./PaxHeaders/gcl-2.7.10000644000000000000000000000013214776130457011442 xustar0030 mtime=1744351535.730906995 30 atime=1744351538.814879383 30 ctime=1744351535.730906995 gcl-2.7.1/0000755000175000017500000000000014776130457010760 5ustar00cammcammgcl-2.7.1/PaxHeaders/elisp0000644000000000000000000000013214776006046012415 xustar0030 mtime=1744309286.154034363 30 atime=1744351538.814879383 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/0000755000175000017500000000000014776006046012070 5ustar00cammcammgcl-2.7.1/elisp/PaxHeaders/ansi-doc.el0000644000000000000000000000013214555472314014511 xustar0030 mtime=1706456268.892732085 30 atime=1744294983.225888945 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/ansi-doc.el0000644000175000017500000000610714555472314014113 0ustar00cammcamm;; 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.7.1/elisp/PaxHeaders/makefile.old0000644000000000000000000000013214776006046014747 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.282034981 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/makefile.old0000644000175000017500000000142614776006046014350 0ustar00cammcamm -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.7.1/elisp/PaxHeaders/sshell.el0000644000000000000000000000013214555472314014306 xustar0030 mtime=1706456268.892732085 30 atime=1744294983.237888998 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/sshell.el0000644000175000017500000003200314555472314013702 0ustar00cammcamm ;; 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.7.1/elisp/PaxHeaders/doc-to-texi.el0000644000000000000000000000013214555472314015150 xustar0030 mtime=1706456268.892732085 30 atime=1744294983.241889015 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/doc-to-texi.el0000644000175000017500000001032014555472314014542 0ustar00cammcamm (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.7.1/elisp/PaxHeaders/smart-complete.el0000644000000000000000000000013114542551763015751 xustar0029 mtime=1703597043.06002252 30 atime=1744294983.241889015 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/smart-complete.el0000644000175000017500000001172114542551763015352 0ustar00cammcamm;; 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.7.1/elisp/PaxHeaders/add-default.el0000644000000000000000000000013214542551763015170 xustar0030 mtime=1703597043.056022514 30 atime=1744294983.241889015 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/add-default.el0000644000175000017500000000016714542551763014572 0ustar00cammcamm ;;;BEGIN gcl addition (autoload 'dbl "dbl" "Make a debugger to run lisp, maxima and or gdb in" t) ;;;END gcl addition gcl-2.7.1/elisp/PaxHeaders/gcl.el0000644000000000000000000000013214555472314013561 xustar0030 mtime=1706456268.892732085 30 atime=1744294983.241889015 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/gcl.el0000644000175000017500000002665314555472314013173 0ustar00cammcamm;; 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.7.1/elisp/PaxHeaders/man1-to-texi.el0000644000000000000000000000013214555472314015237 xustar0030 mtime=1706456268.892732085 30 atime=1744294983.241889015 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/man1-to-texi.el0000644000175000017500000003311614555472314014641 0ustar00cammcamm;;;;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.7.1/elisp/PaxHeaders/readme0000644000000000000000000000013214555472314013652 xustar0030 mtime=1706456268.892732085 30 atime=1744294983.241889015 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/readme0000644000175000017500000000035414555472314013252 0ustar00cammcamm 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.7.1/elisp/PaxHeaders/dbl.el0000644000000000000000000000013214555472314013555 xustar0030 mtime=1706456268.892732085 30 atime=1744294983.241889015 30 ctime=1744351535.714907138 gcl-2.7.1/elisp/dbl.el0000644000175000017500000005456414555472314013171 0ustar00cammcamm;; 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 keys &optional doc) (let ((keys (if (consp keys) keys (list keys))) (fun (intern (format "dbl-%s" (read name))))) `(progn (defun ,fun (arg) ,(or doc "") (interactive "p") (dbl-call ,name arg) ,@(mapcar #'(lambda (key) `(define-key dbl-mode-map ,key ',fun)) keys))))) (def-dbl ":step %p" ("\M-s" "\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" "\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") (defvar dbl-last-frame nil) (defvar dbl-last-frame-displayed-p t) (defvar dbl-delete-prompt-marker nil) (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 (;; important for winnt version of emacs (binary-process-input t) (binary-process-output nil) (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 (cond ((string-match "\032\032\\([A-Za-z]?:?[^:]*\\):\\([0-9]*\\):[^\n]+\n" string) (setq dbl-last-frame (cons (match-string 1 string) (string-to-number (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))) (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)) (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 ((progn (beginning-of-line) (get-text-property (point) 'file-line))) ((progn (end-of-line) (re-search-backward " \\([^: ]+\\):\\([0-9]+\\)" 300 nil)) (let* ((file (buffer-substring (match-beginning 1) (match-end 1))) (line (buffer-substring (match-beginning 2) (match-end 2))) (line (read line)) (file (search-path file 'dbl-dirs))) (and (integerp line) file (list file line)))))) (t (list (buffer-file-name) (+ 1 (if (featurep 'xemacs) (line-number) (line-number-at-pos)))))))) (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) (process-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 (if (featurep 'xemacs) (line-number) (line-number-at-pos))))))))) (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) (process-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))) (process-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 (point)) begin (found (if (search-backward "0x" (- pt 7) t) (point)))) (cond (found (forward-char 2) (buffer-substring found (progn (re-search-forward "[^0-9a-f]") (forward-char -1) (point)))) (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1) (point))) (forward-char 1) (re-search-forward "[^0-9]") (forward-char -1) (buffer-substring begin (point))))))) (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 (point-max)) (insert comm))) (provide 'dbl) gcl-2.7.1/PaxHeaders/bin0000644000000000000000000000013214776130457012055 xustar0030 mtime=1744351535.566908465 30 atime=1744351538.814879383 30 ctime=1744351535.566908465 gcl-2.7.1/bin/0000755000175000017500000000000014776130457011530 5ustar00cammcammgcl-2.7.1/bin/PaxHeaders/dpp.c0000644000000000000000000000013214776006046013055 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.566908465 gcl-2.7.1/bin/dpp.c0000755000175000017500000003104514776006046012461 0ustar00cammcamm/* 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(int argc, char *argv[]) { if (argc != 3) error("arg count"); if (sscanf(argv[1],"%s.d",filename)!=1) error("bad filename\n"); if (!(in = fopen(argv[1], "r"))) error("can't open input file"); out = fopen(argv[2], "w"); if (!(out = fopen(argv[2], "w"))) error("can't open output file"); printf("dpp: %s -> ", argv[1]); printf("%s\n", argv[2]); main_loop(); return 0; } gcl-2.7.1/bin/PaxHeaders/gcl.in0000644000000000000000000000013214776006046013223 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.246034807 30 ctime=1744351535.438909613 gcl-2.7.1/bin/gcl.in0000755000175000017500000000146214776006046012627 0ustar00cammcamm#!/bin/sh EXT=@EXT@ VERS=@VERSION@ if [ -e /etc/default/gcl$EXT ] ; then . /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 fi DIR=@prefix@/lib/gcl-$VERS; if [ "$GCL_ANSI" = "" ] ; then if [ "$GCL_PROF" = "" ] ; then EXE=saved_gcl; else EXE=saved_gcl_gprof; fi else if [ "$GCL_PROF" = "" ] ; then EXE=saved_ansi_gcl; else EXE=saved_ansi_gcl_gprof; fi fi SYS=$DIR/unixport exec $SYS/$EXE -dir $SYS/ -libdir $DIR/ \ -eval '(setq si::*allow-gzipped-file* t)' \ -eval '(setq si::*tk-library* "@TK_CONFIG_PREFIX@")' \ -eval "(setq si::*default-info-files* (list \"gcl$EXT-si.info\" \"gcl$EXT-tk.info\" \"gcl$EXT-dwdoc.info\" \"gcl$EXT.info\"))" \ "$@" gcl-2.7.1/PaxHeaders/man0000644000000000000000000000013214776130457012060 xustar0030 mtime=1744351535.390910043 30 atime=1744351538.814879383 30 ctime=1744351535.390910043 gcl-2.7.1/man/0000755000175000017500000000000014776130457011533 5ustar00cammcammgcl-2.7.1/man/PaxHeaders/man10000644000000000000000000000013214776130457012714 xustar0030 mtime=1744351535.438909613 30 atime=1744351538.814879383 30 ctime=1744351535.438909613 gcl-2.7.1/man/man1/0000755000175000017500000000000014776130457012367 5ustar00cammcammgcl-2.7.1/man/man1/PaxHeaders/gcl.10000644000000000000000000000013214556243153013612 xustar0030 mtime=1706641003.278613412 30 atime=1744295000.509964594 30 ctime=1744351535.438909613 gcl-2.7.1/man/man1/gcl.10000755000175000017500000001330014556243153013210 0ustar00cammcamm.TH GCL 1 "17 March 1997" .SH NAME gcl \- GCL Common Lisp interpreter/compiler .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\ [pathname] .RB Open the file following .B \-f for input (or use *standard-input* if not supplied), 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 .B \-f switch. 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.7.1/PaxHeaders/bench0000644000000000000000000000013114776006046012357 xustar0030 mtime=1744309286.150034344 30 atime=1744351538.814879383 29 ctime=1744351535.72690703 gcl-2.7.1/bench/0000755000175000017500000000000014776006046012033 5ustar00cammcammgcl-2.7.1/bench/PaxHeaders/fft.cl0000644000000000000000000000013214776006046013534 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/fft.cl0000644000175000017500000000720614776006046013137 0ustar00cammcamm;; $Header$ ;; $Locker$ ;; FFT -- This is an FFT benchmark written by Harry Barrow. ;; It tests a variety of floating point operations, including array references. (eval-when (compile) (setq *READ-DEFAULT-FLOAT-FORMAT* 'double-float) ) (defvar **fft-re** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (defvar **fft-im** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (declaim (type (vector double-float) **fft-re** **fft-im**)) (defvar s-pi (float pi 0.0)) (declaim (double-float s-pi)) (defun fft (areal aimag) (declare (type (simple-array double-float (*)) areal aimag)) (prog* ((ar areal) (ai aimag) (i 1) (j 0) (k 0) (m 0) ;compute m = log(n) (n (1- (array-dimension ar 0))) (nv2 (floor n 2)) (le 0) (le1 0) (ip 0) (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) (declare (type fixnum i j k n nv2 m le le1 ip)) (declare (type (simple-array double-float (*)) ar ai)) (declare (double-float ur ui wr wi tr ti)) l1 (cond ((< i n) (setq m (the fixnum (1+ m)) i (the fixnum (+ i i))) (go l1))) (cond ((not (equal n (the fixnum (expt 2 m)))) (princ "error ... array size not a power of two.") (read) (return (terpri)))) (setq j 1 ;interchange elements i 1) ;in bit-reversed order l3 (cond ((< i j) (setq tr (aref ar j) ti (aref ai j)) (setf (aref ar j) (aref ar i)) (setf (aref ai j) (aref ai i)) (setf (aref ar i) tr) (setf (aref ai i) ti))) (setq k nv2) l6 (cond ((< k j) (setq j (the fixnum (- j k)) k (the fixnum (/ k 2))) (go l6))) (setq j (the fixnum (+ j k)) i (the fixnum (1+ i))) (cond ((< i n) (go l3))) (do ((l 1 (the fixnum (1+ (the fixnum l))))) ((> (the fixnum l) m)) ;loop thru stages (declare (type fixnum l)) (setq le (the fixnum (expt 2 l)) le1 (the (values fixnum fixnum) (floor le 2)) ur 1.0 ui 0.0 wr (cos (/ s-pi (float le1))) wi (sin (/ s-pi (float le1)))) (do ((j 1 (the fixnum (1+ (the fixnum j))))) ((> (the fixnum j) le1)) ;loop thru butterflies (declare (type fixnum j)) (do ((i j (+ (the fixnum i) le))) ((> (the fixnum i) n)) ;do a butterfly (declare (type fixnum i)) (setq ip (the fixnum (+ i le1)) tr (- (* (aref ar ip) ur) (* (aref ai ip) ui)) ti (+ (* (aref ar ip) ui) (* (aref ai ip) ur))) (setf (aref ar ip) (- (aref ar i) tr)) (setf (aref ai ip) (- (aref ai i) ti)) (setf (aref ar i) (+ (aref ar i) tr)) (setf (aref ai i) (+ (aref ai i) ti)))) (setq tr (- (* ur wr) (* ui wi)) ti (+ (* ur wi) (* ui wr)) ur tr ui ti)) (return t))) (defun fft-bench () (dotimes (i 10) (fft **fft-re** **fft-im**))) (defun testfft () (print (time (fft-bench)))) ;;; ;;; the following are for verifying that the implementation gives the ;;; correct result ;;; (defun clear-fft () (dotimes (i 1025) (setf (aref **fft-re** i) 0.0 (aref **fft-im** i) 0.0)) (values)) (defun setup-fft-component (theta &optional (phase 0.0)) (let ((f (* 2 pi theta)) (c (cos (* 0.5 pi phase))) (s (sin (* 0.5 pi phase)))) (dotimes (i 1025) (let ((x (sin (* f (/ i 1024.0))))) (incf (aref **fft-re** i) (float (* c x) 0.0)) (incf (aref **fft-im** i) (float (* s x) 0.0))))) (values)) (defvar fft-delta 0.0001) (defun print-fft () (dotimes (i 1025) (let ((re (aref **fft-re** i)) (im (aref **fft-im** i))) (unless (and (< (abs re) fft-delta) (< (abs im) fft-delta)) (format t "~4d ~10f ~10f~%" i re im)))) (values)) gcl-2.7.1/bench/PaxHeaders/takl.cl0000644000000000000000000000013114542551763013711 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.017791491 29 ctime=1744351535.72690703 gcl-2.7.1/bench/takl.cl0000644000175000017500000000102014542551763013301 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; TAKL -- The TAKeuchi function using lists as counters. (defun listn (n) (declare (type fixnum n)) (if (not (= 0 n)) (cons n (listn (the fixnum (1- n)))))) (defvar 18l (listn 18)) (defvar 12l (listn 12)) (defvar 6l (listn 6)) (defun mas (x y z) (if (not (shorterp y x)) z (mas (mas (cdr x) y z) (mas (cdr y) z x) (mas (cdr z) x y)))) (defun shorterp (x y) (and y (or (null x) (shorterp (cdr x) (cdr y))))) (defun testtakl () (print (time (mas 18l 12l 6l)))) gcl-2.7.1/bench/PaxHeaders/sbcl_tim0000644000000000000000000000013114776006046014153 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.246034807 29 ctime=1744351535.72690703 gcl-2.7.1/bench/sbcl_tim0000644000175000017500000000075614776006046013562 0ustar00cammcamm_ sbcl_ref 20250408_x86_64 BOYER 0.337 BROWSE 0.409 CTAK 0.046 DDERIV 0.096 DERIV 0.094 DESTRU 0.190 DESTRU-MOD 0.190 DIV2 0.209 FFT 0.395 FFT-MOD 0.423 FPRINT 0.300 FREAD 0.192 FRPOLY 0.561 PUZZLE 0.165 PUZZLE-MOD 0.187 STAK 0.260 TAK 0.724 TAKL 0.549 TAK-MOD 0.713 TAKR 0.105 TPRINT 0.526 TRAVERSE 0.213 TRIANG 0.525 TRIANG-MOD 0.897 gcl-2.7.1/bench/PaxHeaders/fread.cl0000644000000000000000000000013114542551763014037 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.037791579 29 ctime=1744351535.72690703 gcl-2.7.1/bench/fread.cl0000644000175000017500000000051314542551763013435 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; FREAD -- Benchmark to read from a file. ;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created ;;; by FPRINT. (defun fread () (let ((stream (open "/tmp/fprint.tst" :direction :input))) (read stream) (close stream))) (defun testfread () (print (time (fread)))) gcl-2.7.1/bench/PaxHeaders/ctak.cl0000644000000000000000000000013114542551763013700 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.049791632 29 ctime=1744351535.72690703 gcl-2.7.1/bench/ctak.cl0000644000175000017500000000103614542551763013277 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility. (defun ctak (x y z) (catch 'ctak (ctak-aux x y z))) (defun ctak-aux (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) (throw 'ctak z)) (t (ctak-aux (catch 'ctak (ctak-aux (the fixnum (1- x)) y z)) (catch 'ctak (ctak-aux (the fixnum (1- y)) z x)) (catch 'ctak (ctak-aux (the fixnum (1- z)) x y)))))) (defun testctak () (print (time (ctak 18 12 6)))) gcl-2.7.1/bench/PaxHeaders/traverse.cl0000644000000000000000000000013214776006046014610 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/traverse.cl0000644000175000017500000000764614776006046014223 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; TRAVERSE -- Benchmark which creates and traverses a tree structure. (eval-when (eval compile load) (defstruct node (parents ()) (sons ()) (sn (snb)) (entry1 ()) (entry2 ()) (entry3 ()) (entry4 ()) (entry5 ()) (entry6 ()) (mark ())) ) (defvar traverse-sn 0) (defvar traverse-rand 21.) (defvar traverse-count 0) (declaim (type fixnum traverse-sn traverse-rand traverse-count)) (defvar traverse-marker nil) (defvar traverse-root) (setq traverse-sn 0 traverse-rand 21 traverse-count 0 traverse-marker nil) (defun snb () (setq traverse-sn (the fixnum (1+ traverse-sn)))) (defun traverse-seed () (setq traverse-rand 21.)) (defun traverse-random () (setq traverse-rand (the fixnum (rem (the fixnum (* traverse-rand 17)) 251)))) (defun traverse-remove (n q) (declare (type fixnum n)) (cond ((eq (cdr (car q)) (car q)) (prog2 () (caar q) (rplaca q ()))) ((= n 0) (prog2 () (caar q) (do ((p (car q) (cdr p))) ((eq (cdr p) (car q)) (rplaca q (rplacd p (cdr (car q)))))))) (t (do ((n n (the fixnum (1- n))) (q (car q) (cdr q)) (p (cdr (car q)) (cdr p))) ((= n 0) (prog2 () (car q) (rplacd q p))) (declare (type fixnum n)))))) (defun traverse-select (n q) (declare (type fixnum n)) (do ((n n (the fixnum (1- n))) (q (car q) (cdr q))) ((= n 0) (car q)) (declare (type fixnum n)))) (defun traverse-add (a q) (cond ((null q) `(,(let ((x `(,a))) (rplacd x x) x))) ((null (car q)) (let ((x `(,a))) (rplacd x x) (rplaca q x))) (t (rplaca q (rplacd (car q) `(,a .,(cdr (car q)))))))) (defun traverse-create-structure (n) (declare (type fixnum n)) (let ((a `(,(make-node)))) (do ((m (the fixnum (1- n)) (the fixnum (1- m))) (p a)) ((= m 0) (setq a `(,(rplacd p a))) (do ((unused a) (used (traverse-add (traverse-remove 0 a) ())) (x) (y)) ((null (car unused)) (find-root (traverse-select 0 used) n)) (setq x (traverse-remove (the fixnum (rem (the fixnum (traverse-random)) n)) unused)) (setq y (traverse-select (the fixnum (rem (the fixnum (traverse-random)) n)) used)) (traverse-add x used) (setf (node-sons y) `(,x .,(node-sons y))) (setf (node-parents x) `(,y .,(node-parents x))) )) (declare (type fixnum m)) (push (make-node) a)))) (defun find-root (node n) (declare (type fixnum n)) (do ((n n (the fixnum (1- n)))) ((= n 0) node) (declare (type fixnum n)) (cond ((null (node-parents node)) (return node)) (t (setq node (car (node-parents node))))))) (defun travers (node mark) (cond ((eq (node-mark node) mark) ()) (t (setf (node-mark node) mark) (setq traverse-count (the fixnum (1+ traverse-count))) (setf (node-entry1 node) (not (node-entry1 node))) (setf (node-entry2 node) (not (node-entry2 node))) (setf (node-entry3 node) (not (node-entry3 node))) (setf (node-entry4 node) (not (node-entry4 node))) (setf (node-entry5 node) (not (node-entry5 node))) (setf (node-entry6 node) (not (node-entry6 node))) (do ((sons (node-sons node) (cdr sons))) ((null sons) ()) (travers (car sons) mark))))) (defun traverse (traverse-root) (let ((traverse-count 0)) (declare (type fixnum traverse-count)) (travers traverse-root (setq traverse-marker (not traverse-marker))) traverse-count)) (defun init-traverse() (setq traverse-root (traverse-create-structure 100.)) nil) (defun run-traverse () (do ((i 50 (the fixnum (1- (the fixnum i))))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (traverse traverse-root) (traverse traverse-root) (traverse traverse-root) (traverse traverse-root) (traverse traverse-root))) (defun testtraverse () (testtraverse-init) (testtraverse-run)) (defun testtraverse-init () (print (time (init-traverse)))) (defun testtraverse-run () (print (time (run-traverse)))) gcl-2.7.1/bench/PaxHeaders/tak.cl0000644000000000000000000000013114542551763013535 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.105791879 29 ctime=1744351535.72690703 gcl-2.7.1/bench/tak.cl0000644000175000017500000000107714542551763013141 0ustar00cammcamm;; $Header$ ;; $Locker$ #+excl (eval-when (compile) (setq comp::register-use-threshold 6)) (defun tak (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak (tak (the fixnum (1- x)) y z) (tak (the fixnum (1- y)) z x) (tak (the fixnum (1- z)) x y))))) (defun testtak () (print (time (progn (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6))))) #+excl (eval-when (compile) (setq comp::register-use-threshold 3)) gcl-2.7.1/bench/PaxHeaders/deriv.cl0000644000000000000000000000013114542551763014067 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.105791879 29 ctime=1744351535.72690703 gcl-2.7.1/bench/deriv.cl0000644000175000017500000000220614542551763013466 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt. ;;; It uses a simple subset of Lisp and does a lot of CONSing. (defun deriv-aux (a) (list '/ (deriv a) a)) (defun deriv (a) (cond ((atom a) (cond ((eq a 'x) 1) (t 0))) ((eq (car a) '+) (cons '+ (mapcar #'deriv (cdr a)))) ((eq (car a) '-) (cons '- (mapcar #'deriv (cdr a)))) ((eq (car a) '*) (list '* a (cons '+ (mapcar #'deriv-aux (cdr a))))) ((eq (car a) '/) (list '- (list '/ (deriv (cadr a)) (caddr a)) (list '/ (cadr a) (list '* (caddr a) (caddr a) (deriv (caddr a)))))) (t 'error))) (defun deriv-run () (do ((i 0 (the fixnum (1+ i)))) ((= (the fixnum i) 1000.)) ;runs it 5000 times (declare (type fixnum i)) ;improves the code a little (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)))) (defun testderiv () (print (time (deriv-run)))) gcl-2.7.1/bench/PaxHeaders/dderiv.cl0000644000000000000000000000013114542551763014233 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.105791879 29 ctime=1744351535.72690703 gcl-2.7.1/bench/dderiv.cl0000644000175000017500000000415414542551763013636 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt. ;;; This benchmark is a variant of the simple symbolic derivative program ;;; (DERIV). The main change is that it is `table-driven.' Instead of using a ;;; large COND that branches on the CAR of the expression, this program finds ;;; the code that will take the derivative on the property list of the atom in ;;; the CAR position. So, when the expression is (+ . ), the code ;;; stored under the atom '+ with indicator DERIV will take and ;;; return the derivative for '+. The way that MacLisp does this is with the ;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an ;;; atomic name in that it expects an argument list and the compiler compiles ;;; code, but the name of the function with that code is stored on the ;;; property list of FOO under the indicator BAR, in this case. You may have ;;; to do something like: ;;; :property keyword is not Common Lisp. (defun dderiv-aux (a) (list '// (dderiv a) a)) (defun +dderiv (a) (cons '+ (mapcar 'dderiv a))) (defun -dderiv (a) (cons '- (mapcar 'dderiv a))) (defun *dderiv (a) (list '* (cons '* a) (cons '+ (mapcar 'dderiv-aux a)))) (defun //dderiv (a) (list '- (list '// (dderiv (car a)) (cadr a)) (list '// (car a) (list '* (cadr a) (cadr a) (dderiv (cadr a)))))) (mapc #'(lambda (op fun) (setf (get op 'dderiv) (symbol-function fun))) '(+ - * //) '(+dderiv -dderiv *dderiv //dderiv)) (defun dderiv (a) (cond ((atom a) (cond ((eq a 'x) 1) (t 0))) (t (let ((dderiv (get (car a) 'dderiv))) (cond (dderiv (funcall dderiv (cdr a))) (t 'error)))))) (defun dderiv-run () (do ((i 0 (the fixnum (1+ i)))) ((= (the fixnum i) 1000.)) (declare (type fixnum i)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) (defun testdderiv () (print (time (dderiv-run)))) gcl-2.7.1/bench/PaxHeaders/tak-mod.cl0000644000000000000000000000013214776006046014311 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/tak-mod.cl0000644000175000017500000000117714776006046013715 0ustar00cammcamm;; $Header$ ;; $Locker$ #+excl (eval-when (compile) (setq comp::register-use-threshold 6)) (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak)) (defun tak (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak (tak (the fixnum (1- x)) y z) (tak (the fixnum (1- y)) z x) (tak (the fixnum (1- z)) x y))))) (defun testtak () (print (time (progn (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6))))) #+excl (eval-when (compile) (setq comp::register-use-threshold 3)) gcl-2.7.1/bench/PaxHeaders/stak.cl0000644000000000000000000000013214776006046013717 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/stak.cl0000644000175000017500000000132614776006046013317 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; STAK -- The TAKeuchi function with special variables instead of ;;; parameter passing. (defvar stak-x) (defvar stak-y) (defvar stak-z) (declaim (fixnum stak-x stak-y stak-z)) (defun stak (stak-x stak-y stak-z) (stak-aux)) (defun stak-aux () (if (not (< stak-y stak-x)) stak-z (let ((stak-x (let ((stak-x (the fixnum (1- stak-x))) (stak-y stak-y) (stak-z stak-z)) (stak-aux))) (stak-y (let ((stak-x (the fixnum (1- stak-y))) (stak-y stak-z) (stak-z stak-x)) (stak-aux))) (stak-z (let ((stak-x (the fixnum (1- stak-z))) (stak-y stak-x) (stak-z stak-y)) (stak-aux)))) (stak-aux)))) (defun teststak () (print (time (stak 18 12 6)))) gcl-2.7.1/bench/PaxHeaders/destru-mod.cl0000644000000000000000000000013114542551763015041 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.105791879 29 ctime=1744351535.72690703 gcl-2.7.1/bench/destru-mod.cl0000644000175000017500000000266214542551763014446 0ustar00cammcamm;; $Header$ ;; $Locker$ ;; DESTRU -- Destructive operation benchmark ;;mod: add fixnum declaration for n in the following let: ;; (let ((n (floor (the fixnum (length (car l1))) 2))) (defun destructive (n m) (declare (type fixnum n m)) (let ((l (do ((i 10. (the fixnum (1- i))) (a () (push () a))) ((= (the fixnum i) 0) a) (declare (type fixnum i))))) (do ((i n (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (cond ((null (car l)) (do ((l l (cdr l))) ((null l)) (or (car l) (rplaca l (cons () ()))) (nconc (car l) (do ((j m (the fixnum (1- j))) (a () (push () a))) ((= (the fixnum j) 0) a) (declare (type fixnum j)))))) (t (do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2))) ((null l2)) (rplacd (do ((j (floor (the fixnum (length (car l2))) 2) (the fixnum (1- j))) (a (car l2) (cdr a))) ((zerop (the fixnum j)) a) (declare (type fixnum j)) (rplaca a i)) (let ((n (floor (the fixnum (length (car l1))) 2))) (declare (fixnum n)) (cond ((= (the fixnum n) 0) (rplaca l1 ()) (car l1)) (t (do ((j n (the fixnum (1- j))) (a (car l1) (cdr a))) ((= (the fixnum j) 1) (prog1 (cdr a) (rplacd a ()))) (declare (type fixnum j)) (rplaca a i)))))))))))) (defun testdestru () (print (time (destructive 600 50)))) gcl-2.7.1/bench/PaxHeaders/puzzle.cl0000644000000000000000000000013114776006046014305 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 29 ctime=1744351535.72690703 gcl-2.7.1/bench/puzzle.cl0000644000175000017500000001157214776006046013712 0ustar00cammcamm;; $Header$ ;; $Locker$ (eval-when (compile load eval) (defconstant puzzle-size 511.) (defconstant puzzle-classmax 3.) (defconstant puzzle-typemax 12.)) (defvar **iii** 0) (defvar **kount** 0) (defvar puzzle-d 8.) (declaim (type fixnum **iii** **kount** puzzle-d)) (defvar piececount (make-array (1+ puzzle-classmax) :initial-element 0)) (defvar puzzle-class (make-array (1+ puzzle-typemax) :initial-element 0)) (defvar piecemax (make-array (1+ puzzle-typemax) :initial-element 0)) (defvar puzzle (make-array (1+ puzzle-size))) (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) (declaim (type simple-vector piececount puzzle-class piecemax puzzle)) (declaim (type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) (defun fit (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end) t) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (cond ((aref puzzle (the fixnum (+ j k))) (return nil)))))))) (defun place (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) t)))) (setf (aref piececount (aref puzzle-class i)) (the fixnum (- (the fixnum (aref piececount (aref puzzle-class i))) 1))) (do ((k j (the fixnum (1+ k)))) ((> k puzzle-size) (terpri) (princ "Puzzle filled") 0) (declare (type fixnum k)) (cond ((not (aref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (type fixnum i j)) (let ((end (aref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) nil)))) (setf (aref piececount (aref puzzle-class i)) (+ (the fixnum (aref piececount (aref puzzle-class i))) 1)))) (defun trial (j) (declare (type fixnum j)) (let ((k 0)) (declare (type fixnum k)) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax) (setq **kount** (the fixnum (1+ **kount**))) nil) (declare (type fixnum i)) (cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) (setq **kount** (the fixnum (+ **kount** 1))) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (type fixnum ii jj kk)) (let ((index 0)) (declare (type fixnum index)) (do ((i 0 (the fixnum (1+ i)))) ((> i ii)) (declare (type fixnum i)) (do ((j 0 (the fixnum (1+ j)))) ((> j jj)) (declare (type fixnum j)) (do ((k 0 (the fixnum (1+ k)))) ((> k kk)) (declare (type fixnum k)) (setq index (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) (setf (aref puzzle-p **iii** index) t)))) (setf (aref puzzle-class **iii**) iclass) (setf (aref piecemax **iii**) index) (cond ((not (= **iii** puzzle-typemax)) (setq **iii** (the fixnum (+ **iii** 1))))))) (defun puzzle-start () (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle m) t)) (do ((i 1 (the fixnum (1+ i)))) ((> i 5)) (declare (type fixnum i)) (do ((j 1 (the fixnum (1+ j)))) ((> j 5)) (declare (type fixnum j)) (do ((k 1 (the fixnum (1+ k)))) ((> k 5)) (declare (type fixnum k)) (setf (aref puzzle (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) nil)))) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax)) (declare (type fixnum i)) (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle-p i m) nil))) (setq **iii** 0) (definepiece 0 3 1 0) (definepiece 0 1 0 3) (definepiece 0 0 3 1) (definepiece 0 1 3 0) (definepiece 0 3 0 1) (definepiece 0 0 1 3) (definepiece 1 2 0 0) (definepiece 1 0 2 0) (definepiece 1 0 0 2) (definepiece 2 1 1 0) (definepiece 2 1 0 1) (definepiece 2 0 1 1) (definepiece 3 1 1 1) (setf (aref piececount 0) 13.) (setf (aref piececount 1) 3) (setf (aref piececount 2) 1) (setf (aref piececount 3) 1) (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) (n 0)(**kount** 0)) (declare (type fixnum m n **kount**)) (cond ((fit 0 m) (setq n (place 0 m))) (t (format t "~%Error."))) (cond ((trial n) (format t "~%Success in ~4D trials." **kount**)) (t (format t "~%Failure."))))) (defun testpuzzle () (time (puzzle-start))) gcl-2.7.1/bench/PaxHeaders/puzzle-mod.cl0000644000000000000000000000013214776006046015063 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/puzzle-mod.cl0000644000175000017500000001216114776006046014462 0ustar00cammcamm;; $Header$ ;; $Locker$ (eval-when (compile load eval) (defconstant puzzle-size 511.) (defconstant puzzle-classmax 3.) (defconstant puzzle-typemax 12.)) (defvar **iii** 0) (defvar **kount** 0) (defvar puzzle-d 8.) (declaim (type fixnum **iii** **kount** puzzle-d)) (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) (defvar puzzle (make-array (1+ puzzle-size))) (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) (declaim (type (array fixnum) piececount puzzle-class piecemax)) (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) (declaim (type simple-vector puzzle)) (declaim (type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) (defun fit (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end) t) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (cond ((aref puzzle (the fixnum (+ j k))) (return nil)))))))) (declaim (ftype (function (fixnum fixnum) fixnum) place)) (defun jil () 3) (defun place (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) t)))) (setf (fref piececount (fref puzzle-class i)) (the fixnum (- (the fixnum (fref piececount (fref puzzle-class i))) 1))) (do ((k j (the fixnum (1+ k)))) ((> k puzzle-size) (terpri) (princ "Puzzle filled") 0) (declare (type fixnum k)) (cond ((not (aref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (type fixnum i j)) (let ((end (fref piecemax i))) (declare (type fixnum end)) (do ((k 0 (the fixnum (1+ k)))) ((> k end)) (declare (type fixnum k)) (cond ((aref puzzle-p i k) (setf (aref puzzle (the fixnum (+ j k))) nil)))) (setf (fref piececount (fref puzzle-class i)) (the fixnum (+ (the fixnum (fref piececount (fref puzzle-class i))) 1))))) (defun trial (j) (declare (type fixnum j)) (let ((k 0)) (declare (type fixnum k)) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax) (setq **kount** (the fixnum (1+ **kount**))) nil) (declare (type fixnum i)) (cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) (setq **kount** (the fixnum (+ **kount** 1))) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (type fixnum ii jj kk)) (let ((index 0)) (declare (type fixnum index)) (do ((i 0 (the fixnum (1+ i)))) ((> i ii)) (declare (type fixnum i)) (do ((j 0 (the fixnum (1+ j)))) ((> j jj)) (declare (type fixnum j)) (do ((k 0 (the fixnum (1+ k)))) ((> k kk)) (declare (type fixnum k)) (setq index (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) (setf (aref puzzle-p **iii** index) t)))) (setf (fref puzzle-class **iii**) iclass) (setf (fref piecemax **iii**) index) (cond ((not (= **iii** puzzle-typemax)) (setq **iii** (the fixnum (+ **iii** 1))))))) (defun puzzle-start () (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle m) t)) (do ((i 1 (the fixnum (1+ i)))) ((> i 5)) (declare (type fixnum i)) (do ((j 1 (the fixnum (1+ j)))) ((> j 5)) (declare (type fixnum j)) (do ((k 1 (the fixnum (1+ k)))) ((> k 5)) (declare (type fixnum k)) (setf (aref puzzle (+ i (the fixnum (* puzzle-d (the fixnum (+ j (the fixnum (* puzzle-d k)))))))) nil)))) (do ((i 0 (the fixnum (1+ i)))) ((> i puzzle-typemax)) (declare (type fixnum i)) (do ((m 0 (the fixnum (1+ m)))) ((> m puzzle-size)) (declare (type fixnum m)) (setf (aref puzzle-p i m) nil))) (setq **iii** 0) (definepiece 0 3 1 0) (definepiece 0 1 0 3) (definepiece 0 0 3 1) (definepiece 0 1 3 0) (definepiece 0 3 0 1) (definepiece 0 0 1 3) (definepiece 1 2 0 0) (definepiece 1 0 2 0) (definepiece 1 0 0 2) (definepiece 2 1 1 0) (definepiece 2 1 0 1) (definepiece 2 0 1 1) (definepiece 3 1 1 1) (setf (fref piececount 0) 13.) (setf (fref piececount 1) 3) (setf (fref piececount 2) 1) (setf (fref piececount 3) 1) (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) (n 0)(**kount** 0)) (declare (type fixnum m n **kount**)) (cond ((fit 0 m) (setq n (place 0 m))) (t (format t "~%Error."))) (cond ((trial n) (format t "~%Success in ~4D trials." **kount**)) (t (format t "~%Failure."))))) (defun testpuzzle () (time (puzzle-start))) gcl-2.7.1/bench/PaxHeaders/test-help.lsp0000644000000000000000000000013114776006046015061 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 29 ctime=1744351535.72690703 gcl-2.7.1/bench/test-help.lsp0000644000175000017500000000215114776006046014457 0ustar00cammcamm(defvar *repeats* '(("destru" 4)("destru-mod" 4) ("fprint" 4)("fread" 4)("tprint" 4) ("tak-mod" 4)("tak" 4)("takl" 4)("stak" 4)("takr" 4) ("fft" 10)("fft-mod" 10) ("traverse" 0.1)("triang-mod" 0.1)("triang" 0.1))) (defun do-test (file output &optional (n (or (cadr (assoc (pathname-name file) *repeats* :test 'equal)) 1)) (scale 100)) (load file) (let* ((file (pathname-name file)) (pos (position #\- file))) (let ((command (intern (string-upcase (format nil "TEST~a" (if pos (subseq file 0 pos) file)))))) (let ((start (get-internal-run-time))) (with-open-file (s "/dev/null" :direction :output :if-exists :append) (let ((*trace-output* s)(*standard-output* s)) (dotimes (i (truncate (* n scale))) (funcall command)))) (setq start (- (get-internal-run-time) start)) (setq start (float start));(setq start (/ (float start) n)) (with-open-file (st output :direction :output :if-exists :append :if-does-not-exist :create) (format st "~:@(~a~)~,12t~,3f~%" file (/ start (float internal-time-units-per-second))) (force-output st) ))))) gcl-2.7.1/bench/PaxHeaders/gcl_tim0000644000000000000000000000013114776006046013775 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.246034807 29 ctime=1744351535.72690703 gcl-2.7.1/bench/gcl_tim0000644000175000017500000000075514776006046013403 0ustar00cammcamm_ gcl_ref 20250408_x86_64 BOYER 0.250 BROWSE 0.490 CTAK 0.290 DDERIV 0.150 DERIV 0.170 DESTRU 0.630 DESTRU-MOD 0.620 DIV2 0.250 FFT 0.220 FFT-MOD 0.210 FPRINT 0.290 FREAD 0.140 FRPOLY 0.670 PUZZLE 0.120 PUZZLE-MOD 0.110 STAK 0.200 TAK 0.390 TAKL 0.200 TAK-MOD 0.390 TAKR 0.090 TPRINT 0.340 TRAVERSE 0.250 TRIANG 0.310 TRIANG-MOD 0.260 gcl-2.7.1/bench/PaxHeaders/frpoly.cl0000644000000000000000000000013114542551763014271 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.165792141 29 ctime=1744351535.72690703 gcl-2.7.1/bench/frpoly.cl0000644000175000017500000001262414542551763013675 0ustar00cammcamm;; $Header$ ;; $Locker$ ;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic. ;; Originally writen in Franz Lisp by Richard Fateman. ;; PDIFFER1 appears in the code, but is not defined; is not called for in this ;; test, however. ;; ;; This contain 2 fixes from Gabriel's book. ;; ;; "ptimes3": after label 'b', change the "if" to a "cond". ;; The "go" should be activated when the condition ;; holds, NOT when it fails. ;; ;; The variables *x*, u*, and v are used specially, since this is ;; used to handle polynomial coefficients in a recursive ;; way. Declaring them global is the wrong approach. (defvar ans) (defvar coef) (defvar f) (defvar inc) (defvar i) (defvar qq) (defvar ss) (defvar v) (defvar *x*) (defvar *alpha*) (defvar *a*) (defvar *b*) (defvar *chk) (defvar *l) (defvar *p) (defvar q*) (defvar u*) (defvar *var) (defvar *y*) (defvar r) (defvar r2) (defvar r3) (defvar start) (defvar res1) (defvar res2) (defvar res3) (defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order))) (defmacro pcoefp (e) `(atom ,e)) (defmacro pzerop (x) `(if (numberp ,x) ; no signp in CL (zerop ,x))) (defmacro pzero () 0) (defmacro cplus (x y) `(+ ,x ,y)) (defmacro ctimes (x y) `(* ,x ,y)) (defun pcoefadd (e c x) (if (pzerop c) x (cons e (cons c x)))) (defun pcplus (c p) (if (pcoefp p) (cplus p c) (psimp (car p) (pcplus1 c (cdr p))))) (defun pcplus1 (c x) (cond ((null x) (if (pzerop c) nil (cons 0 (cons c nil)))) ((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil)) (t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x))))))) (defun pctimes (c p) (if (pcoefp p) (ctimes c p) (psimp (car p) (pctimes1 c (cdr p))))) (defun pctimes1 (c x) (if (null x) nil (pcoefadd (car x) (ptimes c (cadr x)) (pctimes1 c (cddr x))))) (defun pplus (x y) (cond ((pcoefp x) (pcplus x y)) ((pcoefp y) (pcplus y x)) ((eq (car x) (car y)) (psimp (car x) (pplus1 (cdr y) (cdr x)))) ((pointergp (car x) (car y)) (psimp (car x) (pcplus1 y (cdr x)))) (t (psimp (car y) (pcplus1 x (cdr y)))))) (defun pplus1 (x y) (cond ((null x) y) ((null y) x) ((= (car x) (car y)) (pcoefadd (car x) (pplus (cadr x) (cadr y)) (pplus1 (cddr x) (cddr y)))) ((> (car x) (car y)) (cons (car x) (cons (cadr x) (pplus1 (cddr x) y)))) (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y))))))) (defun psimp (var x) (cond ((null x) 0) ((atom x) x) ((zerop (car x)) (cadr x)) (t (cons var x)))) (defun ptimes (x y) (cond ((or (pzerop x) (pzerop y)) (pzero)) ((pcoefp x) (pctimes x y)) ((pcoefp y) (pctimes y x)) ((eq (car x) (car y)) (psimp (car x) (ptimes1 (cdr x) (cdr y)))) ((pointergp (car x) (car y)) (psimp (car x) (pctimes1 y (cdr x)))) (t (psimp (car y) (pctimes1 x (cdr y)))))) (defun ptimes1 (*x* y) (prog (u* v) (setq v (setq u* (ptimes2 y))) a (setq *x* (cddr *x*)) (if (null *x*) (return u*)) (ptimes3 y) (go a))) (defun ptimes2 (y) (if (null y) nil (pcoefadd (+ (car *x*) (car y)) (ptimes (cadr *x*) (cadr y)) (ptimes2 (cddr y))))) (defun ptimes3 (y) (prog (e u c) a1 (if (null y) (return nil)) (setq e (+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*) )) (cond ((pzerop c) (setq y (cddr y)) (go a1)) ((or (null v) (> e (car v))) (setq u* (setq v (pplus1 u* (list e c)))) (setq y (cddr y)) (go a1)) ((= e (car v)) (setq c (pplus c (cadr v))) (if (pzerop c) ; never true, evidently (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))) (rplaca (cdr v) c)) (setq y (cddr y)) (go a1))) a (cond ((and (cddr v) (> (caddr v) e)) (setq v (cddr v)) (go a))) (setq u (cdr v)) b (cond ((or (null (cdr u)) (< (cadr u) e)) (rplacd u (cons e (cons c (cdr u)))) (go e))) (cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d)) (t (rplaca (cddr u) c))) e (setq u (cddr u)) d (setq y (cddr y)) (if (null y) (return nil)) (setq e (+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*))) c (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c))) (go b))) (defun pexptsq (p n) (do ((n (floor n 2) (floor n 2)) (s (if (oddp n) p 1))) ((zerop n) s) (setq p (ptimes p p)) (and (oddp n) (setq s (ptimes s p))))) (eval-when (load eval) (setf (get 'x 'order) 1) (setf (get 'y 'order) 2) (setf (get 'z 'order) 3) (setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1))) ; r= x+y+z+1 r2 (ptimes r 100000) ; r2 = 100000*r r3 (ptimes r 1.0))) ; r3 = r with floating point coefficients (defun standard-frpoly-test1 () (progn (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) nil)) (defun standard-frpoly-test2 () (progn (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5) nil)) (defun standard-frpoly-test3 () (progn (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10) nil)) (defun standard-frpoly-test4 () (progn (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15) nil)) (defun testfrpoly () (testfrpoly-1) (testfrpoly-2) (testfrpoly-3) (testfrpoly-4)) (defun testfrpoly-1 () (print (time (standard-frpoly-test1)))) (defun testfrpoly-2 () (print (time (standard-frpoly-test2)))) (defun testfrpoly-3 () (print (time (standard-frpoly-test3)))) (defun testfrpoly-4 () (print (time (standard-frpoly-test4)))) gcl-2.7.1/bench/PaxHeaders/div2.cl0000644000000000000000000000013114542551763013622 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.165792141 29 ctime=1744351535.72690703 gcl-2.7.1/bench/div2.cl0000644000175000017500000000216614542551763013226 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. ;;; This file contains a recursive as well as an iterative test. (defun create-n (n) (declare (type fixnum n)) (do ((n n (the fixnum (1- n))) (a () (push () a))) ((= (the fixnum n) 0) a) (declare (type fixnum n)))) (defvar ll (create-n 200.)) (defun iterative-div2 (l) (do ((l l (cddr l)) (a () (push (car l) a))) ((null l) a))) (defun recursive-div2 (l) (cond ((null l) ()) (t (cons (car l) (recursive-div2 (cddr l)))))) (defun test-1 (l) (do ((i 300 (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l))) (defun test-2 (l) (do ((i 300 (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (recursive-div2 l) (recursive-div2 l) (recursive-div2 l) (recursive-div2 l))) (defun testdiv2 () (testdiv2-iter) (testdiv2-recur)) (defun testdiv2-iter () (print (time (test-1 ll)))) (defun testdiv2-recur () (print (time (test-2 ll)))) gcl-2.7.1/bench/PaxHeaders/takr.cl0000644000000000000000000000013114542551763013717 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.165792141 29 ctime=1744351535.72690703 gcl-2.7.1/bench/takr.cl0000644000175000017500000004722614542551763013331 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache ;;; memory effects. Results should be the same as for TAK on stack machines. ;;; Distribution of calls is not completely flat. (defun tak0 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak1 (tak37 (the fixnum (1- x)) y z) (tak11 (the fixnum (1- y)) z x) (tak17 (the fixnum (1- z)) x y))))) (defun tak1 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak2 (tak74 (the fixnum (1- x)) y z) (tak22 (the fixnum (1- y)) z x) (tak34 (the fixnum (1- z)) x y))))) (defun tak2 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak3 (tak11 (the fixnum (1- x)) y z) (tak33 (the fixnum (1- y)) z x) (tak51 (the fixnum (1- z)) x y))))) (defun tak3 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak4 (tak48 (the fixnum (1- x)) y z) (tak44 (the fixnum (1- y)) z x) (tak68 (the fixnum (1- z)) x y))))) (defun tak4 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak5 (tak85 (the fixnum (1- x)) y z) (tak55 (the fixnum (1- y)) z x) (tak85 (the fixnum (1- z)) x y))))) (defun tak5 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak6 (tak22 (the fixnum (1- x)) y z) (tak66 (the fixnum (1- y)) z x) (tak2 (the fixnum (1- z)) x y))))) (defun tak6 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak7 (tak59 (the fixnum (1- x)) y z) (tak77 (the fixnum (1- y)) z x) (tak19 (the fixnum (1- z)) x y))))) (defun tak7 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak8 (tak96 (the fixnum (1- x)) y z) (tak88 (the fixnum (1- y)) z x) (tak36 (the fixnum (1- z)) x y))))) (defun tak8 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak9 (tak33 (the fixnum (1- x)) y z) (tak99 (the fixnum (1- y)) z x) (tak53 (the fixnum (1- z)) x y))))) (defun tak9 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak10 (tak70 (the fixnum (1- x)) y z) (tak10 (the fixnum (1- y)) z x) (tak70 (the fixnum (1- z)) x y))))) (defun tak10 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak11 (tak7 (the fixnum (1- x)) y z) (tak21 (the fixnum (1- y)) z x) (tak87 (the fixnum (1- z)) x y))))) (defun tak11 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak12 (tak44 (the fixnum (1- x)) y z) (tak32 (the fixnum (1- y)) z x) (tak4 (the fixnum (1- z)) x y))))) (defun tak12 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak13 (tak81 (the fixnum (1- x)) y z) (tak43 (the fixnum (1- y)) z x) (tak21 (the fixnum (1- z)) x y))))) (defun tak13 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak14 (tak18 (the fixnum (1- x)) y z) (tak54 (the fixnum (1- y)) z x) (tak38 (the fixnum (1- z)) x y))))) (defun tak14 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak15 (tak55 (the fixnum (1- x)) y z) (tak65 (the fixnum (1- y)) z x) (tak55 (the fixnum (1- z)) x y))))) (defun tak15 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak16 (tak92 (the fixnum (1- x)) y z) (tak76 (the fixnum (1- y)) z x) (tak72 (the fixnum (1- z)) x y))))) (defun tak16 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak17 (tak29 (the fixnum (1- x)) y z) (tak87 (the fixnum (1- y)) z x) (tak89 (the fixnum (1- z)) x y))))) (defun tak17 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak18 (tak66 (the fixnum (1- x)) y z) (tak98 (the fixnum (1- y)) z x) (tak6 (the fixnum (1- z)) x y))))) (defun tak18 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak19 (tak3 (the fixnum (1- x)) y z) (tak9 (the fixnum (1- y)) z x) (tak23 (the fixnum (1- z)) x y))))) (defun tak19 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak20 (tak40 (the fixnum (1- x)) y z) (tak20 (the fixnum (1- y)) z x) (tak40 (the fixnum (1- z)) x y))))) (defun tak20 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak21 (tak77 (the fixnum (1- x)) y z) (tak31 (the fixnum (1- y)) z x) (tak57 (the fixnum (1- z)) x y))))) (defun tak21 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak22 (tak14 (the fixnum (1- x)) y z) (tak42 (the fixnum (1- y)) z x) (tak74 (the fixnum (1- z)) x y))))) (defun tak22 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak23 (tak51 (the fixnum (1- x)) y z) (tak53 (the fixnum (1- y)) z x) (tak91 (the fixnum (1- z)) x y))))) (defun tak23 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak24 (tak88 (the fixnum (1- x)) y z) (tak64 (the fixnum (1- y)) z x) (tak8 (the fixnum (1- z)) x y))))) (defun tak24 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak25 (tak25 (the fixnum (1- x)) y z) (tak75 (the fixnum (1- y)) z x) (tak25 (the fixnum (1- z)) x y))))) (defun tak25 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak26 (tak62 (the fixnum (1- x)) y z) (tak86 (the fixnum (1- y)) z x) (tak42 (the fixnum (1- z)) x y))))) (defun tak26 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak27 (tak99 (the fixnum (1- x)) y z) (tak97 (the fixnum (1- y)) z x) (tak59 (the fixnum (1- z)) x y))))) (defun tak27 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak28 (tak36 (the fixnum (1- x)) y z) (tak8 (the fixnum (1- y)) z x) (tak76 (the fixnum (1- z)) x y))))) (defun tak28 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak29 (tak73 (the fixnum (1- x)) y z) (tak19 (the fixnum (1- y)) z x) (tak93 (the fixnum (1- z)) x y))))) (defun tak29 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak30 (tak10 (the fixnum (1- x)) y z) (tak30 (the fixnum (1- y)) z x) (tak10 (the fixnum (1- z)) x y))))) (defun tak30 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak31 (tak47 (the fixnum (1- x)) y z) (tak41 (the fixnum (1- y)) z x) (tak27 (the fixnum (1- z)) x y))))) (defun tak31 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak32 (tak84 (the fixnum (1- x)) y z) (tak52 (the fixnum (1- y)) z x) (tak44 (the fixnum (1- z)) x y))))) (defun tak32 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak33 (tak21 (the fixnum (1- x)) y z) (tak63 (the fixnum (1- y)) z x) (tak61 (the fixnum (1- z)) x y))))) (defun tak33 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak34 (tak58 (the fixnum (1- x)) y z) (tak74 (the fixnum (1- y)) z x) (tak78 (the fixnum (1- z)) x y))))) (defun tak34 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak35 (tak95 (the fixnum (1- x)) y z) (tak85 (the fixnum (1- y)) z x) (tak95 (the fixnum (1- z)) x y))))) (defun tak35 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak36 (tak32 (the fixnum (1- x)) y z) (tak96 (the fixnum (1- y)) z x) (tak12 (the fixnum (1- z)) x y))))) (defun tak36 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak37 (tak69 (the fixnum (1- x)) y z) (tak7 (the fixnum (1- y)) z x) (tak29 (the fixnum (1- z)) x y))))) (defun tak37 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak38 (tak6 (the fixnum (1- x)) y z) (tak18 (the fixnum (1- y)) z x) (tak46 (the fixnum (1- z)) x y))))) (defun tak38 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak39 (tak43 (the fixnum (1- x)) y z) (tak29 (the fixnum (1- y)) z x) (tak63 (the fixnum (1- z)) x y))))) (defun tak39 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak40 (tak80 (the fixnum (1- x)) y z) (tak40 (the fixnum (1- y)) z x) (tak80 (the fixnum (1- z)) x y))))) (defun tak40 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak41 (tak17 (the fixnum (1- x)) y z) (tak51 (the fixnum (1- y)) z x) (tak97 (the fixnum (1- z)) x y))))) (defun tak41 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak42 (tak54 (the fixnum (1- x)) y z) (tak62 (the fixnum (1- y)) z x) (tak14 (the fixnum (1- z)) x y))))) (defun tak42 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak43 (tak91 (the fixnum (1- x)) y z) (tak73 (the fixnum (1- y)) z x) (tak31 (the fixnum (1- z)) x y))))) (defun tak43 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak44 (tak28 (the fixnum (1- x)) y z) (tak84 (the fixnum (1- y)) z x) (tak48 (the fixnum (1- z)) x y))))) (defun tak44 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak45 (tak65 (the fixnum (1- x)) y z) (tak95 (the fixnum (1- y)) z x) (tak65 (the fixnum (1- z)) x y))))) (defun tak45 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak46 (tak2 (the fixnum (1- x)) y z) (tak6 (the fixnum (1- y)) z x) (tak82 (the fixnum (1- z)) x y))))) (defun tak46 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak47 (tak39 (the fixnum (1- x)) y z) (tak17 (the fixnum (1- y)) z x) (tak99 (the fixnum (1- z)) x y))))) (defun tak47 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak48 (tak76 (the fixnum (1- x)) y z) (tak28 (the fixnum (1- y)) z x) (tak16 (the fixnum (1- z)) x y))))) (defun tak48 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak49 (tak13 (the fixnum (1- x)) y z) (tak39 (the fixnum (1- y)) z x) (tak33 (the fixnum (1- z)) x y))))) (defun tak49 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak50 (tak50 (the fixnum (1- x)) y z) (tak50 (the fixnum (1- y)) z x) (tak50 (the fixnum (1- z)) x y))))) (defun tak50 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak51 (tak87 (the fixnum (1- x)) y z) (tak61 (the fixnum (1- y)) z x) (tak67 (the fixnum (1- z)) x y))))) (defun tak51 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak52 (tak24 (the fixnum (1- x)) y z) (tak72 (the fixnum (1- y)) z x) (tak84 (the fixnum (1- z)) x y))))) (defun tak52 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak53 (tak61 (the fixnum (1- x)) y z) (tak83 (the fixnum (1- y)) z x) (tak1 (the fixnum (1- z)) x y))))) (defun tak53 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak54 (tak98 (the fixnum (1- x)) y z) (tak94 (the fixnum (1- y)) z x) (tak18 (the fixnum (1- z)) x y))))) (defun tak54 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak55 (tak35 (the fixnum (1- x)) y z) (tak5 (the fixnum (1- y)) z x) (tak35 (the fixnum (1- z)) x y))))) (defun tak55 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak56 (tak72 (the fixnum (1- x)) y z) (tak16 (the fixnum (1- y)) z x) (tak52 (the fixnum (1- z)) x y))))) (defun tak56 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak57 (tak9 (the fixnum (1- x)) y z) (tak27 (the fixnum (1- y)) z x) (tak69 (the fixnum (1- z)) x y))))) (defun tak57 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak58 (tak46 (the fixnum (1- x)) y z) (tak38 (the fixnum (1- y)) z x) (tak86 (the fixnum (1- z)) x y))))) (defun tak58 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak59 (tak83 (the fixnum (1- x)) y z) (tak49 (the fixnum (1- y)) z x) (tak3 (the fixnum (1- z)) x y))))) (defun tak59 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak60 (tak20 (the fixnum (1- x)) y z) (tak60 (the fixnum (1- y)) z x) (tak20 (the fixnum (1- z)) x y))))) (defun tak60 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak61 (tak57 (the fixnum (1- x)) y z) (tak71 (the fixnum (1- y)) z x) (tak37 (the fixnum (1- z)) x y))))) (defun tak61 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak62 (tak94 (the fixnum (1- x)) y z) (tak82 (the fixnum (1- y)) z x) (tak54 (the fixnum (1- z)) x y))))) (defun tak62 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak63 (tak31 (the fixnum (1- x)) y z) (tak93 (the fixnum (1- y)) z x) (tak71 (the fixnum (1- z)) x y))))) (defun tak63 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak64 (tak68 (the fixnum (1- x)) y z) (tak4 (the fixnum (1- y)) z x) (tak88 (the fixnum (1- z)) x y))))) (defun tak64 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak65 (tak5 (the fixnum (1- x)) y z) (tak15 (the fixnum (1- y)) z x) (tak5 (the fixnum (1- z)) x y))))) (defun tak65 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak66 (tak42 (the fixnum (1- x)) y z) (tak26 (the fixnum (1- y)) z x) (tak22 (the fixnum (1- z)) x y))))) (defun tak66 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak67 (tak79 (the fixnum (1- x)) y z) (tak37 (the fixnum (1- y)) z x) (tak39 (the fixnum (1- z)) x y))))) (defun tak67 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak68 (tak16 (the fixnum (1- x)) y z) (tak48 (the fixnum (1- y)) z x) (tak56 (the fixnum (1- z)) x y))))) (defun tak68 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak69 (tak53 (the fixnum (1- x)) y z) (tak59 (the fixnum (1- y)) z x) (tak73 (the fixnum (1- z)) x y))))) (defun tak69 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak70 (tak90 (the fixnum (1- x)) y z) (tak70 (the fixnum (1- y)) z x) (tak90 (the fixnum (1- z)) x y))))) (defun tak70 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak71 (tak27 (the fixnum (1- x)) y z) (tak81 (the fixnum (1- y)) z x) (tak7 (the fixnum (1- z)) x y))))) (defun tak71 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak72 (tak64 (the fixnum (1- x)) y z) (tak92 (the fixnum (1- y)) z x) (tak24 (the fixnum (1- z)) x y))))) (defun tak72 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak73 (tak1 (the fixnum (1- x)) y z) (tak3 (the fixnum (1- y)) z x) (tak41 (the fixnum (1- z)) x y))))) (defun tak73 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak74 (tak38 (the fixnum (1- x)) y z) (tak14 (the fixnum (1- y)) z x) (tak58 (the fixnum (1- z)) x y))))) (defun tak74 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak75 (tak75 (the fixnum (1- x)) y z) (tak25 (the fixnum (1- y)) z x) (tak75 (the fixnum (1- z)) x y))))) (defun tak75 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak76 (tak12 (the fixnum (1- x)) y z) (tak36 (the fixnum (1- y)) z x) (tak92 (the fixnum (1- z)) x y))))) (defun tak76 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak77 (tak49 (the fixnum (1- x)) y z) (tak47 (the fixnum (1- y)) z x) (tak9 (the fixnum (1- z)) x y))))) (defun tak77 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak78 (tak86 (the fixnum (1- x)) y z) (tak58 (the fixnum (1- y)) z x) (tak26 (the fixnum (1- z)) x y))))) (defun tak78 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak79 (tak23 (the fixnum (1- x)) y z) (tak69 (the fixnum (1- y)) z x) (tak43 (the fixnum (1- z)) x y))))) (defun tak79 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak80 (tak60 (the fixnum (1- x)) y z) (tak80 (the fixnum (1- y)) z x) (tak60 (the fixnum (1- z)) x y))))) (defun tak80 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak81 (tak97 (the fixnum (1- x)) y z) (tak91 (the fixnum (1- y)) z x) (tak77 (the fixnum (1- z)) x y))))) (defun tak81 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak82 (tak34 (the fixnum (1- x)) y z) (tak2 (the fixnum (1- y)) z x) (tak94 (the fixnum (1- z)) x y))))) (defun tak82 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak83 (tak71 (the fixnum (1- x)) y z) (tak13 (the fixnum (1- y)) z x) (tak11 (the fixnum (1- z)) x y))))) (defun tak83 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak84 (tak8 (the fixnum (1- x)) y z) (tak24 (the fixnum (1- y)) z x) (tak28 (the fixnum (1- z)) x y))))) (defun tak84 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak85 (tak45 (the fixnum (1- x)) y z) (tak35 (the fixnum (1- y)) z x) (tak45 (the fixnum (1- z)) x y))))) (defun tak85 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak86 (tak82 (the fixnum (1- x)) y z) (tak46 (the fixnum (1- y)) z x) (tak62 (the fixnum (1- z)) x y))))) (defun tak86 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak87 (tak19 (the fixnum (1- x)) y z) (tak57 (the fixnum (1- y)) z x) (tak79 (the fixnum (1- z)) x y))))) (defun tak87 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak88 (tak56 (the fixnum (1- x)) y z) (tak68 (the fixnum (1- y)) z x) (tak96 (the fixnum (1- z)) x y))))) (defun tak88 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak89 (tak93 (the fixnum (1- x)) y z) (tak79 (the fixnum (1- y)) z x) (tak13 (the fixnum (1- z)) x y))))) (defun tak89 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak90 (tak30 (the fixnum (1- x)) y z) (tak90 (the fixnum (1- y)) z x) (tak30 (the fixnum (1- z)) x y))))) (defun tak90 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak91 (tak67 (the fixnum (1- x)) y z) (tak1 (the fixnum (1- y)) z x) (tak47 (the fixnum (1- z)) x y))))) (defun tak91 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak92 (tak4 (the fixnum (1- x)) y z) (tak12 (the fixnum (1- y)) z x) (tak64 (the fixnum (1- z)) x y))))) (defun tak92 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak93 (tak41 (the fixnum (1- x)) y z) (tak23 (the fixnum (1- y)) z x) (tak81 (the fixnum (1- z)) x y))))) (defun tak93 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak94 (tak78 (the fixnum (1- x)) y z) (tak34 (the fixnum (1- y)) z x) (tak98 (the fixnum (1- z)) x y))))) (defun tak94 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak95 (tak15 (the fixnum (1- x)) y z) (tak45 (the fixnum (1- y)) z x) (tak15 (the fixnum (1- z)) x y))))) (defun tak95 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak96 (tak52 (the fixnum (1- x)) y z) (tak56 (the fixnum (1- y)) z x) (tak32 (the fixnum (1- z)) x y))))) (defun tak96 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak97 (tak89 (the fixnum (1- x)) y z) (tak67 (the fixnum (1- y)) z x) (tak49 (the fixnum (1- z)) x y))))) (defun tak97 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak98 (tak26 (the fixnum (1- x)) y z) (tak78 (the fixnum (1- y)) z x) (tak66 (the fixnum (1- z)) x y))))) (defun tak98 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak99 (tak63 (the fixnum (1- x)) y z) (tak89 (the fixnum (1- y)) z x) (tak83 (the fixnum (1- z)) x y))))) (defun tak99 (x y z) (declare (type fixnum x y z)) (cond ((not (< y x)) z) (t (tak0 (tak0 (the fixnum (1- x)) y z) (tak0 (the fixnum (1- y)) z x) (tak0 (the fixnum (1- z)) x y))))) (defun testtakr () (print (time (tak0 18 12 6)))) gcl-2.7.1/bench/PaxHeaders/browse.cl0000644000000000000000000000013114542551763014257 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.165792141 29 ctime=1744351535.72690703 gcl-2.7.1/bench/browse.cl0000644000175000017500000000725414542551763013666 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; BROWSE -- Benchmark to create and browse through an AI-like data base ;;; of units. ;;; n is # of symbols ;;; m is maximum amount of stuff on the plist ;;; npats is the number of basic patterns on the unit ;;; ipats is the instantiated copies of the patterns (eval-when (eval compile) (defvar *browse-rand* 21) (proclaim '(type fixnum *browse-rand*)) (defconstant *browse-star* (code-char 42)) (defconstant *browse-questionmark* (code-char 63))) (eval-when (eval compile) ;; maybe SYMBOL-NAME (defmacro browse-char1 (x) `(schar (symbol-name ,x) 0))) (defun browse-init (n m npats ipats) (declare (type fixnum n m npats)) (setq *browse-rand* 21) (let ((ipats (copy-tree ipats))) (do ((p ipats (cdr p))) ((null (cdr p)) (rplacd p ipats))) (do ((n n (the fixnum (1- n))) (i m (cond ((= i 0) m) (t (the fixnum (1- i))))) (name (gentemp) (gentemp)) (a ())) ((= n 0) a) (declare (type fixnum n i)) (push name a) (do ((i i (the fixnum (1- i)))) ((= i 0)) (declare (type fixnum i)) (setf (get name (gensym)) nil)) (setf (get name 'pattern) (do ((i npats (the fixnum (1- i))) (ipats ipats (cdr ipats)) (a ())) ((= i 0) a) (declare (type fixnum i)) (push (car ipats) a))) (do ((j (the fixnum (- m i)) (the fixnum (1- j)))) ((= j 0)) (declare (type fixnum j)) (setf (get name (gensym)) nil))))) (defun browse-random () (setq *browse-rand* (rem (the fixnum (* *browse-rand* 17)) 251))) (defun browse-randomize (l) (do ((a ())) ((null l) a) (let ((n (rem (the fixnum (browse-random)) (the fixnum (length l))))) (declare (type fixnum n)) (cond ((= n 0) (push (car l) a) (setq l (cdr l))) (t (do ((n n (the fixnum (1- n))) (x l (cdr x))) ((= n 1) (push (cadr x) a) (rplacd x (cddr x))) (declare (type fixnum n)))))))) (defun match (pat dat alist) (cond ((null pat) (null dat)) ((null dat) ()) ((or (eq (car pat) '?) (eq (car pat) (car dat))) (match (cdr pat) (cdr dat) alist)) ((eq (car pat) '*) (or (match (cdr pat) dat alist) (match (cdr pat) (cdr dat) alist) (match pat (cdr dat) alist))) (t (cond ((atom (car pat)) ;;replace eq by 'eql for char (cond ((eql (browse-char1 (car pat)) *browse-questionmark*) (let ((val (assoc (car pat) alist))) (cond (val (match (cons (cdr val) (cdr pat)) dat alist)) (t (match (cdr pat) (cdr dat) (cons (cons (car pat) (car dat)) alist)))))) ((eql (browse-char1 (car pat)) *browse-star*) (let ((val (assoc (car pat) alist))) (cond (val (match (append (cdr val) (cdr pat)) dat alist)) (t (do ((l () (nconc l (cons (car d) nil))) (e (cons () dat) (cdr e)) (d dat (cdr d))) ((null e) ()) (cond ((match (cdr pat) d (cons (cons (car pat) l) alist)) (return t)))))))))) (t (and (not (atom (car dat))) (match (car pat) (car dat) alist) (match (cdr pat) (cdr dat) alist))))))) (defun browse () (investigate (browse-randomize (browse-init 100 10 4 '((a a a b b b b a a a a a b b a a a) (a a b b b b a a (a a)(b b)) (a a a b (b a) b a b a)))) '((*a ?b *b ?b a *a a *b *a) (*a *b *b *a (*a) (*b)) (? ? * (b a) * ? ?)))) (defun investigate (units pats) (do ((units units (cdr units))) ((null units)) (do ((pats pats (cdr pats))) ((null pats)) (do ((p (get (car units) 'pattern) (cdr p))) ((null p)) (match (car pats) (car p) ()))))) (defun testbrowse () (print (time (browse)))) gcl-2.7.1/bench/PaxHeaders/triang-mod.cl0000644000000000000000000000013214776006046015016 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/triang-mod.cl0000644000175000017500000000461114776006046014416 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; TRIANG -- Board game benchmark. ;;; In converting to common lisp eq compares of fixnums have been changed ;;; to eql and the type of the board vectors has been declared. (declaim (special board seq a b c)) (declaim (type (vector fixnum ) board seq a b c)) (defvar answer) (defvar final) (defun triang-setup () (setq board (make-array 16 :element-type 'fixnum :initial-element 1)) (setq seq (make-array 14 :element-type 'fixnum :initial-element 0)) (setq a (make-array 37 :element-type 'fixnum :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) (setq b (make-array 37 :element-type 'fixnum :initial-contents '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) (setq c (make-array 37 :element-type 'fixnum :initial-contents '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) (setf (aref board 5) 0)) (defun last-position () (do ((i 1 (the fixnum (+ i 1)))) ((= i 16) 0) (declare (fixnum i)) (if (eql 1 (aref board i)) (return i)))) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final :test #'eql) (push lp final))) ;;; (format t "~&~s" (cdr (simple-vector-to-list seq))) (push (cdr (simple-vector-to-list seq)) answer) t) ; this is a hack to replace LISTARRAY ((and (eql 1 (aref board (aref a i))) (eql 1 (aref board (aref b i))) (eql 0 (aref board (aref c i)))) (setf (aref board (aref a i)) 0) (setf (aref board (aref b i)) 0) (setf (aref board (aref c i)) 1) (setf (aref seq depth) i) (do ((j 0 (the fixnum (+ j 1))) (depth (the fixnum (+ depth 1)))) ((or (= j 36) (try j depth)) ()) (declare (fixnum j depth))) (setf (aref board (aref a i)) 1) (setf (aref board (aref b i)) 1) (setf (aref board (aref c i)) 0) ()))) (defun simple-vector-to-list (seq) (do ((i (- (length seq) 1) (1- i)) (res)) ((< i 0) res) (declare (fixnum i)) (declare (type (array fixnum) seq)) (push (aref seq i) res))) (defun gogogo (i) (let ((answer ()) (final ())) (try i 1))) (defun testtriang () (triang-setup) (print (time (gogogo 22)))) gcl-2.7.1/bench/PaxHeaders/make-declare.lsp0000644000000000000000000000013214776006046015467 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/make-declare.lsp0000644000175000017500000000537314776006046015075 0ustar00cammcamm;; By W. Schelter ;; Usage: (si::proclaim-file "foo.lsp") (compile-file "foo.lsp") (proclaim (quote (optimize (compilation-speed 0) (safety 0) (speed 3) (space 0) (debug 0)))) ;; 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 efect. Unfortunately it is impossible to tell about ;; multiple values without doing a full compiler type pass over ;; all files in the relevant system. AKCL supports doing such a pass ;; during the compilation of a system, and can thus produce proclaims for ;; a subsequent compilation. [see emit-fn documentation]. (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 )))))))) (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) '(DEFUN)) (COND ((AND (listp (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 `(ftype (function ,(ARG-DECLARES (THIRD FORM) (cdddr FORM)) t) ,(cadr form))) )))))) (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.7.1/bench/PaxHeaders/fprint.cl0000644000000000000000000000013114542551763014260 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.165792141 29 ctime=1744351535.72690703 gcl-2.7.1/bench/fprint.cl0000644000175000017500000000202614542551763013657 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; FPRINT -- Benchmark to print to a file. (defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67 mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12 wxyzab23 xyzabc34 123456ab 234567bc 345678cd 456789de 567890ef 678901fg 789012gh 890123hi)) (defun init-aux (m n atoms) (declare (fixnum m n)) (cond ((= m 0) (pop atoms)) (t (do ((i n (the fixnum (- i 2))) (a ())) ((< i 1) a) (declare (fixnum i)) (push (pop atoms) a) (push (init-aux (the fixnum (1- m)) n atoms) a))))) (defun fprint-init (m n atoms) (let ((atoms (subst () () atoms))) (do ((a atoms (cdr a))) ((null (cdr a)) (rplacd a atoms))) (init-aux m n atoms))) (defvar test-pattern (fprint-init 6. 6. test-atoms)) (defun fprint () (if (probe-file "/tmp/fprint.tst") (delete-file "/tmp/fprint.tst")) (let ((stream (open "/tmp/fprint.tst" :direction :output))) (print test-pattern stream) (close stream))) (defun testfprint () (print (time (fprint)))) gcl-2.7.1/bench/PaxHeaders/boyer.cl0000644000000000000000000000013114542551763014076 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.173792176 29 ctime=1744351535.72690703 gcl-2.7.1/bench/boyer.cl0000644000175000017500000003027714542551763013506 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer. ;;; Fairly CONS intensive. (defvar **unify-subst**) (defvar **temp-temp**) (defun add-lemma (term) (cond ((and (not (atom term)) (eq (car term) (quote equal)) (not (atom (cadr term)))) (setf (get (car (cadr term)) (quote lemmas)) (cons term (get (car (cadr term)) (quote lemmas))))) (t (error "~%ADD-LEMMA did not like term: ~a" term)))) (defun add-lemma-lst (lst) (cond ((null lst) t) (t (add-lemma (car lst)) (add-lemma-lst (cdr lst))))) (defun apply-subst (alist term) (cond ((atom term) (cond ((setq **temp-temp** (assoc term alist :test #'eq)) (cdr **temp-temp**)) (t term))) (t (cons (car term) (apply-subst-lst alist (cdr term)))))) (defun apply-subst-lst (alist lst) (cond ((null lst) nil) (t (cons (apply-subst alist (car lst)) (apply-subst-lst alist (cdr lst)))))) (defun falsep (x lst) (or (equal x (quote (f))) (member x lst))) (defun one-way-unify (term1 term2) (progn (setq **unify-subst** nil) (one-way-unify1 term1 term2))) (defun one-way-unify1 (term1 term2) (cond ((atom term2) (cond ((setq **temp-temp** (assoc term2 **unify-subst** :test #'eq)) (equal term1 (cdr **temp-temp**))) (t (setq **unify-subst** (cons (cons term2 term1) **unify-subst**)) t))) ((atom term1) nil) ((eq (car term1) (car term2)) (one-way-unify1-&lst (cdr term1) (cdr term2))) (t nil))) (defun one-way-unify1-&lst (lst1 lst2) (cond ((null lst1) t) ((one-way-unify1 (car lst1) (car lst2)) (one-way-unify1-&lst (cdr lst1) (cdr lst2))) (t nil))) (defun rewrite (term) (cond ((atom term) term) (t (rewrite-with-lemmas (cons (car term) (rewrite-args (cdr term))) (get (car term) (quote lemmas)))))) (defun rewrite-args (lst) (cond ((null lst) nil) (t (cons (rewrite (car lst)) (rewrite-args (cdr lst)))))) (defun rewrite-with-lemmas (term lst) (cond ((null lst) term) ((one-way-unify term (cadr (car lst))) (rewrite (apply-subst **unify-subst** (caddr (car lst))))) (t (rewrite-with-lemmas term (cdr lst))))) (defun boyer-setup () (add-lemma-lst (quote ((equal (compile form) (reverse (codegen (optimize form) (nil)))) (equal (eqp x y) (equal (fix x) (fix y))) (equal (greaterp x y) (lessp y x)) (equal (lesseqp x y) (not (lessp y x))) (equal (greatereqp x y) (not (lessp x y))) (equal (boolean x) (or (equal x (t)) (equal x (f)))) (equal (iff x y) (and (implies x y) (implies y x))) (equal (even1 x) (if (zerop x) (t) (odd (1- x)))) (equal (countps- l pred) (countps-loop l pred (zero))) (equal (fact- i) (fact-loop i 1)) (equal (reverse- x) (reverse-loop x (nil))) (equal (divides x y) (zerop (remainder y x))) (equal (assume-true var alist) (cons (cons var (t)) alist)) (equal (assume-false var alist) (cons (cons var (f)) alist)) (equal (tautology-checker x) (tautologyp (normalize x) (nil))) (equal (falsify x) (falsify1 (normalize x) (nil))) (equal (prime x) (and (not (zerop x)) (not (equal x (add1 (zero)))) (prime1 x (1- x)))) (equal (and p q) (if p (if q (t) (f)) (f))) (equal (or p q) (if p (t) (if q (t) (f)) (f))) (equal (not p) (if p (f) (t))) (equal (implies p q) (if p (if q (t) (f)) (t))) (equal (fix x) (if (numberp x) x (zero))) (equal (if (if a b c) d e) (if a (if b d e) (if c d e))) (equal (zerop x) (or (equal x (zero)) (not (numberp x)))) (equal (plus (plus x y) z) (plus x (plus y z))) (equal (equal (plus a b) (zero)) (and (zerop a) (zerop b))) (equal (difference x x) (zero)) (equal (equal (plus a b) (plus a c)) (equal (fix b) (fix c))) (equal (equal (zero) (difference x y)) (not (lessp y x))) (equal (equal x (difference x y)) (and (numberp x) (or (equal x (zero)) (zerop y)))) (equal (meaning (plus-tree (append x y)) a) (plus (meaning (plus-tree x) a) (meaning (plus-tree y) a))) (equal (meaning (plus-tree (plus-fringe x)) a) (fix (meaning x a))) (equal (append (append x y) z) (append x (append y z))) (equal (reverse (append a b)) (append (reverse b) (reverse a))) (equal (times x (plus y z)) (plus (times x y) (times x z))) (equal (times (times x y) z) (times x (times y z))) (equal (equal (times x y) (zero)) (or (zerop x) (zerop y))) (equal (exec (append x y) pds envrn) (exec y (exec x pds envrn) envrn)) (equal (mc-flatten x y) (append (flatten x) y)) (equal (member x (append a b)) (or (member x a) (member x b))) (equal (member x (reverse y)) (member x y)) (equal (length (reverse x)) (length x)) (equal (member a (intersect b c)) (and (member a b) (member a c))) (equal (nth (zero) i) (zero)) (equal (exp i (plus j k)) (times (exp i j) (exp i k))) (equal (exp i (times j k)) (exp (exp i j) k)) (equal (reverse-loop x y) (append (reverse x) y)) (equal (reverse-loop x (nil)) (reverse x)) (equal (count-list z (sort-lp x y)) (plus (count-list z x) (count-list z y))) (equal (equal (append a b) (append a c)) (equal b c)) (equal (plus (remainder x y) (times y (quotient x y))) (fix x)) (equal (power-eval (big-plus1 l i base) base) (plus (power-eval l base) i)) (equal (power-eval (big-plus x y i base) base) (plus i (plus (power-eval x base) (power-eval y base)))) (equal (remainder y 1) (zero)) (equal (lessp (remainder x y) y) (not (zerop y))) (equal (remainder x x) (zero)) (equal (lessp (quotient i j) i) (and (not (zerop i)) (or (zerop j) (not (equal j 1))))) (equal (lessp (remainder x y) x) (and (not (zerop y)) (not (zerop x)) (not (lessp x y)))) (equal (power-eval (power-rep i base) base) (fix i)) (equal (power-eval (big-plus (power-rep i base) (power-rep j base) (zero) base) base) (plus i j)) (equal (gcd x y) (gcd y x)) (equal (nth (append a b) i) (append (nth a i) (nth b (difference i (length a))))) (equal (difference (plus x y) x) (fix y)) (equal (difference (plus y x) x) (fix y)) (equal (difference (plus x y) (plus x z)) (difference y z)) (equal (times x (difference c w)) (difference (times c x) (times w x))) (equal (remainder (times x z) z) (zero)) (equal (difference (plus b (plus a c)) a) (plus b c)) (equal (difference (add1 (plus y z)) z) (add1 y)) (equal (lessp (plus x y) (plus x z)) (lessp y z)) (equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y))) (equal (lessp y (plus x y)) (not (zerop x))) (equal (gcd (times x z) (times y z)) (times z (gcd x y))) (equal (value (normalize x) a) (value x a)) (equal (equal (flatten x) (cons y (nil))) (and (nlistp x) (equal x y))) (equal (listp (gopher x)) (listp x)) (equal (samefringe x y) (equal (flatten x) (flatten y))) (equal (equal (greatest-factor x y) (zero)) (and (or (zerop y) (equal y 1)) (equal x (zero)))) (equal (equal (greatest-factor x y) 1) (equal x 1)) (equal (numberp (greatest-factor x y)) (not (and (or (zerop y) (equal y 1)) (not (numberp x))))) (equal (times-list (append x y)) (times (times-list x) (times-list y))) (equal (prime-list (append x y)) (and (prime-list x) (prime-list y))) (equal (equal z (times w z)) (and (numberp z) (or (equal z (zero)) (equal w 1)))) (equal (greatereqpr x y) (not (lessp x y))) (equal (equal x (times x y)) (or (equal x (zero)) (and (numberp x) (equal y 1)))) (equal (remainder (times y x) y) (zero)) (equal (equal (times a b) 1) (and (not (equal a (zero))) (not (equal b (zero))) (numberp a) (numberp b) (equal (1- a) (zero)) (equal (1- b) (zero)))) (equal (lessp (length (delete x l)) (length l)) (member x l)) (equal (sort2 (delete x l)) (delete x (sort2 l))) (equal (dsort x) (sort2 x)) (equal (length (cons x1 (cons x2 (cons x3 (cons x4 (cons x5 (cons x6 x7))))))) (plus 6 (length x7))) (equal (difference (add1 (add1 x)) 2) (fix x)) (equal (quotient (plus x (plus x y)) 2) (plus x (quotient y 2))) (equal (sigma (zero) i) (quotient (times i (add1 i)) 2)) (equal (plus x (add1 y)) (if (numberp y) (add1 (plus x y)) (add1 x))) (equal (equal (difference x y) (difference z y)) (if (lessp x y) (not (lessp y z)) (if (lessp z y) (not (lessp y x)) (equal (fix x) (fix z))))) (equal (meaning (plus-tree (delete x y)) a) (if (member x y) (difference (meaning (plus-tree y) a) (meaning x a)) (meaning (plus-tree y) a))) (equal (times x (add1 y)) (if (numberp y) (plus x (times x y)) (fix x))) (equal (nth (nil) i) (if (zerop i) (nil) (zero))) (equal (last (append a b)) (if (listp b) (last b) (if (listp a) (cons (car (last a)) b) b))) (equal (equal (lessp x y) z) (if (lessp x y) (equal t z) (equal f z))) (equal (assignment x (append a b)) (if (assignedp x a) (assignment x a) (assignment x b))) (equal (car (gopher x)) (if (listp x) (car (flatten x)) (zero))) (equal (flatten (cdr (gopher x))) (if (listp x) (cdr (flatten x)) (cons (zero) (nil)))) (equal (quotient (times y x) y) (if (zerop y) (zero) (fix x))) (equal (get j (set i val mem)) (if (eqp j i) val (get j mem))))))) (defun tautologyp (x true-lst false-lst) (cond ((truep x true-lst) t) ((falsep x false-lst) nil) ((atom x) nil) ((eq (car x) (quote if)) (cond ((truep (cadr x) true-lst) (tautologyp (caddr x) true-lst false-lst)) ((falsep (cadr x) false-lst) (tautologyp (cadddr x) true-lst false-lst)) (t (and (tautologyp (caddr x) (cons (cadr x) true-lst) false-lst) (tautologyp (cadddr x) true-lst (cons (cadr x) false-lst)))))) (t nil))) (defun tautp (x) (tautologyp (rewrite x) nil nil)) (defun boyer-test () (prog (ans term) (setq term (apply-subst (quote ((x f (plus (plus a b) (plus c (zero)))) (y f (times (times a b) (plus c d))) (z f (reverse (append (append a b) (nil)))) (u equal (plus a b) (difference x y)) (w lessp (remainder a b) (member a (length b))))) (quote (implies (and (implies x y) (and (implies y z) (and (implies z u) (implies u w)))) (implies x w))))) (setq ans (tautp term)))) #| (defun trans-of-implies (n) (list (quote implies) (trans-of-implies1 n) (list (quote implies) 0 n))) (defun trans-of-implies1 (n) (cond ((eql n 1) (list (quote implies) 0 1)) (t (list (quote and) (list (quote implies) (1- n) n) (trans-of-implies1 (1- n)))))) |# (defun truep (x lst) (or (equal x (quote (t))) (member x lst))) (defvar setup-performed-p (prog1 t (boyer-setup))) (defun testboyer () (print (time (boyer-test)))) gcl-2.7.1/bench/PaxHeaders/ecl_tim0000644000000000000000000000013114776006046013773 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.246034807 29 ctime=1744351535.72690703 gcl-2.7.1/bench/ecl_tim0000644000175000017500000000076014776006046013375 0ustar00cammcamm_ ecl_ref 20250408_x86_64 BOYER 2.781 BROWSE 4.683 CTAK 1.158 DDERIV 2.066 DERIV 2.040 DESTRU 4.224 DESTRU-MOD 4.187 DIV2 2.410 FFT 14.653 FFT-MOD 14.604 FPRINT 8.270 FREAD 4.282 FRPOLY 6.521 PUZZLE 1.848 PUZZLE-MOD 1.828 STAK 4.819 TAK 7.979 TAKL 4.576 TAK-MOD 7.996 TAKR 4.229 TPRINT 11.350 TRAVERSE 1.157 TRIANG 2.914 TRIANG-MOD 1.650 gcl-2.7.1/bench/PaxHeaders/destru.cl0000644000000000000000000000013114542551763014264 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.173792176 29 ctime=1744351535.72690703 gcl-2.7.1/bench/destru.cl0000644000175000017500000000244314542551763013666 0ustar00cammcamm;; $Header$ ;; $Locker$ ;; DESTRU -- Destructive operation benchmark (defun destructive (n m) (declare (type fixnum n m)) (let ((l (do ((i 10. (the fixnum (1- i))) (a () (push () a))) ((= (the fixnum i) 0) a) (declare (type fixnum i))))) (do ((i n (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (type fixnum i)) (cond ((null (car l)) (do ((l l (cdr l))) ((null l)) (or (car l) (rplaca l (cons () ()))) (nconc (car l) (do ((j m (the fixnum (1- j))) (a () (push () a))) ((= (the fixnum j) 0) a) (declare (type fixnum j)))))) (t (do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2))) ((null l2)) (rplacd (do ((j (floor (the fixnum (length (car l2))) 2) (the fixnum (1- j))) (a (car l2) (cdr a))) ((zerop (the fixnum j)) a) (declare (type fixnum j)) (rplaca a i)) (let ((n (floor (the fixnum (length (car l1))) 2))) (cond ((= (the fixnum n) 0) (rplaca l1 ()) (car l1)) (t (do ((j n (the fixnum (1- j))) (a (car l1) (cdr a))) ((= (the fixnum j) 1) (prog1 (cdr a) (rplacd a ()))) (declare (type fixnum j)) (rplaca a i)))))))))))) (defun testdestru () (print (time (destructive 600 50)))) gcl-2.7.1/bench/PaxHeaders/fft-mod.cl0000644000000000000000000000013214776006046014311 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/fft-mod.cl0000644000175000017500000001027014776006046013707 0ustar00cammcamm;; $Header$ ;; $Locker$ ;; FFT -- This is an FFT benchmark written by Harry Barrow. ;; It tests a variety of floating point operations, including array references. (eval-when (compile) (setq *READ-DEFAULT-FLOAT-FORMAT* 'double-float) ) (defvar **fft-re** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (defvar **fft-im** (make-array 1025. :element-type 'double-float :initial-element 0.0)) (defmacro ff+ (a b) `(the double-float (+ (the double-float ,a) (the double-float ,b)))) (defmacro ff*(a b) `(the double-float (* (the double-float ,a) (the double-float ,b)))) (defmacro ff-(a b) `(the double-float (- (the double-float ,a) (the double-float ,b)))) (defmacro ff/ (a b) `(the double-float (/ (the double-float ,a) (the double-float ,b)))) (declaim (type (simple-array double-float (*)) **fft-re** **fft-im**)) (defvar s-pi (float pi 0.0)) (declaim (double-float s-pi)) (defun fft (areal aimag) (declare (type (simple-array double-float (*)) areal aimag)) (prog* ((ar areal) (ai aimag) (i 1) (j 0) (k 0) (m 0) ;compute m = log(n) (n (1- (array-dimension ar 0))) (nv2 (floor n 2)) (le 0) (le1 0) (ip 0) (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) (declare (type fixnum i j k n nv2 m le le1 ip)) (declare (type (simple-array double-float (*)) ar ai)) (declare (double-float ur ui wr wi tr ti)) l1 (cond ((< i n) (setq m (the fixnum (1+ m)) i (the fixnum (+ i i))) (go l1))) (cond ((not (equal n (the fixnum (expt 2 m)))) (princ "error ... array size not a power of two.") (read) (return (terpri)))) (setq j 1 ;interchange elements i 1) ;in bit-reversed order l3 (cond ((< i j) (setq tr (aref ar j) ti (aref ai j)) (setf (aref ar j) (aref ar i)) (setf (aref ai j) (aref ai i)) (setf (aref ar i) tr) (setf (aref ai i) ti))) (setq k nv2) l6 (cond ((< k j) (setq j (the fixnum (- j k)) k (the fixnum (/ k 2))) (go l6))) (setq j (the fixnum (+ j k)) i (the fixnum (1+ i))) (cond ((< i n) (go l3))) (do ((l 1 (the fixnum (1+ (the fixnum l))))) ((> (the fixnum l) m)) ;loop thru stages (declare (type fixnum l)) (setq le (the fixnum (expt 2 l)) le1 (the (values fixnum fixnum) (floor le 2)) ur 1.0 ui 0.0 wr (cos (ff/ s-pi (float le1 0.0d0))) wi (sin (ff/ s-pi (float le1 0.0d0)))) (do ((j 1 (the fixnum (1+ (the fixnum j))))) ((> (the fixnum j) le1)) ;loop thru butterflies (declare (type fixnum j)) (do ((i j (+ (the fixnum i) le))) ((> (the fixnum i) n)) ;do a butterfly (declare (type fixnum i)) (setq ip (the fixnum (+ i le1)) tr (ff- (ff* (aref ar ip) ur) (ff* (aref ai ip) ui)) ti (ff+ (ff* (aref ar ip) ui) (ff* (aref ai ip) ur))) (setf (aref ar ip) (ff- (aref ar i) tr)) (setf (aref ai ip) (ff- (aref ai i) ti)) (setf (aref ar i) (ff+ (aref ar i) tr)) (setf (aref ai i) (ff+ (aref ai i) ti)))) (setq tr (ff- (ff* ur wr) (ff* ui wi)) ti (ff+ (ff* ur wi) (ff* ui wr)) ur tr ui ti)) (return t))) (defun fft-bench () (dotimes (i 10) (fft **fft-re** **fft-im**))) (defun testfft () (print (time (fft-bench)))) ;;; ;;; the following are for verifying that the implementation gives the ;;; correct result ;;; (defun clear-fft () (dotimes (i 1025) (setf (aref **fft-re** i) 0.0 (aref **fft-im** i) 0.0)) (values)) (defun setup-fft-component (theta &optional (phase 0.0)) (let ((f (ff* 2.0 (ff* pi theta))) (c (cos (ff* 0.5 (ff* pi phase)))) (s (sin (ff* 0.5 (ff* pi phase))))) (dotimes (i 1025) (let ((x (sin (* f (/ i 1024.0))))) (incf (aref **fft-re** i) (float (* c x) 0.0)) (incf (aref **fft-im** i) (float (* s x) 0.0))))) (values)) (defvar fft-delta 0.0001) (defun print-fft () (dotimes (i 1025) (let ((re (aref **fft-re** i)) (im (aref **fft-im** i))) (unless (and (< (abs re) fft-delta) (< (abs im) fft-delta)) (format t "~4d ~10f ~10f~%" i re im)))) (values)) (defun show-fft() (clear-fft) (setup-fft-component 0.2) (fft **fft-re** **fft-im**) (print-fft)) gcl-2.7.1/bench/PaxHeaders/triang.cl0000644000000000000000000000013214776006046014241 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.722907066 gcl-2.7.1/bench/triang.cl0000644000175000017500000000371414776006046013644 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; TRIANG -- Board game benchmark. (declaim (special board seq a b c)) (defvar answer) (defvar final) (defun triang-setup () (setq board (make-array 16 :initial-element 1)) (setq seq (make-array 14 :initial-element 0)) (setq a (make-array 37 :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) (setq b (make-array 37 :initial-contents '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) (setq c (make-array 37 :initial-contents '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) (setf (svref board 5) 0)) (defun last-position () (do ((i 1 (the fixnum (+ i 1)))) ((= i 16) 0) (declare (fixnum i)) (if (eq 1 (svref board i)) (return i)))) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final :test #'eq) (push lp final))) (push (cdr (simple-vector-to-list seq)) answer) t) ; this is a hack to replace LISTARRAY ((and (eq 1 (svref board (svref a i))) (eq 1 (svref board (svref b i))) (eq 0 (svref board (svref c i)))) (setf (svref board (svref a i)) 0) (setf (svref board (svref b i)) 0) (setf (svref board (svref c i)) 1) (setf (svref seq depth) i) (do ((j 0 (the fixnum (+ j 1))) (depth (the fixnum (+ depth 1)))) ((or (= j 36) (try j depth)) ()) (declare (fixnum j depth))) (setf (svref board (svref a i)) 1) (setf (svref board (svref b i)) 1) (setf (svref board (svref c i)) 0) ()))) (defun simple-vector-to-list (seq) (do ((i (- (length seq) 1) (1- i)) (res)) ((< i 0) res) (declare (fixnum i)) (push (svref seq i) res))) (defun gogogo (i) (let ((answer ()) (final ())) (try i 1))) (defun testtriang () (triang-setup) (print (time (gogogo 22)))) gcl-2.7.1/bench/PaxHeaders/clisp_tim0000644000000000000000000000013214776006046014343 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.242034788 30 ctime=1744351535.722907066 gcl-2.7.1/bench/clisp_tim0000644000175000017500000000076114776006046013745 0ustar00cammcamm_ clisp_ref 20250408_x86_64 BOYER 4.295 BROWSE 5.556 CTAK 0.406 DDERIV 2.109 DERIV 1.961 DESTRU 2.733 DESTRU-MOD 2.716 DIV2 2.150 FFT 29.459 FFT-MOD 29.673 FPRINT 2.097 FREAD 0.328 FRPOLY 7.122 PUZZLE 4.354 PUZZLE-MOD 4.314 STAK 1.793 TAK 8.901 TAKL 4.921 TAK-MOD 8.618 TAKR 1.187 TPRINT 3.394 TRAVERSE 1.434 TRIANG 4.932 TRIANG-MOD 6.346 gcl-2.7.1/bench/PaxHeaders/tprint.cl0000644000000000000000000000013114542551763014276 xustar0030 mtime=1703597043.032022476 30 atime=1744294961.181792212 29 ctime=1744351535.72690703 gcl-2.7.1/bench/tprint.cl0000644000175000017500000000146114542551763013677 0ustar00cammcamm;; $Header$ ;; $Locker$ ;;; TPRINT -- Benchmark to print and read to the terminal. (defvar test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9 stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d 567d 678e 789f 890g)) (defun tprint-init (m n atoms) (let ((atoms (subst () () atoms))) (do ((a atoms (cdr a))) ((null (cdr a)) (rplacd a atoms))) (tprint-init-aux m n atoms))) (defun tprint-init-aux (m n atoms) (declare (fixnum m n)) (cond ((= m 0) (pop atoms)) (t (do ((i n (the fixnum (- i 2))) (a ())) ((< i 1) a) (push (pop atoms) a) (push (tprint-init-aux (the fixnum (1- m)) n atoms) a))))) (defvar test-pattern (tprint-init 6. 6. test-atoms)) (defun standard-tprint-test () (print test-pattern)) (defun testtprint () (print (time (print test-pattern)))) gcl-2.7.1/PaxHeaders/AUTHORS0000644000000000000000000000013214776006046012426 xustar0030 mtime=1744309286.146034324 30 atime=1744340055.580933501 30 ctime=1744351535.442909577 gcl-2.7.1/AUTHORS0000644000175000017500000000000014776006046012012 0ustar00cammcammgcl-2.7.1/PaxHeaders/h0000644000000000000000000000013214776130457011534 xustar0030 mtime=1744351535.562908501 30 atime=1744351538.814879383 30 ctime=1744351535.562908501 gcl-2.7.1/h/0000755000175000017500000000000014776130457011207 5ustar00cammcammgcl-2.7.1/h/PaxHeaders/compprotos.h0000644000000000000000000000013214753165412014161 xustar0030 mtime=1739385610.873119866 30 atime=1744339813.007401361 30 ctime=1744351535.494909111 gcl-2.7.1/h/compprotos.h0000644000175000017500000000663014753165412013564 0ustar00cammcammbool 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_cs2(object,...); object call_proc_new(object,ufixnum,ufixnum,void **,ufixnum,object,va_list); object call_proc_new_nval(object,ufixnum,ufixnum,void **,ufixnum,object,...); object coerce_to_string(); object fixnum_big_shift(fixnum,fixnum); object fixnum_times(fixnum,fixnum); object fSgensym0(void); object fSgensym1ig(object); object fSgensym1s(object); object fSinit_function(object,object,object,object, fixnum,fixnum,fixnum); object fSsputprop(object,object,object); object Icall_gen_error_handler(object,object,object,object,ufixnum,...); 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_complex(object, object); object make_cons(object, object); object make_dcomplex(dcomplex); object make_fcomplex(fcomplex); object make_fixnum1(long); object make_list(fixnum); object make_longfloat(longfloat); object make_shortfloat(float); 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 prin1(object,object); object print(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 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); dcomplex object_to_dcomplex(object); char object_to_char(object); void not_a_symbol(object); object number_expt(object,object); object fLrow_major_aref(object,fixnum); void *alloca(unsigned long); object cmod(object); object ctimes(object,object); object cdifference(object,object); object cplus(object,object); double sqrt(double); float sqrtf(float); 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); fixnum fixnum_expt(fixnum, fixnum); char *gcl_gets(char *,int); int gcl_puts(const char *); int setjmp(); int _setjmp(); char *object_to_string(object); gcl-2.7.1/h/PaxHeaders/mach64_i386_reloc.h0000644000000000000000000000013214761577223015001 xustar0030 mtime=1741094547.578220659 30 atime=1744294997.973953505 30 ctime=1744351535.546908644 gcl-2.7.1/h/mach64_i386_reloc.h0000644000175000017500000000135714761577223014405 0ustar00cammcamm#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) store_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: // 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.7.1/h/PaxHeaders/elf64_mips_reloc_special.h0000644000000000000000000000013114542551763016613 xustar0029 mtime=1703597043.20002274 30 atime=1744294997.977953522 30 ctime=1744351535.538908716 gcl-2.7.1/h/elf64_mips_reloc_special.h0000644000175000017500000001011214542551763016205 0ustar00cammcammstatic 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))< 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.7.1/h/PaxHeaders/solaris.h0000644000000000000000000000013214542551763013434 xustar0030 mtime=1703597043.208022752 30 atime=1744294997.985953557 30 ctime=1744351535.562908501 gcl-2.7.1/h/solaris.h0000755000175000017500000000200614542551763013033 0ustar00cammcamm#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.7.1/h/PaxHeaders/elf64_s390_reloc.h0000644000000000000000000000012714542551763014646 xustar0029 mtime=1703597043.20002274 29 atime=1744294997.99795361 29 ctime=1744351535.54290868 gcl-2.7.1/h/elf64_s390_reloc.h0000644000175000017500000000053714542551763014245 0ustar00cammcamm case R_390_32: add_ivals((int *)where,MASK(32),s+a); break; case R_390_64: add_val(where,~0L,s+a); break; case R_390_PC32: add_ivals((int *)where,MASK(32),s+a-p); break; case R_390_PC32DBL: case R_390_PLT32DBL:/*FIXME think about this*/ add_ivals((int *)where,MASK(32),(s+a-p)>>1); break; gcl-2.7.1/h/PaxHeaders/defun.h0000644000000000000000000000013014542551763013057 xustar0029 mtime=1703597043.20002274 29 atime=1744340055.76093465 30 ctime=1744351535.518908896 gcl-2.7.1/h/defun.h0000755000175000017500000000130614542551763012462 0ustar00cammcamm#define ARG_LIMIT 63 #define ARG_LIMIT 63 #ifndef DONT_DEFINE_DEFUN #undef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) EXTER ret fname args; #define DEFUNB(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,p,doc) EXTER ret fname args; #define DEFUNM(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) EXTER ret fname args; #define DO_INIT(x) /* 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.7.1/h/PaxHeaders/elf32_arm_reloc.h0000644000000000000000000000013014542551763014714 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.01395368 30 ctime=1744351535.526908824 gcl-2.7.1/h/elf32_arm_reloc.h0000644000175000017500000000140514542551763014314 0ustar00cammcamm#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.7.1/h/PaxHeaders/error.h0000644000000000000000000000013114542551763013110 xustar0029 mtime=1703597043.20002274 30 atime=1744339813.023401461 30 ctime=1744351535.494909111 gcl-2.7.1/h/error.h0000644000175000017500000002721714542551763012520 0ustar00cammcamm#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 PRINT_NOT_READABLE(a_,b_) Icall_error_handler(sLprint_not_readable,null_string,6,\ sKobject,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.7.1/h/PaxHeaders/elf32_ppc_reloc.h0000644000000000000000000000013014542551763014717 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.01395368 30 ctime=1744351535.530908788 gcl-2.7.1/h/elf32_ppc_reloc.h0000644000175000017500000000123514542551763014320 0ustar00cammcamm 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.7.1/h/PaxHeaders/386-macosx.h0000644000000000000000000000013114555237434013567 xustar0030 mtime=1706376988.835763681 29 atime=1744294998.01395368 30 ctime=1744351535.558908537 gcl-2.7.1/h/386-macosx.h0000644000175000017500000001440214555237434013167 0ustar00cammcamm/* 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" #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(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.7.1/h/PaxHeaders/lex.h0000644000000000000000000000013214542551763012550 xustar0030 mtime=1703597043.204022746 30 atime=1744339813.007401361 30 ctime=1744351535.498909075 gcl-2.7.1/h/lex.h0000755000175000017500000000261214542551763012152 0ustar00cammcamm/* (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.7.1/h/PaxHeaders/pool.h0000644000000000000000000000013214753203247012724 xustar0030 mtime=1739392679.670800949 30 atime=1744340055.748934573 30 ctime=1744351535.506909003 gcl-2.7.1/h/pool.h0000644000175000017500000000572614753203247012334 0ustar00cammcammstatic 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 ufixnum pool_pid,pool_n,pool_s; 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)) return errno==EINTR ? set_lock() : -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) { struct stat ss; massert(!lstat(multiprocess_memory_pool,&ss)); massert(S_ISDIR(ss.st_mode)); massert(snprintf(gcl_pool,sizeof(gcl_pool),"%s%sgcl_pool", multiprocess_memory_pool, multiprocess_memory_pool[strlen(multiprocess_memory_pool)-1]=='/' ? "" : "/")>=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) || errno==ENOENT); 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_stat(void) { #ifndef NO_FILE_LOCKING if (multiprocess_memory_pool) { open_pool(); lock_pool(); pool_pid=Pool->pid; pool_n=Pool->n; pool_s=Pool->s; unlock_pool(); } #endif } 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.7.1/h/PaxHeaders/hppa-linux.h0000644000000000000000000000013214776006046014043 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.558908537 gcl-2.7.1/h/hppa-linux.h0000755000175000017500000000133114776006046013442 0ustar00cammcamm#include "linux.h" #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 */ #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.7.1/h/PaxHeaders/mp.h0000644000000000000000000000013214542551763012374 xustar0030 mtime=1703597043.204022746 30 atime=1744339813.059401686 30 ctime=1744351535.502909039 gcl-2.7.1/h/mp.h0000755000175000017500000001074014542551763011777 0ustar00cammcamm #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_fixnum1) ,x1,x2); \ action maybe_replace_big(big_fixnum1); \ } 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.7.1/h/PaxHeaders/elf32_m68k_reloc.h0000644000000000000000000000013114542551763014723 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.021953715 30 ctime=1744351535.526908824 gcl-2.7.1/h/elf32_m68k_reloc.h0000644000175000017500000000017414542551763014324 0ustar00cammcamm 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.7.1/h/PaxHeaders/amd64-linux.h0000644000000000000000000000013214776006046014026 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.546908644 gcl-2.7.1/h/amd64-linux.h0000644000175000017500000000077514776006046013435 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/powerpc-macosx.h0000644000000000000000000000013214542551763014727 xustar0030 mtime=1703597043.208022752 30 atime=1744294998.021953715 30 ctime=1744351535.558908537 gcl-2.7.1/h/powerpc-macosx.h0000644000175000017500000001317514542551763014334 0ustar00cammcamm/* 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.7.1/h/PaxHeaders/bds.h0000644000000000000000000000013214542551763012530 xustar0030 mtime=1703597043.196022733 30 atime=1744339813.007401361 30 ctime=1744351535.514908931 gcl-2.7.1/h/bds.h0000755000175000017500000000327714542551763012142 0ustar00cammcamm/* 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 */ typedef struct bds_bd { object bds_sym; /* symbol */ object bds_val; /* previous value of the symbol */ } *bds_ptr; EXTER bds_ptr bds_org,bds_limit,bds_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);\ if (++bds_top>=bds_limit) bds_overflow(); \ bds_top->bds_sym=_sym; \ bds_top->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.7.1/h/PaxHeaders/notcomp.h0000644000000000000000000000013214753634424013437 xustar0030 mtime=1739536660.886460969 30 atime=1744339813.007401361 30 ctime=1744351535.502909039 gcl-2.7.1/h/notcomp.h0000755000175000017500000002673414753634424013054 0ustar00cammcamm#include #include #include #include #include #define CHAR_CODE_LIMIT 256 #define READ_TABLE_SIZE CHAR_CODE_LIMIT 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 sigint(),sigalrm(); */ EXTER int gc_enabled, saving_system; EXTER object lisp_package,user_package; EXTER char *core_end; EXTER int catch_fatal; EXTER long real_maxpage; 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 /* 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) */ #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 MAKEFUNB(pack,string,fname,argd,p) \ (GMP_makefunb(string,fname,argd,p)) #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 mjoin(a_,b_) a_ ## b_ #define Mjoin(a_,b_) mjoin(a_,b_) #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_macro_function(a_,b_) make_macro_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_macro_function(a_,b_) make_macro_internal(a_,b_) #define make_si_sfun(a_,b_,c_) make_si_sfun_internal(a_,b_,c_) #define STATD #endif #undef DEFUN #define DEFUN(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,(void *)FFN(fname),F_ARGD(min,max,(flags|ONE_VAL),ARGTYPES(ret0a0,a12,a34,a56))); \ }\ STATD ret FFN(fname) args #define DEFUNB(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,p,doc) STATD ret FFN(fname) args; \ void Mjoin(fname,_init) () {\ MAKEFUNB(pack,string,(void *)FFN(fname),F_ARGD(min,max,(flags|ONE_VAL),ARGTYPES(ret0a0,a12,a34,a56)),p); \ }\ STATD ret FFN(fname) args #define DEFUNM(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,(void *)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) */ /* 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 */ #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<=(void *)core_end));}) #endif /* NULL_OR_ON_C_STACK */ #define siScomma sSXB EXTER object sSXB; #define inheap(pp) ((char *)(pp) < heap_end) #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 #ifdef EXPORT_GMP #include "bfdef.h" #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_)) #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 #include "prelink.h" #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;}) #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 BV_BITS CHAR_SIZE */ /* #define BV_ALLOC (BV_BITS*SIZEOF_LONG) */ #define BV_BITS (CHAR_SIZE*SIZEOF_LONG) #define BV_ALLOC BV_BITS #ifdef WORDS_BIGENDIAN #define BV_BIT(i) (1L<<(BV_BITS-1-((i)%BV_BITS))) #else #define BV_BIT(i) (1L<<((i)%BV_BITS)) #endif #define BITREF(x,i) ({ufixnum _i=(i);(BV_BIT(_i)&(x->bv.bv_self[_i/BV_BITS])) ? 1 : 0;}) #define SET_BITREF(x,i) ({ufixnum _i=(i);(x->bv.bv_self[_i/BV_BITS]) |= BV_BIT(_i);}) #define CLEAR_BITREF(x,i) ({ufixnum _i=(i);(x->bv.bv_self[_i/BV_BITS]) &= ~BV_BIT(_i);}) #define BIT_MASK(n_) ({char _n=n_;(_n==BV_BITS ? -1L : BV_BIT(_n)-1);}) #define VLEN(a_) ({object _a=(a_);(_a)->v.v_hasfillp ? (_a)->v.v_fillp : (_a)->v.v_dim;}) #define VFILLP_SET(a_,b_) \ ({object _a=(a_);ufixnum _b=(b_); \ if (_a->v.v_hasfillp) _a->v.v_fillp=_b;}) #define VSET_MAX_FILLP(a_) ({object _x=(a_);VFILLP_SET(_x,_x->v.v_dim);}) #define ADISP(a_) ({object _a=(a_);(_a)->a.a_adjustable ? (_a)->a.a_displaced : Cnil;}) #define SET_ADISP(a_,b_) ({object _a=(a_);if ((_a)->a.a_adjustable) (_a)->a.a_displaced=(b_);}) #define str(a_) \ ({string_register->st.st_self=(a_); \ string_register->st.st_dim=strlen(string_register->st.st_self); \ string_register;}) #define BLOCK_EXCEPTIONS(a_) \ ({fenv_t env; \ feholdexcept(&env); \ a_; \ fesetenv(&env);}) #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.7.1/h/PaxHeaders/elf32_sparc_reloc.h0000644000000000000000000000013114542551763015246 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.021953715 30 ctime=1744351535.530908788 gcl-2.7.1/h/elf32_sparc_reloc.h0000644000175000017500000000060514542551763014646 0ustar00cammcamm 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.7.1/h/PaxHeaders/make-init.h0000644000000000000000000000013214542551763013636 xustar0030 mtime=1703597043.204022746 30 atime=1744339837.823556348 30 ctime=1744351535.502909039 gcl-2.7.1/h/make-init.h0000755000175000017500000000431314542551763013240 0ustar00cammcamm#include "include.h" #include "num_include.h" #define IN_NEW_INIT #define SI 0 #define LISP 1 #define KEYWORD 2 #define NONE 0 #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,args,doc) \ {extern void Mjoin(fname,_init)(); Mjoin(fname,_init)();} #undef DEFUNB #define DEFUNB(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,p,doc) \ {extern void Mjoin(fname,_init)(); Mjoin(fname,_init)();} #undef DEFUNM #define DEFUNM(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,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.7.1/h/PaxHeaders/elf64_ppc_reloc.h0000644000000000000000000000013114542551763014725 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.021953715 30 ctime=1744351535.538908716 gcl-2.7.1/h/elf64_ppc_reloc.h0000644000175000017500000000117714542551763014332 0ustar00cammcamm#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.7.1/h/PaxHeaders/elf32_hppa_reloc_special.h0000644000000000000000000000013114542551763016566 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.021953715 30 ctime=1744351535.526908824 gcl-2.7.1/h/elf32_hppa_reloc_special.h0000644000175000017500000000225014542551763016164 0ustar00cammcammstatic 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.7.1/h/PaxHeaders/funlink.h0000644000000000000000000000013114542551763013425 xustar0029 mtime=1703597043.20002274 30 atime=1744339813.023401461 30 ctime=1744351535.498909075 gcl-2.7.1/h/funlink.h0000755000175000017500000001105414542551763013030 0ustar00cammcamm#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.7.1/h/PaxHeaders/globals.h0000644000000000000000000000013014542551763013401 xustar0029 mtime=1703597043.20002274 29 atime=1744339813.09540191 30 ctime=1744351535.498909075 gcl-2.7.1/h/globals.h0000644000175000017500000000075114542551763013004 0ustar00cammcammEXTER union lispunion Cnil_body OBJ_ALIGN; EXTER union lispunion Ct_body OBJ_ALIGN; #define MULTIPLE_VALUES_LIMIT 32 struct call_data { object fun; hfixnum argd; hfixnum nvalues; object values[MULTIPLE_VALUES_LIMIT]; fixnum valp; double double_return; }; EXTER struct call_data fcall; EXTER struct character character_table[256] OBJ_ALIGN; /*FIXME, sync with char code constants above.*/ EXTER struct unadjstring character_name_table[256] OBJ_ALIGN; EXTER object null_string; gcl-2.7.1/h/PaxHeaders/protoize.h0000644000000000000000000000013214766555457013647 xustar0030 mtime=1742396207.146952854 30 atime=1744339813.007401361 30 ctime=1744351535.510908967 gcl-2.7.1/h/protoize.h0000644000175000017500000016217414766555457013260 0ustar00cammcamm/* alloc.c:89:OF */ extern void *alloc_page (long n); /* (n) int n; */ /* alloc.c:149:OF */ void add_page_to_freelist (char *p, struct typemanager *tm); /* (p, tm) char *p; struct typemanager *tm; */ /* 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: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: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:262:OF */ extern void siLaset (void); /* () */ /* array.c:321:OF */ extern void siLsvset (void); /* () */ /* array.c:480:OF */ extern void siLmake_vector (void); /* () */ /* array.c:738:OF */ extern void adjust_displaced (object x); /* (x, diff) object x; int diff; */ /* array.c:790:OF */ extern void gset (void *p1, void *val, fixnum n, int typ); /* (p1, val, n, typ) char *p1; char *val; int n; int typ; */ /* 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:944:OF */ extern void Lfill_pointer (void); /* () */ /* array.c:986:OF */ extern void Larray_element_type (void); /* () */ /* array.c:995:OF */ extern void Ladjustable_array_p (void); /* () */ /* array.c:1002:OF */ extern void siLdisplaced_array_p (void); /* () */ /* array.c:1010:OF */ extern void Larray_rank (void); /* () */ /* array.c:1020:OF */ extern void Larray_dimension (void); /* () */ /* array.c:1090:OF */ extern void siLreplace_array (void); /* () */ /* 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:142:OF */ extern void siLfset (void); /* () */ /* assignment.c:228:OF */ extern void Lfmakunbound (void); /* () */ /* assignment.c:547:OF */ extern object clear_compiler_properties (object sym, object code); /* (sym, code) object sym; object code; */ /* 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; */ /* 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:454:OF */ extern object 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:482:OF */ extern void integer_quotient_remainder_1_ui (object x, unsigned long 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 *); /* (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: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,fixnum nval); /* (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,object cl,fixnum argd,fixnum sizes); /* (self, name, env, data) int (*self)(); object name; object env; object data; */ /* cfun.c:91:OF */ extern object make_cclosure(void *self,object data,object call,object key,ufixnum argd,ufixnum sizes,object *envp,ufixnum nargs,...); /* cfun.c:91:OF */ extern void add_to_env(object fun,ufixnum nargs,...); /* 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:371:OF */ extern void turbo_closure (object fun); /* (fun) object fun; */ /* cfun.c:403:OF */ extern void gcl_init_cfun (void); /* () */ /* cmac.c:191:OF */ extern void gcl_init_cmac (void); /* () */ /* cmpaux.c:33:OF */ extern void siLspecialp (void); /* () */ /* 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: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:660:OF */ extern void check_socket (object x); /* (x) object x; */ /* error.c:670:OF */ extern void check_stream (object strm); /* (strm) object strm; */ /* error.c:697:OF */ extern void check_arg_range (fixnum nn,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 Ievaln (object form,object *vals); /* (form) object form; */ #define Ieval1(a_) Ievaln(a_,0) /* eval.c:944:OF */ extern void eval (object form); /* (form) object form; */ /* eval.c:1189:OF */ extern void Leval (void); /* () */ /* eval.c:1203:OF */ extern void Levalhook (void); /* () */ /* eval.c:1269:OF */ extern void Lconstantp (void); /* () */ /* 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); /* eval.c:1348:OF */ extern object ifuncall4 (object fun, object arg1, object arg2, object arg3, object arg4); 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:435:OF */ extern void gcl_init_fat_string (void); /* () */ /* sfasli.c::OF */ extern void gcl_init_sfasl (void); /* () */ /* 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, int setf, void **link); /* (sym, link) object sym; void **link; */ /* funlink.c:41:OF */ extern void call_or_link_closure (object sym, int setf,void **link, void **ptr); /* (sym, link, ptr) object sym; void **link; object *ptr; */ /* funlink.c:696:OF */ extern object call_proc0 (object sym, int setf,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; */ /* 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: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); /* () */ /* 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,long,void *,char *); /* () */ /* 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:805:OF */ extern void Llisp_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: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 GMP_makefunb (char *strg, object (*fn) (/* ??? */), unsigned int argd,object p); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */ /* makefun.c:122:OF */ extern void SI_makefunm (char *strg, object (*fn) (/* ??? */), unsigned int argd); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */ /* makefun.c:131:OF */ extern void LISP_makefunm (char *strg, object (*fn) (/* ??? */), unsigned int argd); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */ /* 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); /* () */ object funcall_vec(object,fixnum,object *); /* 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)(), ufixnum 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: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:81:OF */ extern object make_fixnum1 (long i); /* (i) int i; */ /* number.c:102:OF */ extern object make_ratio (object num, object den,int); /* (num, den) object num; object den; */ /* number.c:144:OF */ extern object make_shortfloat (float 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:46:OF */ extern void Lsymbolp (void); /* () */ /* predicate.c:176:OF */ extern void Lcomplexp (void); /* () */ /* predicate.c:238:OF */ extern void Lsimple_string_p (void); /* () */ /* predicate.c:253:OF */ extern void Lsimple_bit_vector_p (void); /* () */ /* predicate.c:268:OF */ extern void Lsimple_vector_p (void); /* () */ /* predicate.c:301:OF */ extern void Lpackagep (void); /* () */ /* predicate.c:313:OF */ extern void Lfunctionp (void); /* () */ /* predicate.c:344:OF */ extern void Lcompiled_function_p (void); /* () */ /* 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: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: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:750:OF */ extern bool contains_sharp_comma (object x); /* (x) object x; */ /* 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; */ /* 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: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:209:OF */ extern void coerce_to_local_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: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: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: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, siginfo_t *a, void *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; */ /* 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 (fixnum n,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: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_function(void); void gcl_init_readline(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,object); void write_str(char *); 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 writec_pstream(int,object); void write_codes_pstream(object,fixnum,fixnum,fixnum,fixnum); void *writec_stream_fun(object); object output_stream(object); int digit_weight(int,int); void flush_stream(object); void writestr_pstream(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 Lstring_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 Lstring_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); struct cons * gethash(object,object); 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); #ifdef SPECIAL_RSYM void read_special_symbols(char *); /* int */ /* node_compare(const void *,const void *); */ #endif void FEpackage_error(object,const char *s); void FEcannot_coerce(object, object); int system_time_zone_helper(void); object call_proc_new(object sym,ufixnum clp,ufixnum vald,void **link,ufixnum argd,object first,va_list ll); object call_vproc_new(object,int setf,int pop_one_arg,void *,object,va_list); void funcall_with_catcher(object, object); void siLset_symbol_plist(void); void Lhash_table_p(void); void Lreadtablep(void); fixnum fixnum_expt(fixnum,fixnum); 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_gen_error_handler(object,object,object,object,ufixnum,...); /* #define Icall_error_handler(a_,b_,c_,d_...) \ */ /* Icall_gen_error_handler(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_) */ /* object */ /* Icall_error_handler(object,object,int,...); */ /* object */ /* Icall_continue_error_handler(object,object,object,int,...); */ void * gcl_gmp_alloc(size_t); void init_gmp_rnd_state(__gmp_randstate_struct *); int my_plt(const char *,unsigned long *); int my_pltp(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 powm_bbb(object,object,object); object powm_bfb(object,fixnum,object); object powm_fbb(fixnum,object,object); object powm_ffb(fixnum,fixnum,object); object powm_bbf(object,object,fixnum); object powm_bff(object,fixnum,fixnum); object powm_fbf(fixnum,object,fixnum); object powm_fff(fixnum,fixnum,fixnum); object find_init_name1(char *,unsigned); int gcl_isnan(object); long opt_maxpage(struct typemanager *); typedef MP_INT * GEN; MP_INT * otoi(object); MP_INT * stoi(fixnum); object read_byte1(object,object); #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 ); 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); unsigned long ihash_equal1(object,int); object interactive_stream_p(object); void reinit_gmp(void); object macro_def_int(object); /* void call_after_gbc_hook(int); */ int reset_plt(void); int msystem(char *); fcomplex object_to_fcomplex(object); object make_fcomplex(fcomplex); dcomplex object_to_dcomplex(object); void assert_error(const char *,unsigned,const char *,const char *); #ifdef _WIN32 void detect_wine(void); void init_shared_memory(void); #endif void * object_to_pointer(object); void * alloca(unsigned long); object make_dcomplex(dcomplex); object find_init_string(const char *); object quick_call_function_cs(object,...); object call_proc_cs(object,...); void * get_mmap(FILE *,void **); void * get_mmap_shared(FILE *,void **); object call_proc_cs1(object,...); int un_mmap(void *,void *); object call_proc_cs2(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 *); int update_real_maxpage(void); fixnum set_tm_maxpage(struct typemanager *,fixnum); fixnum elt_size(fixnum); fixnum elt_mode(fixnum); void init_gmp_rnd_state(__gmp_randstate_struct *); /* void set_sgc_bit(struct pageinfo *,void *); */ 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); extern void *feval_src; #if defined(DARWIN) void init_darwin_zone_compat (); #endif int get_cstack_dir(VOL fixnum); int gcl_mprotect(void *,unsigned long,int); void * alloc_code_space(size_t,ufixnum); void * alloc_contblock_no_gc(size_t,char *); struct pageinfo * get_pageinfo(void *); void reset_contblock_freelist(void); void setup_rb(bool); void empty_relblock(void); void close_pool(void); void gcl_cleanup(int); void do_gcl_abort(void); object n_cons_from_x(fixnum,object); int mbrk(void *); void prelink_init(void); fixnum check_avail_pages(void); void resize_hole(ufixnum,enum type,bool); void maybe_set_hole_from_maxpages(void); size_t dir_name_length(const char *); object new_cfdata(void); void set_displaced_body_ptr(object); void travel_find_sharing(object,object); object coerce_funcall_object_to_function(object); object gcl_make_hash_table(object); int home_namestring1(const char *,int,char *,int); object double_to_rational(double); object fresh_synonym_stream_to_terminal_io(void); void set_array_elttype(object,enum aelttype); object apply_format_function(object,object,object,object,object,object); object fSstring_match2(object,object); object aelttype_list(void); object alloc_simple_string(fixnum); object alloc_string(fixnum); object append(object,object); object car(object); object cdr(object); object copy_list(object); object copy_simple_string(object); object current_package(void); object find_package(object); object find_symbol(object,object); object getf(object,object,object); object intern(object,object); object make_constant(char *,object); object make_keyword(char *); object make_ordinary(char *); object make_si_constant(char *,object); object make_si_ordinary(char *); object make_si_special(char *,object); object make_special(char *,object); object nreverse(object); double object_to_double(object); object open_stream(object,enum smmode,object,object); object putf(object,object,object); object putprop(object,object,object); object read_object(object); object read_object_non_recursive(object); object make_symbol(object); object reverse(object); object alloc_bitvector(fixnum); object alloc_simple_bitvector(fixnum); object alloc_simple_vector(fixnum); object alloc_vector(fixnum,enum aelttype); object coerce_to_character(object); object peek_char(bool,object); object prin1(object,object); object read_char(object); object make_string_output_stream(int); object make_gmp_ordinary(char *); void *malloc(size_t); void *realloc(void *,size_t); void *alloc_contblock(size_t); void *alloc_relblock(size_t); object ifuncall(object,int,...); object list(fixnum,...); object listA(fixnum,...); object vs_overflow(void); object make_fixnum1(long); object make_shortfloat(float); long fixint(object); object read_char1(object,object); object Iapply_fun_n(object,int,int,...); object Iapply_fun_n2(object,int,int,...); object Ifuncall_n(object,int,...); object funcall_cfun(void(*)(),int,...); int gcl_init_cmp_anon(void); int is_bigger_fixnum(void *); int is_text_addr(void *); int seek_to_end_ofile(FILE *); void stack_list(void); void *msbrk(intptr_t); int msbrk_init(void); int msbrk_end(void); gcl-2.7.1/h/PaxHeaders/eval.h0000644000000000000000000000013214555557372012715 xustar0030 mtime=1706483450.788392733 30 atime=1744339813.007401361 30 ctime=1744351535.494909111 gcl-2.7.1/h/eval.h0000644000175000017500000000707414555557372012323 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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,env_top) ({extern int Rset;int rset=Rset;if (!rset) {ihs_check;ihs_push(x);}(*(x)->cc.cc_self)(env_top);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.7.1/h/PaxHeaders/elf64_alpha_reloc_special.h0000644000000000000000000000013114542551763016730 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.025953732 30 ctime=1744351535.534908752 gcl-2.7.1/h/elf64_alpha_reloc_special.h0000644000175000017500000001043014542551763016325 0ustar00cammcammstatic 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.7.1/h/PaxHeaders/mipsel-linux.h0000644000000000000000000000013214776006046014404 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.550908609 gcl-2.7.1/h/mipsel-linux.h0000755000175000017500000000004014776006046013777 0ustar00cammcamm#include "linux.h" #define SGC gcl-2.7.1/h/PaxHeaders/sh4-linux.h0000644000000000000000000000013214776006046013611 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.546908644 gcl-2.7.1/h/sh4-linux.h0000755000175000017500000000106014776006046013207 0ustar00cammcamm#include "linux.h" #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 (;p1) \ 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 #define RF_mpz_t mpz_t #define RF_gmp_randstate_t gmp_randstate_t /* #define RF_gmp_char_star_star char ** */ #define P1(bt_) Join(RF_,bt_) _b #define P2(bt_,ct_) P1(bt_),Join(RF_,ct_) _c #define P3(bt_,ct_,dt_) P2(bt_,ct_),Join(RF_,dt_) _d #define P4(bt_,ct_,dt_,et_) P3(bt_,ct_,dt_),Join(RF_,et_) _e #define P5(bt_,ct_,dt_,et_,ft_) P4(bt_,ct_,dt_,et_),Join(RF_,ft_) _f #define A1 _b #define A2 A1,_c #define A3 A2,_d #define A4 A3,_e #define A5 A4,_f #define SS_40 4 #define SS_30 3 #define SS_20 2 #define SS_10 1 #define SS_00 0 #define SS_41 3 #define SS_31 2 #define SS_21 1 #define SS_11 0 #define SS_42 2 #define SS_32 1 #define SS_22 0 #define SS_43 1 #define SS_33 0 #define SS_44 0 #define SS_53 2 #define PP_gmp_ulint 1 #define PP_gmp_lint 1 #define PP_int 1 #define PP_size_t 1 #define PP_void 0 #define PP_00 0 #define PP_10 1 #define PP_11 2 #define PP_20 2 #define PP_21 3 #define PP0(a_) Join(PP_,a_) #define PP1(a_) Join(PP_1,Join(PP_,a_)) #define PP2(a_) Join(PP_2,Join(PP_,a_)) #define QQQ_gmp_ulint f #define QQQ_gmp_lint f #define QQQ_int f #define QQQ_size_t f #define QQQ_mpz_t b #define QQ10(a_) Join(QQQ_,a_) #define QQ20(a_,b_) QQ10(a_),QQ10(b_) #define QQ30(a_,b_,c_) QQ20(a_,b_),QQ10(c_) #define QQ40(a_,b_,c_,d_) QQ30(a_,b_,c_),QQ10(d_) #define QQ11(a_) #define QQ21(a_,b_) QQ10(b_) #define QQ31(a_,b_,c_) QQ20(b_,c_) #define QQ41(a_,b_,c_,d_) QQ30(b_,c_,d_) #define QQ22(a_,b_) #define QQ32(a_,b_,c_) QQ10(c_) #define QQ42(a_,b_,c_,d_) QQ20(c_,d_) #define QQ53(a_,b_,c_,d_,e_) QQ20(d_,e_) #define ZZ_gmp_ulint f #define ZZ_gmp_lint f #define ZZ_int f #define ZZ_size_t f #define ZZ_void #define ZZ3(a_) Join(Join(ZZ_,a_),bbb) #define ZZ2(a_) Join(Join(ZZ_,a_),bb) #define ZZ1(a_) Join(Join(ZZ_,a_),b) #define ZZ0(a_) Join(ZZ_,a_) #ifndef BF #define BF(n_,b_,r_,a_...) #endif /* #undef mpz_get_strp */ /* #define mpz_get_strp __gmpz_get_strp */ /* GMP_EXTERN_INLINE char * */ /* __gmpz_get_strp(char **a,int b,mpz_t c) {return __gmpz_get_str(*a,b,c);} /\*FIXME*\/ */ /* 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_);\ } #define EXPORT_GMP_CALL(n_,rt_,a_,s_,b_...) \ MEM_GMP_CALL(n_,rt_,Join(mpz_,a_),s_,b_) \ BF(n_,Join(SS_,Join(n_,s_)),s_,a_,Join(ZZ,s_)(rt_),Join(QQ,Join(n_,s_))(b_)) MEM_GMP_CALL(3,void,mpz_urandomm,1,mpz_t,gmp_randstate_t,mpz_t) MEM_GMP_CALL(2,void,gmp_randseed,1,gmp_randstate_t,mpz_t) MEM_GMP_CALL(2,void,gmp_randseed_ui,1,gmp_randstate_t,gmp_ulint) MEM_GMP_CALL(1,void,gmp_randinit_default,0,gmp_randstate_t) EXPORT_GMP_CALL(2,gmp_ulint,scan0,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,gmp_ulint,scan1,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,add,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,add_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,sub,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,sub_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,ui_sub,1,mpz_t,gmp_ulint,mpz_t) EXPORT_GMP_CALL(3,void,mul,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,mul_si,1,mpz_t,mpz_t,gmp_lint) EXPORT_GMP_CALL(3,void,mul_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,mul_2exp,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,void,neg,1,mpz_t,mpz_t) EXPORT_GMP_CALL(4,void,tdiv_qr,2,mpz_t,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,fdiv_q_2exp,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,int,cmp,0,mpz_t,mpz_t) EXPORT_GMP_CALL(2,int,cmpabs,0,mpz_t,mpz_t) EXPORT_GMP_CALL(2,int,cmpabs_ui,0,mpz_t,gmp_ulint) /* EXPORT_GMP_CALL(2,int,cmp_si,0,mpz_t,gmp_lint) */ /*macro*/ /* EXPORT_GMP_CALL(2,int,cmp_ui,0,mpz_t,gmp_ulint) */ EXPORT_GMP_CALL(3,void,and,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,xor,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,ior,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(2,void,com,1,mpz_t,mpz_t) EXPORT_GMP_CALL(2,int,tstbit,0,mpz_t,gmp_ulint) MEM_GMP_CALL(1,void,mpz_init,1,mpz_t) MEM_GMP_CALL(2,void,mpz_init_set,1,mpz_t,mpz_t) EXPORT_GMP_CALL(2,void,set,1,mpz_t,mpz_t) EXPORT_GMP_CALL(2,void,set_ui,1,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,void,set_si,1,mpz_t,gmp_lint) MEM_GMP_CALL(1,double,mpz_get_d,0,mpz_t) EXPORT_GMP_CALL(1,gmp_lint,get_si,0,mpz_t) EXPORT_GMP_CALL(1,gmp_lint,get_ui,0,mpz_t) MEM_GMP_CALL(3,gmp_char_star,mpz_get_str,0,gmp_char_star,int,mpz_t) MEM_GMP_CALL(3,int,mpz_set_str,0,mpz_t,gmp_char_star,int)/*arg set, but 0 for check as moot*/ EXPORT_GMP_CALL(1,int,fits_sint_p,0,mpz_t) EXPORT_GMP_CALL(1,int,fits_slong_p,0,mpz_t) EXPORT_GMP_CALL(1,int,fits_sshort_p,0,mpz_t) EXPORT_GMP_CALL(1,int,fits_uint_p,0,mpz_t) EXPORT_GMP_CALL(1,int,fits_ulong_p,0,mpz_t) EXPORT_GMP_CALL(1,int,fits_ushort_p,0,mpz_t) EXPORT_GMP_CALL(1,gmp_ulint,popcount,0,mpz_t) EXPORT_GMP_CALL(1,size_t,size,0,mpz_t) EXPORT_GMP_CALL(2,size_t,sizeinbase,0,mpz_t,int) EXPORT_GMP_CALL(3,void,gcd,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(5,void,gcdext,3,mpz_t,mpz_t,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,gmp_ulint,gcd_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,divexact,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,divexact_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,void,fac_ui,1,mpz_t,gmp_ulint) EXPORT_GMP_CALL(4,void,powm,1,mpz_t,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(4,void,powm_ui,1,mpz_t,mpz_t,gmp_ulint,mpz_t) EXPORT_GMP_CALL(3,void,ui_pow_ui,1,mpz_t,gmp_ulint,gmp_ulint) EXPORT_GMP_CALL(3,void,pow_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,int,probab_prime_p,0,mpz_t,int) EXPORT_GMP_CALL(2,void,nextprime,1,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,lcm,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,lcm_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,invert,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(2,int,jacobi,0,mpz_t,mpz_t) EXPORT_GMP_CALL(2,int,kronecker_si,0,mpz_t,gmp_lint) EXPORT_GMP_CALL(2,int,kronecker_ui,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,int,si_kronecker,0,gmp_lint,mpz_t) EXPORT_GMP_CALL(2,int,ui_kronecker,0,gmp_ulint,mpz_t) EXPORT_GMP_CALL(3,gmp_ulint,remove,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,bin_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,bin_uiui,1,mpz_t,gmp_ulint,gmp_ulint) EXPORT_GMP_CALL(2,void,fib_ui,1,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,fib2_ui,2,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,void,lucnum_ui,1,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,lucnum2_ui,2,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,mod,1,mpz_t,mpz_t,mpz_t) /* EXPORT_GMP_CALL(3,void,mod_ui,1,mpz_t,mpz_t,gmp_ulint) */ /*alias*/ EXPORT_GMP_CALL(2,gmp_ulint,millerrabin,0,mpz_t,int) EXPORT_GMP_CALL(2,gmp_ulint,hamdist,0,mpz_t,mpz_t) /* EXPORT_GMP_CALL(1,int,odd_p,0,mpz_t) */ /*macro*/ /* EXPORT_GMP_CALL(1,int,even_p,0,mpz_t) */ EXPORT_GMP_CALL(3,int,root,1,mpz_t,mpz_t,gmp_ulint)/* mult val*/ EXPORT_GMP_CALL(4,void,rootrem,2,mpz_t,mpz_t,mpz_t,gmp_ulint)/* mult val*/ EXPORT_GMP_CALL(2,void,sqrt,1,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,sqrtrem,2,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(1,int,perfect_power_p,0,mpz_t) EXPORT_GMP_CALL(1,int,perfect_square_p,0,mpz_t) EXPORT_GMP_CALL(3,void,cdiv_q,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,cdiv_r,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(4,void,cdiv_qr,2,mpz_t,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,gmp_ulint,cdiv_q_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,gmp_ulint,cdiv_r_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(4,gmp_ulint,cdiv_qr_ui,2,mpz_t,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,gmp_ulint,cdiv_ui,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,cdiv_q_2exp,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,cdiv_r_2exp,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,fdiv_q,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,fdiv_r,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(4,void,fdiv_qr,2,mpz_t,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,gmp_ulint,fdiv_q_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,gmp_ulint,fdiv_r_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(4,gmp_ulint,fdiv_qr_ui,2,mpz_t,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,gmp_ulint,fdiv_ui,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,fdiv_r_2exp,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,tdiv_q,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,tdiv_r,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,gmp_ulint,tdiv_q_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,gmp_ulint,tdiv_r_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(4,gmp_ulint,tdiv_qr_ui,2,mpz_t,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,gmp_ulint,tdiv_ui,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,tdiv_q_2exp,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,tdiv_r_2exp,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,int,divisible_p,0,mpz_t,mpz_t) EXPORT_GMP_CALL(2,int,divisible_ui_p,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,int,divisible_2exp_p,0,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,int,congruent_p,0,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,int,congruent_ui_p,0,mpz_t,gmp_ulint,gmp_ulint) EXPORT_GMP_CALL(3,int,congruent_2exp_p,0,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,addmul,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,addmul_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(3,void,submul,1,mpz_t,mpz_t,mpz_t) EXPORT_GMP_CALL(3,void,submul_ui,1,mpz_t,mpz_t,gmp_ulint) EXPORT_GMP_CALL(2,void,abs,1,mpz_t,mpz_t) /* MEM_GMP_CALL(2,void *,mpz_realloc,mpz_t,mp_size_t)*/ /* MEM_GMP_CALL(2,int,mpz_legendre,0,mpz_t,mpz_t) */ /*alias*/ /* MEM_GMP_CALL(2,int,mpz_kronecker,0,mpz_t,mpz_t) */ /* FIXME: find a way to have this follow the convention in gmp.h*/ #define __gmpz_urandomm m__gmpz_urandomm #define __gmp_randseed m__gmp_randseed #define __gmp_randseed_ui m__gmp_randseed_ui #define __gmp_randinit_default m__gmp_randinit_default #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_mul_ui m__gmpz_mul_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_str m__gmpz_get_str #define __gmpz_set_str m__gmpz_set_str #define __gmpz_get_si m__gmpz_get_si #define __gmpz_fits_sint_p m__gmpz_fits_sint_p #define __gmpz_popcount m__gmpz_popcount #define __gmpz_size m__gmpz_size #define __gmpz_sizeinbase m__gmpz_sizeinbase #define __gmpz_gcd m__gmpz_gcd #define __gmpz_gcd_ui m__gmpz_gcd_ui #define __gmpz_divexact m__gmpz_divexact #define __gmpz_divexact_ui m__gmpz_divexact_ui #define __gmpz_fac_ui m__gmpz_fac_ui #define __gmpz_powm m__gmpz_powm #define __gmpz_powm_ui m__gmpz_powm_ui #define __gmpz_ui_pow_ui m__gmpz_ui_pow_ui #define __gmpz_pow_ui m__gmpz_pow_ui #define __gmpz_probab_prime_p m__gmpz_probab_prime_p #define __gmpz_nextprime m__gmpz_nextprime #define __gmpz_lcm m__gmpz_lcm #define __gmpz_lcm_ui m__gmpz_lcm_ui #define __gmpz_invert m__gmpz_invert #define __gmpz_jacobi m__gmpz_jacobi #define __gmpz_kronecker_si m__gmpz_kronecker_si #define __gmpz_kronecker_ui m__gmpz_kronecker_ui #define __gmpz_si_kronecker m__gmpz_si_kronecker #define __gmpz_ui_kronecker m__gmpz_ui_kronecker #define __gmpz_remove m__gmpz_remove #define __gmpz_bin_ui m__gmpz_bin_ui #define __gmpz_bin_uiui m__gmpz_bin_uiui #define __gmpz_fib_ui m__gmpz_fib_ui #define __gmpz_fib2_ui m__gmpz_fib2_ui #define __gmpz_lucnum_ui m__gmpz_lucnum_ui #define __gmpz_lucnum2_ui m__gmpz_lucnum2_ui #define __gmpz_hamdist m__gmpz_hamdist #define __gmpz_odd_p m__gmpz_odd_p #define __gmpz_even_p m__gmpz_even_p #define __gmpz_root m__gmpz_root #define __gmpz_rootrem m__gmpz_rootrem #define __gmpz_sqrt m__gmpz_sqrt #define __gmpz_sqrtrem m__gmpz_sqrtrem #define __gmpz_perfect_power_p m__gmpz_perfect_power_p #define __gmpz_perfect_square_p m__gmpz_perfect_square_p #define __gmpz_cdiv_q m__gmpz_cdiv_q #define __gmpz_cdiv_r m__gmpz_cdiv_r #define __gmpz_cdiv_qr m__gmpz_cdiv_qr #define __gmpz_cdiv_q_ui m__gmpz_cdiv_q_ui #define __gmpz_cdiv_r_ui m__gmpz_cdiv_r_ui #define __gmpz_cdiv_qr_ui m__gmpz_cdiv_qr_ui #define __gmpz_cdiv_ui m__gmpz_cdiv_ui #define __gmpz_cdiv_q_2exp m__gmpz_cdiv_q_2exp #define __gmpz_cdiv_r_2exp m__gmpz_cdiv_r_2exp #define __gmpz_fdiv_q m__gmpz_fdiv_q #define __gmpz_fdiv_r m__gmpz_fdiv_r #define __gmpz_fdiv_qr m__gmpz_fdiv_qr #define __gmpz_fdiv_q_ui m__gmpz_fdiv_q_ui #define __gmpz_fdiv_r_ui m__gmpz_fdiv_r_ui #define __gmpz_fdiv_qr_ui m__gmpz_fdiv_qr_ui #define __gmpz_fdiv_ui m__gmpz_fdiv_ui #define __gmpz_fdiv_r_2exp m__gmpz_fdiv_r_2exp #define __gmpz_tdiv_q m__gmpz_tdiv_q #define __gmpz_tdiv_r m__gmpz_tdiv_r #define __gmpz_tdiv_q_ui m__gmpz_tdiv_q_ui #define __gmpz_tdiv_r_ui m__gmpz_tdiv_r_ui #define __gmpz_tdiv_qr_ui m__gmpz_tdiv_qr_ui #define __gmpz_tdiv_ui m__gmpz_tdiv_ui #define __gmpz_tdiv_q_2exp m__gmpz_tdiv_q_2exp #define __gmpz_tdiv_r_2exp m__gmpz_tdiv_r_2exp #define __gmpz_divisible_p m__gmpz_divisible_p #define __gmpz_divisible_ui_p m__gmpz_divisible_ui_p #define __gmpz_divisible_2exp_p m__gmpz_divisible_2exp_p #define __gmpz_congruent_p m__gmpz_congruent_p #define __gmpz_congruent_ui_p m__gmpz_congruent_ui_p #define __gmpz_congruent_2exp_p m__gmpz_congruent_2exp_p #define __gmpz_addmul m__gmpz_addmul #define __gmpz_addmul_ui m__gmpz_addmul_ui #define __gmpz_submul m__gmpz_submul #define __gmpz_submul_ui m__gmpz_submul_ui #define __gmpz_abs m__gmpz_abs #endif gcl-2.7.1/h/PaxHeaders/elf64_ppcle_reloc.h0000644000000000000000000000013114542551763015246 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.025953732 30 ctime=1744351535.538908716 gcl-2.7.1/h/elf64_ppcle_reloc.h0000644000175000017500000000252314542551763014647 0ustar00cammcamm#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.7.1/h/PaxHeaders/elf32_mips_reloc_special.h0000644000000000000000000000013114542551763016606 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.025953732 30 ctime=1744351535.530908788 gcl-2.7.1/h/elf32_mips_reloc_special.h0000644000175000017500000000754314542551763016216 0ustar00cammcamm#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.7.1/h/PaxHeaders/att_ext.h0000644000000000000000000000013114565740505013426 xustar0029 mtime=1708638533.12156778 30 atime=1744339813.023401461 30 ctime=1744351535.518908896 gcl-2.7.1/h/att_ext.h0000644000175000017500000002367514565740505013042 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 * memalign(size_t,size_t); */ /* array.c */ EXTER object sLarray_dimension_limit; EXTER object sLarray_total_size_limit; /* assignment.c */ /* backq.c */ EXTER int backq_level; EXTER object sLlistA; EXTER object sLappend; EXTER object sLnconc; /* bds.c */ /* big.c */ EXTER struct bignum big_fixnum1_body,big_fixnum2_body,big_fixnum3_body,big_fixnum4_body,big_fixnum5_body; EXTER object big_fixnum1,big_fixnum2,big_fixnum3,big_fixnum4,big_fixnum5; /* bind.c */ EXTER object ANDoptional; EXTER object ANDrest; EXTER object ANDkey; EXTER object ANDallow_other_keys; EXTER object ANDaux; EXTER object sKallow_other_keys; /* block.c */ /* cfun.c */ /* 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; /* catch.c */ /* cmpaux.c */ /* error.c */ EXTER object sKerror,sKparse_error,sKreader_error,sKprogram_error; EXTER object sKwrong_type_argument; EXTER object sKcontrol_error; 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; EXTER object sSuniversal_error_handler; EXTER object sSPminus_most_negative_fixnumP; /* eval.c */ EXTER object sLapply; EXTER object sLfuncall; EXTER object siVevalhook; EXTER object siVapplyhook; /* 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; #ifdef UNIX /* unixfsys.c */ #else /* filesystem.c */ #endif /* frame.c */ /* gbc.c */ EXTER bool GBC_enable; #ifdef CAN_UNRANDOMIZE_SBRK EXTER bool gcl_unrandomized; #endif /* let.c */ /* lex.c */ /* list.d */ EXTER object sKtest; EXTER object sKtest_not; EXTER object sKkey; EXTER object sKinitial_element; /* EXTER object sKrev; */ /* macros.c */ EXTER object sLAmacroexpand_hookA; EXTER object sSdefmacroA; /* main.c */ EXTER char * system_directory; EXTER int ARGC; EXTER char **ARGV; #ifdef UNIX EXTER char **ENVP; #endif EXTER object sSAsystem_directoryA; #ifdef UNIX EXTER char *kcl_self; #endif #if !defined(IN_MAIN) || !defined(ATT) EXTER bool raw_image; #endif 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);}) */ /* num_pred.c */ /* num_comp.c */ /* num_arith */ /* num_co.c */ /* num_log.c */ /* package.d */ EXTER object lisp_package; EXTER object user_package; EXTER object keyword_package; EXTER object system_package; EXTER object gmp_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; /* 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; /* print.d */ EXTER object sKupcase; EXTER object sKdowncase; EXTER object sKpreserve; EXTER object sKinvert; 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 sKlinear; EXTER object sKmiser; EXTER object sKfill; EXTER object sKmandatory; EXTER object sKcurrent; EXTER object sKblock; 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 sSAprint_contextA; EXTER object sSAprint_context_headA; 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 int READdefault_float_format; EXTER int READbase; EXTER bool READsuppress; EXTER bool READeval; 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; /* fasdump.c */ EXTER object sharing_table; /* reference.c */ /* sequence.d */ /* structure.c */ EXTER object sSs_data; /* string.d */ 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; #ifdef UNIX /* unixsys.c */ #else /* sys.c */ #endif #ifdef UNIX /* unixtime.c */ #else /* time.c */ #endif /* toplevel.c */ EXTER object sLspecial,sLdeclare; EXTER object sSvariable_documentation; EXTER object sSfunction_documentation; EXTER object sSsetf_function; #define setf_fn_form(a_) (consp(a_) && MMcar(a_)==sLsetf &&\ consp(MMcdr(a_)) && type_of(MMcadr(a_))==t_symbol &&\ MMcddr(a_)==Cnil) /* typespec.c */ EXTER object sLcommon,sLnull,sLcons,sLlist,siLproper_list,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,sLratio,sLshort_float,sLstandard_char; EXTER object sLchar,sLnon_negative_char,sLnegative_char,sLsigned_char,sLunsigned_char; EXTER object sLshort,sLnon_negative_short,sLnegative_short,sLsigned_short,sLunsigned_short; EXTER object sLfixnum,sLnon_negative_fixnum,sLnegative_fixnum,sLsigned_fixnum,sLunsigned_fixnum; EXTER object sLlfixnum,sLnon_negative_lfixnum,sLnegative_lfixnum; EXTER object sLsigned_lfixnum,sLunsigned_lfixnum,sLnegative_bignum,sLnon_negative_bignum,sLbase_char; EXTER object sLsigned_int,sLnon_negative_int,sLnegative_int,sLunsigned_int; EXTER object sLseqind,sLrnkind; EXTER object sLcomplex; EXTER object sLsingle_float,sLpackage,sLbignum,sLrandom_state,sLdouble_float,sLstream,sLbit,sLreadtable; EXTER object sLlong_float,sLhash_table,sLstructure,sLboolean,sLfile_stream,sLinput_stream,sLoutput_stream,sLtype_error; EXTER object sLbroadcast_stream,sLconcatenated_stream,sLecho_stream,sLfile_stream,sLstring_stream; EXTER object sLsynonym_stream,sLtwo_way_stream; 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 sSAlink_arrayA; /* nfunlink.c */ /* object Icall_proc(); */ EXTER object sSPmemory; EXTER object sSPinit; /* string.d */ int (*casefun)(); gcl-2.7.1/h/PaxHeaders/gclincl.h.in0000644000000000000000000000013214776130437014000 xustar0030 mtime=1744351519.335055113 30 atime=1744351519.971049295 30 ctime=1744351535.438909613 gcl-2.7.1/h/gclincl.h.in0000644000175000017500000002576614776130437013416 0ustar00cammcamm/* h/gclincl.h.in. Generated from configure.ac by autoheader. */ /* binding stack size */ #undef BDSSIZE /* maximum C stack size */ #undef CSSIZE /* C stack alignment */ #undef CSTACK_ALIGNMENT /* 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 /* 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 /* 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 '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 /* can madvise hugepages */ #undef HAVE_MADVISE_HUGEPAGE /* 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 header file. */ #undef HAVE_MINIX_CONFIG_H /* Define to 1 if you have the 'mprotect' function. */ #undef HAVE_MPROTECT /* can use nsocket library */ #undef HAVE_NSOCKET /* Define to 1 if you have the 'print_insn_i386' function. */ #undef HAVE_PRINT_INSN_I386 /* have putenv call */ #undef HAVE_PUTENV /* Define to 1 if you have the header file. */ #undef HAVE_READLINE_READLINE_H /* Define to 1 if you have the 'readlinkat' function. */ #undef HAVE_READLINKAT /* Define to 1 if you have the 'rename' function. */ #undef HAVE_RENAME /* 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 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_TYPES_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 /* Define to 1 if you have the header file. */ #undef HAVE_WCHAR_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 /* sizeof mp_limb in gmp library */ #undef MP_LIMB_BYTES /* 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 /* bfd output mach */ #undef OUTPUT_MACH /* 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 /* 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 /* The size of 'char', as computed by sizeof. */ #undef SIZEOF_CHAR /* sizeof linked list for contiguous pages */ #undef SIZEOF_CONTBLOCK /* The size of 'int', as computed by sizeof. */ #undef SIZEOF_INT /* sizeof jmp_buf */ #undef SIZEOF_JMP_BUF /* The size of 'long', as computed by sizeof. */ #undef SIZEOF_LONG /* The size of 'short', as computed by sizeof. */ #undef SIZEOF_SHORT /* 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 C89 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 /* use fionbio for non-blocking io */ #undef USE_FIONBIO /* use gprof */ #undef USE_GPROF /* use readline library */ #undef USE_READLINE /* protect cdr from immfix and speed up type processing */ #undef USE_SAFE_CDR /* Enable extensions on AIX, Interix, z/OS. */ #ifndef _ALL_SOURCE # undef _ALL_SOURCE #endif /* Enable general extensions on macOS. */ #ifndef _DARWIN_C_SOURCE # undef _DARWIN_C_SOURCE #endif /* Enable general extensions on Solaris. */ #ifndef __EXTENSIONS__ # undef __EXTENSIONS__ #endif /* Enable GNU extensions on systems that have them. */ #ifndef _GNU_SOURCE # undef _GNU_SOURCE #endif /* Enable X/Open compliant socket functions that do not require linking with -lxnet on HP-UX 11.11. */ #ifndef _HPUX_ALT_XOPEN_SOCKET_API # undef _HPUX_ALT_XOPEN_SOCKET_API #endif /* Identify the host operating system as Minix. This macro does not affect the system headers' behavior. A future release of Autoconf may stop defining this macro. */ #ifndef _MINIX # undef _MINIX #endif /* Enable general extensions on NetBSD. Enable NetBSD compatibility extensions on Minix. */ #ifndef _NETBSD_SOURCE # undef _NETBSD_SOURCE #endif /* Enable OpenBSD compatibility extensions on NetBSD. Oddly enough, this does nothing on OpenBSD. */ #ifndef _OPENBSD_SOURCE # undef _OPENBSD_SOURCE #endif /* Define to 1 if needed for POSIX-compatible behavior. */ #ifndef _POSIX_SOURCE # undef _POSIX_SOURCE #endif /* Define to 2 if needed for POSIX-compatible behavior. */ #ifndef _POSIX_1_SOURCE # undef _POSIX_1_SOURCE #endif /* Enable POSIX-compatible threading on Solaris. */ #ifndef _POSIX_PTHREAD_SEMANTICS # undef _POSIX_PTHREAD_SEMANTICS #endif /* Enable extensions specified by ISO/IEC TS 18661-5:2014. */ #ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__ # undef __STDC_WANT_IEC_60559_ATTRIBS_EXT__ #endif /* Enable extensions specified by ISO/IEC TS 18661-1:2014. */ #ifndef __STDC_WANT_IEC_60559_BFP_EXT__ # undef __STDC_WANT_IEC_60559_BFP_EXT__ #endif /* Enable extensions specified by ISO/IEC TS 18661-2:2015. */ #ifndef __STDC_WANT_IEC_60559_DFP_EXT__ # undef __STDC_WANT_IEC_60559_DFP_EXT__ #endif /* Enable extensions specified by C23 Annex F. */ #ifndef __STDC_WANT_IEC_60559_EXT__ # undef __STDC_WANT_IEC_60559_EXT__ #endif /* Enable extensions specified by ISO/IEC TS 18661-4:2015. */ #ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__ # undef __STDC_WANT_IEC_60559_FUNCS_EXT__ #endif /* Enable extensions specified by C23 Annex H and ISO/IEC TS 18661-3:2015. */ #ifndef __STDC_WANT_IEC_60559_TYPES_EXT__ # undef __STDC_WANT_IEC_60559_TYPES_EXT__ #endif /* Enable extensions specified by ISO/IEC TR 24731-2:2010. */ #ifndef __STDC_WANT_LIB_EXT2__ # undef __STDC_WANT_LIB_EXT2__ #endif /* Enable extensions specified by ISO/IEC 24747:2009. */ #ifndef __STDC_WANT_MATH_SPEC_FUNCS__ # undef __STDC_WANT_MATH_SPEC_FUNCS__ #endif /* Enable extensions on HP NonStop. */ #ifndef _TANDEM_SOURCE # undef _TANDEM_SOURCE #endif /* Enable X/Open extensions. Define to 500 only if necessary to make mbstate_t available. */ #ifndef _XOPEN_SOURCE # undef _XOPEN_SOURCE #endif /* Version number of package */ #undef VERSION /* 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 as 'unsigned int' if doesn't define. */ #undef size_t gcl-2.7.1/h/PaxHeaders/page.h0000644000000000000000000000013214766555457012710 xustar0030 mtime=1742396207.146952854 30 atime=1744339817.291428084 30 ctime=1744351535.506909003 gcl-2.7.1/h/page.h0000755000175000017500000000756514766555457012326 0ustar00cammcamm#define MAYBE_DATA_P(pp) ((char *)(pp)>= (char *) data_start)/*DBEGIN*/ #define VALID_DATA_ADDRESS_P(pp) (MAYBE_DATA_P(pp) && inheap(pp)) #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; #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);}),1) #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.7.1/h/PaxHeaders/amd64-gnu.h0000644000000000000000000000013214776006046013460 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.550908609 gcl-2.7.1/h/amd64-gnu.h0000755000175000017500000000110114776006046013052 0ustar00cammcamm#include "linux.h" #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 "elf64_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.7.1/h/PaxHeaders/pageinfo.h0000644000000000000000000000013114542551763013547 xustar0030 mtime=1703597043.208022752 29 atime=1744339813.08740186 30 ctime=1744351535.506909003 gcl-2.7.1/h/pageinfo.h0000644000175000017500000000026214542551763013146 0ustar00cammcamm#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.7.1/h/PaxHeaders/compbas.h0000644000000000000000000000013114542551763013403 xustar0030 mtime=1703597043.196022733 29 atime=1744339813.08740186 30 ctime=1744351535.490909147 gcl-2.7.1/h/compbas.h0000755000175000017500000000027714542551763013013 0ustar00cammcamm#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.7.1/h/PaxHeaders/gnuwin95.h0000644000000000000000000000013114760704751013443 xustar0030 mtime=1740868073.359093586 29 atime=1744294998.02995375 30 ctime=1744351535.562908501 gcl-2.7.1/h/gnuwin95.h0000755000175000017500000000571114760704751013051 0ustar00cammcamm#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) seek_to_end_ofile(fp) #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.7.1/h/PaxHeaders/s390-linux.h0000644000000000000000000000013214776006046013611 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.554908573 gcl-2.7.1/h/s390-linux.h0000755000175000017500000000033114776006046013207 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/mips-linux.h0000644000000000000000000000013214776006046014063 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.550908609 gcl-2.7.1/h/mips-linux.h0000755000175000017500000000104114776006046013460 0ustar00cammcamm#include "linux.h" /* 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.7.1/h/PaxHeaders/stacks.h0000644000000000000000000000013214542551763013250 xustar0030 mtime=1703597043.208022752 30 atime=1744339837.443553971 30 ctime=1744351535.510908967 gcl-2.7.1/h/stacks.h0000755000175000017500000000134514542551763012654 0ustar00cammcamm#ifndef VSSIZE #define VSSIZE 512*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 8*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 32*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 8*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.7.1/h/PaxHeaders/compat.h0000644000000000000000000000013214542551763013243 xustar0030 mtime=1703597043.196022733 30 atime=1744339813.027401486 30 ctime=1744351535.518908896 gcl-2.7.1/h/compat.h0000755000175000017500000000100114542551763012634 0ustar00cammcamm #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.7.1/h/PaxHeaders/elf32_arm_reloc_special.h0000644000000000000000000000013014542551763016414 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.02995375 30 ctime=1744351535.526908824 gcl-2.7.1/h/elf32_arm_reloc_special.h0000644000175000017500000000163314542551763016017 0ustar00cammcammstatic 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.7.1/h/PaxHeaders/cmpincl1.h0000644000000000000000000000013114542551763013465 xustar0030 mtime=1703597043.196022733 30 atime=1744340055.764934675 29 ctime=1744351535.52290886 gcl-2.7.1/h/cmpincl1.h0000755000175000017500000000050514542551763013067 0ustar00cammcamm#define CMPINCLUDE #include #define EXTER extern EXTER void * sLspecial; EXTER void * sLerror; EXTER void * sKformat_control; EXTER void * sKformat_arguments; EXTER void * sSmacro; EXTER void * keyword_package; EXTER void * sLtype_error; EXTER void * sLlist; EXTER void * sKdatum; EXTER void * sKexpected_type; gcl-2.7.1/h/PaxHeaders/cstack.h0000644000000000000000000000013214776006046013226 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.494909111 gcl-2.7.1/h/cstack.h0000644000175000017500000000265114776006046012630 0ustar00cammcamm#if SIZEOF_LONG == 4 #if defined(__PPC__) #define SET_STACK_POINTER "addi %%r1,%0,0\n\t" #elif defined(__m68k__) #define SET_STACK_POINTER "movel %0,%%sp\n\t" #elif defined(__i386__) #define SET_STACK_POINTER "mov %0,%%esp\n\t" #elif defined(__ILP32__) && defined(__x86_64__) #define SET_STACK_POINTER "mov %0,%%esp\n\t" #elif defined(__arm__) #define SET_STACK_POINTER "mov %%sp,%0\n\t" #elif defined(__hppa__) #define SET_STACK_POINTER "copy %0,%%sp\n\t" #elif defined(__SH4__) #define SET_STACK_POINTER "mov %0,r15\n\t" #endif #define FIXED_STACK (1UL<<23)/*FIXME configure?*/ #if defined(__SH4__)/*FIXME is this just due to qemu?*/ #define CTOP (void *)0x80000000 #define SS FIXED_STACK #elif defined(__gnu_hurd__) #define CTOP (void *)0xc0000000 #define SS FIXED_STACK #define MAP_GROWSDOWN 0 #define MAP_STACK 0 #else #define CTOP (void *)0xc0000000/*FIXME configure?*/ #define SS getpagesize() #endif #ifdef SET_STACK_POINTER { void *p,*p1,*b,*s; int a,f=MAP_FIXED|MAP_PRIVATE|MAP_ANON|MAP_STACK; p=alloca(1); p1=alloca(1); b=CTOP-(p1

CTOP || p < b) { if (mmap(b,SS,PROT_READ|PROT_WRITE|PROT_EXEC,f,-1,0)!=(void *)-1) { stack_map_base=b; asm volatile (SET_STACK_POINTER::"r" (s):"memory"); if (p1>p) mmap(CTOP,getpagesize(),PROT_NONE,f,-1,0);/*guard page*/ } } } #endif #endif gcl-2.7.1/h/PaxHeaders/elf64_mips_reloc.h0000644000000000000000000000013014542551763015112 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.02995375 30 ctime=1744351535.538908716 gcl-2.7.1/h/elf64_mips_reloc.h0000644000175000017500000000344714542551763014522 0ustar00cammcamm 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.7.1/h/PaxHeaders/loongarch64-linux.h0000644000000000000000000000013214776006046015241 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.558908537 gcl-2.7.1/h/loongarch64-linux.h0000644000175000017500000000053114776006046014636 0ustar00cammcamm#include "linux.h" #define SGC /* Apparently stack pointers can be 4 byte aligned, at least &argc -- CM */ #define C_GC_OFFSET 4 #define RELOC_H "elf64_loongarch64_reloc.h" #define SPECIAL_RELOC_H "elf64_loongarch64_reloc_special.h" /* #define MAX_CODE_ADDRESS (1L<<31)/\*large memory model broken gcc 4.8*\/ */ #define NEED_STACK_CHK_GUARD gcl-2.7.1/h/PaxHeaders/elf64_sparc_reloc.h0000644000000000000000000000012714542551763015260 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.02995375 29 ctime=1744351535.54290868 gcl-2.7.1/h/elf64_sparc_reloc.h0000644000175000017500000000122414542551763014651 0ustar00cammcamm 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.7.1/h/PaxHeaders/num_include.h0000644000000000000000000000013214555557372014270 xustar0030 mtime=1706483450.788392733 30 atime=1744339817.763431029 30 ctime=1744351535.502909039 gcl-2.7.1/h/num_include.h0000644000175000017500000000222314555557372013665 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.7.1/h/PaxHeaders/386-kfreebsd.h0000644000000000000000000000013214776006046014061 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.550908609 gcl-2.7.1/h/386-kfreebsd.h0000644000175000017500000000037114776006046013460 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/FreeBSD.h0000644000000000000000000000013214776006046013170 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.562908501 gcl-2.7.1/h/FreeBSD.h0000755000175000017500000000344014776006046012572 0ustar00cammcamm/* * 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 /* Begin for cmpinclude */ #define SGC /* can mprotect pages and so selective gc will work */ /* End for cmpinclude */ gcl-2.7.1/h/PaxHeaders/arm-linux.h0000644000000000000000000000013214776006046013672 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.554908573 gcl-2.7.1/h/arm-linux.h0000755000175000017500000000022714776006046013274 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/riscv64-linux.h0000644000000000000000000000013214776006046014413 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.546908644 gcl-2.7.1/h/riscv64-linux.h0000644000175000017500000000043114776006046014007 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/writable.h0000644000000000000000000000013214542551763013571 xustar0030 mtime=1703597043.212022758 30 atime=1744339817.295428108 30 ctime=1744351535.514908931 gcl-2.7.1/h/writable.h0000644000175000017500000000207014542551763013166 0ustar00cammcammEXTER 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.7.1/h/PaxHeaders/elf64_loongarch64_reloc.h0000644000000000000000000000013214645210066016262 xustar0030 mtime=1721045046.275539377 30 atime=1744294998.033953767 30 ctime=1744351535.534908752 gcl-2.7.1/h/elf64_loongarch64_reloc.h0000644000175000017500000000555314645210066015670 0ustar00cammcamm#define get_insn_page(x) ((x) & ~0xffful) #define get_page_delta(dest, pc) ({ \ ul res = get_insn_page(dest) - get_insn_page(pc); \ if ((dest) & 0x800) \ res += 0x1000ul - 0x100000000ul; \ if (res & 0x80000000) \ res += 0x100000000ul; \ res; \ }) #define get_page_low(dest) ((dest) & 0xfff) #define bdest (((long)((s+a)-p))>>2) #define bgdest (((long)(((ul)got)-p))>>2) case R_LARCH_RELAX: case R_LARCH_ALIGN: massert(!emsg("Unsupport relaxation, please compile with '-mno-relax -Wa,-mno-relax'\n")); break; case R_LARCH_64: store_val(where,~0L,(s+a)); break; case R_LARCH_32: store_val(where,MASK(32),(s+a)); break; case R_LARCH_32_PCREL: store_val(where,MASK(32),(s+a)-p); break; case R_LARCH_ADD6: add_val(where,MASK(6),(s+a)); break; case R_LARCH_ADD8: add_val(where,MASK(8),(s+a)); break; case R_LARCH_ADD16: add_val(where,MASK(16),(s+a)); break; case R_LARCH_ADD32: add_val(where,MASK(32),(s+a)); break; case R_LARCH_ADD64: add_val(where,~0L,(s+a)); break; case R_LARCH_SUB6: add_val(where,MASK(6),-(s+a)); break; case R_LARCH_SUB8: add_val(where,MASK(8),-(s+a)); break; case R_LARCH_SUB16: add_val(where,MASK(16),-(s+a)); break; case R_LARCH_SUB32: add_val(where,MASK(32),-(s+a)); break; case R_LARCH_SUB64: add_val(where,~0L,-(s+a)); break; case R_LARCH_B16: store_val(where,MASK(16)<<10,bdest<<10); break; case R_LARCH_B21: store_val(where,(MASK(16)<<10)|MASK(5),bdest<<10|((bdest>>16)&0x1f)); break; case R_LARCH_B26: { if ((bdest&(~MASK(25)))==0||((~bdest)&(~MASK(25)))==0) { store_val(where,MASK(26),bdest<<10|((bdest>>16)&0x3ff)); break; } if (!(sym->st_size&0x2)) massert(!emsg("Unresolved R_LARCH_B26 symbol\n")); got+=(sym->st_size>>2)+(sym->st_size&0x1?1:0); store_val(where,MASK(26),bgdest<<10|((bgdest>>16)&0x3ff)); memcpy(got,tramp,sizeof(tramp)); store_val(got,MASK(20)<<5,(get_insn_page(s+a)-get_insn_page((ul)got))>>12<<5); store_val((ul*)((ul)got+4),MASK(16)<<10,(((s+a)>>2)&0x3ff)<<10); } break; case R_LARCH_PCALA_HI20: store_val(where,MASK(20)<<5,get_page_delta(s+a,p)>>12<<5); break; case R_LARCH_PCALA_LO12: store_val(where,MASK(12)<<10,get_page_low(s+a)<<10); break; case R_LARCH_GOT_PC_HI20: got+=sym->st_size>>2; *got=s+a; store_val(where,MASK(20)<<5,get_page_delta((ul)got,p)>>12<<5); break; case R_LARCH_GOT_PC_LO12: got+=sym->st_size>>2; // *got=s+a; store_val(where,MASK(12)<<10,get_page_low((ul)got)<<10); break; gcl-2.7.1/h/PaxHeaders/immnum.h0000644000000000000000000000013214542551763013262 xustar0030 mtime=1703597043.204022746 30 atime=1744339813.027401486 30 ctime=1744351535.498909075 gcl-2.7.1/h/immnum.h0000644000175000017500000002416514542551763012670 0ustar00cammcamm#ifndef IMMNUM_H #define IMMNUM_H #include "fixnum.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)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)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*/ long int labs(long int j); 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,0),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,0),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,0),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,0,&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,0,&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<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.7.1/h/PaxHeaders/fixnum.h0000644000000000000000000000013214575160702013261 xustar0030 mtime=1710547394.279799081 30 atime=1744339813.027401486 30 ctime=1744351535.494909111 gcl-2.7.1/h/fixnum.h0000644000175000017500000000530514575160702012662 0ustar00cammcamm#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_) ({if (is_unmrkd_imm_fixnum(a_)) (a_)=((object)((fixnum)(a_)+(LOW_IM_FIX<<1)));}) #define unmark_imm_fixnum(a_) ({if (is_marked_imm_fixnum(a_)) (a_)=((object)((fixnum)(a_)-(LOW_IM_FIX<<1)));}) #define is_imm_fixnum(a_) ((fixnum)(a_)>=-LOW_IM_FIX && ((fixnum)(a_)<(fixnum)OBJNULL))/* (labs((fixnum)(a_))<=(fixnum)OBJNULL) */ #define is_unmrkd_imm_fixnum(a_) is_imm_fix(a_)/* (labs((fixnum)(a_))<=LOW_IM_FIX) */ #define is_marked_imm_fixnum(a_) ((fixnum)(a_)>=LOW_IM_FIX && ((fixnum)(a_)<(fixnum)OBJNULL))/* (is_imm_fixnum(a_)&&!is_unmrkd_imm_fixnum(a_)) */ #define is_imm_fix(a_) INT_IN_BITS(a_,LOW_SHFT-1) #elif defined (IM_FIX_BASE) && defined(IM_FIX_LIM) #define make_imm_fixnum(a_) ((object)((a_)+(IM_FIX_BASE+(IM_FIX_LIM>>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 _q3;\ _q3=is_imm_fix(_q1) ? make_imm_fixnum(_q1) : make_fixnum1(_q1);_q3;}) #define CMPmake_fixnum(a_) make_fixnum(a_)/*FIXME*/ #define fix(a_) ({register object _q2=(a_);register fixnum _q4;\ _q4=is_imm_fixnum(_q2) ? fix_imm_fixnum(_q2) : (_q2)->FIX.FIXVAL;_q4;}) #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.7.1/h/PaxHeaders/ia64-linux.h0000644000000000000000000000013214776006046013656 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.554908573 gcl-2.7.1/h/ia64-linux.h0000755000175000017500000000030114776006046013251 0ustar00cammcamm#include "linux.h" /* #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.7.1/h/PaxHeaders/elf32_armhf_reloc_special.h0000644000000000000000000000013114542551763016733 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.053953855 30 ctime=1744351535.526908824 gcl-2.7.1/h/elf32_armhf_reloc_special.h0000644000175000017500000000366214542551763016341 0ustar00cammcammstatic 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.7.1/h/PaxHeaders/elf64_i386_reloc.h0000644000000000000000000000013114542551763014634 xustar0029 mtime=1703597043.20002274 30 atime=1744339829.847506484 30 ctime=1744351535.534908752 gcl-2.7.1/h/elf64_i386_reloc.h0000644000175000017500000000053614542551763014237 0ustar00cammcamm 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.7.1/h/PaxHeaders/type.h0000644000000000000000000000013014575160702012732 xustar0028 mtime=1710547394.2837991 30 atime=1744339801.619330396 30 ctime=1744351535.510908967 gcl-2.7.1/h/type.h0000644000175000017500000001415414575160702012337 0ustar00cammcammenum type { t_cons, t_start = 0, t_fixnum, t_bignum, t_ratio, t_shortfloat, t_longfloat, t_complex, t_pathname, t_string, t_simple_string, t_simple_bitvector, t_bitvector, t_simple_vector, t_vector, t_simple_array, t_array, t_hashtable, t_structure, t_character, t_symbol, t_package, t_stream, t_random, t_readtable, t_function, t_cfdata, t_spice, t_contiguous, t_end=t_contiguous, t_relocatable, t_other }; #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_)->d.h=(fixnum)OBJNULL ? 1 : 0;}) #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 #define set_type_of(x,y) ({object _x=(object)(x);enum type _y=(y);_x->d.f=0;\ if (TYPEWORD_TYPE_P(_y)) {_x->d.e=1;_x->d.t=_y;_x->d.h=(fixnum)OBJNULL ? 1 : 0;}}) #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_tp(a_) TS_MEMBER(a_,TS(t_string)|TS(t_simple_string)) #define stringp(a_) stringp_tp(type_of(a_)) #define fixnump(a_) SPP(a_,fixnum) #define readtablep(a_) SPP(a_,readtable) #define functionp(a_) (type_of(a_)==t_function) #define compiled_functionp(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_); stringp_tp(_tp) || _tp == t_symbol;}) #define pathname_string_symbolp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || stringp_tp(_tp) \ || _tp == t_symbol;}) #define pathname_string_symbol_streamp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || stringp_tp(_tp) \ || _tp == t_symbol || _tp==t_stream;}) /* #define eql_is_eq(a_) (is_imm_fixnum(a_) || ({enum type _tp=type_of(a_); _tp == t_cons || _tp > t_complex;})) */ #define eql_is_eq(a_) (is_imm_fixnum(a_)||valid_cdr(a_)||(a_->d.t>t_complex)) #define equal_is_eq(a_) (is_imm_fixnum(a_) || type_of(a_)>t_bitvector) #define equalp_is_eq(a_) (type_of(a_)>t_structure) #define tp0(x) is_imm_fixnum(x)/*(((ufixnum)x)>=IM_FIX_BASE)*/ #define tp1(x) (x==Cnil) #define tp2(x) ({object _x=x;is_imm_fixnum(_x) ? 2 : _x->d.e && !is_imm_fixnum(_x->ff.ff);})/*(((ufixnum)_x)>=IM_FIX_BASE)*/ #define tp3(x) ({object _x=x;_x==Cnil ? 2 : (is_imm_fixnum(_x) ? 3 : _x->d.e && !is_imm_fixnum(_x->ff.ff));}) #define tp4(x) ({object _x=x;is_imm_fixnum(_x) ? -1 : _x->d.e && !is_imm_fixnum(_x->ff.ff) ? _x->d.t : 0;}) #define tp5(x) ({object _x=x;_x==Cnil ? -2 : (is_imm_fixnum(_x) ? -1 : (_x->d.e && !is_imm_fixnum(_x->ff.ff) ? _x->d.t : 0));}) #define tp6(x) ({object _x=x;is_imm_fixnum(_x) ? -1 : (_x->d.e && !is_imm_fixnum(_x->ff.ff) ? _x->fstp.tp : 0);}) #define tp7(x) ({object _x=x;_x==Cnil ? -2 : \ (is_imm_fixnum(_x) ? -1 : \ (_x->d.e && !is_imm_fixnum(_x->ff.ff) ? _x->fstp.tp : 0));}) #define tp8(x) ({object _x=x;(is_imm_fixnum(_x) ? 0 : \ (_x->d.e && !is_imm_fixnum(_x->ff.ff) ? \ (_x->d.td.t : \ (_x->d.t==t_complex&&x->d.tt<4 ? x->d.t : \ (_x->d.t==t_complex ? x->d.t+x->d.tt-3 : \ 0))) : 0));})/*FIXME*/ gcl-2.7.1/h/PaxHeaders/elf64_ppc_reloc_special.h0000644000000000000000000000013014542551763016424 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.053953855 29 ctime=1744351535.54290868 gcl-2.7.1/h/elf64_ppc_reloc_special.h0000644000175000017500000000376214542551763016034 0ustar00cammcammstatic 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.7.1/h/PaxHeaders/armhf-linux.h0000644000000000000000000000013214776006046014210 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.554908573 gcl-2.7.1/h/armhf-linux.h0000644000175000017500000000023314776006046013604 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/powerpc-linux.h0000644000000000000000000000013214776006046014572 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.558908537 gcl-2.7.1/h/powerpc-linux.h0000644000175000017500000000143514776006046014173 0ustar00cammcamm#include "linux.h" #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 */ #define HAVE_ELF /* Seeking to the end of ELF data is a little messy... */ #include #define SEEK_TO_END_OFILE(fp) seek_to_end_ofile(fp) #define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr #define MPROTECT_ACTION_FLAGS SA_RESTART | SA_ONSTACK | SA_SIGINFO #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) #undef SETUP_SIG_STACK /* #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 HAVE_SIGPROCMASK #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) #define CLEANUP_CODE \ setbuf(stdin,0); \ setbuf(stdout,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((fixnum)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) #define FPE_SET_CTXT_ADDR(c_,a_) ({void *_c=(c_);fixnum _a=fix(a_);(UC(_c)->uc_mcontext.gregs[REG_EIP]=(_a));}) #define FPE_CLR_CTXT_CWD(c_) ({void *_c=(c_);UC(_c)->uc_mcontext.fpregs->cw|=FE_ALL_EXCEPT;((struct _fpstate *)UC(c_)->uc_mcontext.fpregs)->mxcsr|=(FE_ALL_EXCEPT<<7);}) #else #define FPE_CODE(i_,v_) make_fixnum((fixnum)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) #define FPE_SET_CTXT_ADDR(c_,a_) ({void *_c=(c_);fixnum _a=fix(a_);(UC(_c)->uc_mcontext.gregs[REG_RIP]=(_a));}) #define FPE_CLR_CTXT_CWD(c_) ({void *_c=(c_);UC(_c)->uc_mcontext.fpregs->cwd|=FE_ALL_EXCEPT;UC(_c)->uc_mcontext.fpregs->mxcsr|=(FE_ALL_EXCEPT<<7);}) #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_TCODE(x_) \ {ufixnum _x=(x_),_y=0; \ switch(_x) { \ case FPE_FLTINV: _y=FE_INVALID;break; \ case FPE_FLTDIV: _y=FE_DIVBYZERO;break; \ case FPE_FLTOVF: _y=FE_OVERFLOW;break; \ case FPE_FLTUND: _y=FE_UNDERFLOW;break; \ case FPE_FLTRES: _y=FE_INEXACT;break; \ } \ _y; \ } #define FPE_CODE(i_,v_) make_fixnum(FPE_TCODE((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 #undef sbrk #define sbrk msbrk #define INITIALIZE_BRK msbrk_init(); gcl-2.7.1/h/PaxHeaders/bfdef.h0000644000000000000000000000013214542551763013026 xustar0030 mtime=1703597043.196022733 30 atime=1744339820.739449601 30 ctime=1744351535.518908896 gcl-2.7.1/h/bfdef.h0000644000175000017500000002032614542551763012427 0ustar00cammcamm#include "compbas2.h" #include "funlink.h" extern object sLvalues,sLinteger,sLfixnum,big_fixnum1,big_fixnum2,big_fixnum3,big_fixnum4,big_fixnum5; #define ENSURE_MP(a_,b_) \ if (type_of(a_)==t_fixnum) {\ mpz_set_si(MP(Join(big_fixnum,b_)),fix(a_));\ a_=Join(big_fixnum,b_);\ } #define K_bbb_b OO #define K_bbb_f OI #define K_bb_b OO #define K_bb_f OI #define K_fb_b IO #define K_fb_f II #define K_fbb_b IO #define K_fbb_f II #define K_m_b OO #define K_m_f OI #define K_b_b OO #define K_f_b IO #define K_b_f OI #define K_f_f II #define KK1(a_,b_) Join(K_,Join(a_,Join(_,b_))) #define Q11(a_,b_) KK1(a_,b_) #define Q21(a_,b_) OO #define Q31(a_,b_) OO #define Q41(a_,b_) OO #define Q12(a_,b_,c_) KK1(a_,b_) #define Q22(a_,b_,c_) KK1(c_,b) #define Q32(a_,b_,c_) OO #define Q42(a_,b_,c_) OO #define Q13(a_,b_,c_,d_) KK1(a_,b_) #define Q23(a_,b_,c_,d_) KK1(c_,d_) #define Q33(a_,b_,c_,d_) OO #define Q43(a_,b_,c_,d_) OO #define Q14(a_,b_,c_,d_,e_) KK1(a_,b_) #define Q24(a_,b_,c_,d_,e_) KK1(c_,d_) #define Q34(a_,b_,c_,d_,e_) KK1(e_,b) #define Q44(a_,b_,c_,d_,e_) OO #define Q15(a_,b_,c_,d_,e_,f_) KK1(a_,b_) #define Q25(a_,b_,c_,d_,e_,f_) KK1(c_,d_) #define Q35(a_,b_,c_,d_,e_,f_) KK1(e_,f_) #define Q45(a_,b_,c_,d_,e_,f_) OO /* #define QR11(a_,b_) KK1(a_,b_) */ /* #define QR21(a_,b_) OO */ /* #define QR31(a_,b_) OO */ /* #define QR41(a_,b_) OO */ /* #define QR12(a_,b_,c_) KK1(a_,b_) */ /* #define QR22(a_,b_,c_) KK1(c_,b) */ /* #define QR32(a_,b_,c_) OO */ /* #define QR42(a_,b_,c_) OO */ /* #define QR13(a_,b_,c_,d_) KK1(a_,b_) */ /* #define QR23(a_,b_,c_,d_) KK1(c_,d_) */ /* #define QR33(a_,b_,c_,d_) OO */ /* #define QR43(a_,b_,c_,d_) OO */ /* #define QR14(a_,b_,c_,d_,e_) KK1(a_,b_) */ /* #define QR24(a_,b_,c_,d_,e_) KK1(c_,d_) */ /* #define QR34(a_,b_,c_,d_,e_) KK1(e_,b) */ /* #define QR44(a_,b_,c_,d_,e_) OO */ /* #define QR_fb(a_...) fb,b,a_ */ /* #define QR_fbb(a_...) fbb,b,b,a_ */ /* #define QR_bb(a_...) bb,b,b,a_ */ /* #define QR_bbb(a_...) bbb,b,b,b,a_ */ /* #define QR_m(a_...) m,b,b,a_ */ /* #define QR_b(a_...) b,b,a_ */ /* #define QR_f(a_...) f,a_ */ /* #define QR(r_,a_...) Join(QR_,r_)(a_) */ /* #define QRR(e_,n_,a_...) Join(Join(Q,e_),n_)(a_) */ #define D_fb fixnum #define D_fbb fixnum #define D_bb object #define D_bbb object #define D_m object #define D_b object #define D_f fixnum #define D0(a_) Join(D_,a_) #define D1(a_) D0(a_) x #define D2(a_,b_) D1(a_),D0(b_) y #define D3(a_,b_,c_) D2(a_,b_),D0(c_) z #define D4(a_,b_,c_,d_) D3(a_,b_,c_),D0(d_) w #define R1(a_) object /*D0(a_)*/ #define EE(a_,b_) #define E_b ENSURE_MP #define E_f EE #define E1(a_) Join(E_,a_)(x,1); #define E2(a_,b_) E1(a_) Join(E_,b_)(y,2) #define E3(a_,b_,c_) E2(a_,b_) Join(E_,c_)(z,3) #define E4(a_,b_,c_,d_) E3(a_,b_,c_) Join(E_,d_)(w,4) /* #define AA_m object *vals=(object *)fcall.valp,*base=vs_top,u=new_bignum(),v=new_bignum() */ /* #define AA_b object u=new_bignum() */ #define AA_bbb object *vals=(object *)fcall.valp,*base=vs_top,u=big_fixnum3,v=big_fixnum4,v2=big_fixnum5 #define AA_bb object *vals=(object *)fcall.valp,*base=vs_top,u=big_fixnum4,v=big_fixnum5 #define AA_fb fixnum u;object *vals=(object *)fcall.valp,*base=vs_top,v=big_fixnum4 #define AA_fbb fixnum u;object *vals=(object *)fcall.valp,*base=vs_top,v=big_fixnum4,v2=big_fixnum5 #define AA_m object *vals=(object *)fcall.valp,*base=vs_top,u=big_fixnum4,v=big_fixnum5 #define AA_b object u=big_fixnum4 #define AA_f fixnum u #define AA1(a_) Join(AA_,a_) /* #define AAR_bbb */ /* #define AAR_bb */ /* #define AAR_fb fixnum u */ /* #define AAR_fbb fixnum u */ /* #define AAR_m */ /* #define AAR_b */ /* #define AAR_f fixnum u */ /* #define AAR1(a_) Join(AAR_,a_) */ /* #define CR_b */ /* #define CR_f */ /* #define CR1(a_) Join(CR_,a_)(x) */ /* #define CR2(a_,b_) CR1(a_),Join(CR_,b_)(y) */ /* #define CR3(a_,b_,c_) CR2(a_,b_),Join(CR_,c_)(z) */ /* #define CR4(a_,b_,c_,d_) CR3(a_,b_,c_),Join(CR_,d_)(w) */ #define C_b MP #define C_f #define C1(a_) Join(C_,a_)(x) #define C2(a_,b_) C1(a_),Join(C_,b_)(y) #define C3(a_,b_,c_) C2(a_,b_),Join(C_,c_)(z) #define C4(a_,b_,c_,d_) C3(a_,b_,c_),Join(C_,d_)(w) #define CC_bbb MP(u),MP(v),MP(v2), #define CC_bb MP(u),MP(v), #define CC_fb MP(v), #define CC_fbb MP(v),MP(v2), #define CC_m MP(u),MP(v), #define CC_b MP(u), #define CC_f #define CC1(r_) Join(CC_,r_) /* #define CCR_bbb u,v,v2, */ /* #define CCR_bb u,v, */ /* #define CCR_fb v, */ /* #define CCR_fbb v,v, */ /* #define CCR_m u,v, */ /* #define CCR_b u, */ /* #define CCR_f */ /* #define CCR1(r_) Join(CCR_,r_) */ /* #define DR_bbb object u,object v,object v2, */ /* #define DR_bb object u,object v, */ /* #define DR_fb object v, */ /* #define DR_fbb object v,object v2, */ /* #define DR_m object u,object v, */ /* #define DR_b object u, */ /* #define DR_f */ /* #define DR1(r_) Join(DR_,r_) */ #define W_bbb #define W_bb #define W_fb u= #define W_fbb u= #define W_m #define W_b #define W_f u= /* #define WR_bbb */ /* #define WR_bb */ /* #define WR_fb fixnum u= */ /* #define WR_fbb fixnum u= */ /* #define WR_m */ /* #define WR_b */ /* #define WR_f fixnum u= */ /* #define Z_m normalize_big(u),normalize_big(v) */ /* #define Z_b normalize_big(u) */ #define Z_bbb maybe_replace_big(u),maybe_replace_big(v),maybe_replace_big(v2) #define Z_bb maybe_replace_big(u),maybe_replace_big(v) #define Z_fb (object)u,maybe_replace_big(v) #define Z_fbb (object)u,maybe_replace_big(v),maybe_replace_big(v2) #define Z_m maybe_replace_big(u),maybe_replace_big(v) #define Z_b maybe_replace_big(u) #define Z_f (object)u #define PT_bb MMcons(sLvalues,MMcons(sLinteger,MMcons(sLinteger,Cnil))) #define PT_fb MMcons(sLvalues,MMcons(sLfixnum,MMcons(sLinteger,Cnil))) #define PT_fbb MMcons(sLvalues,MMcons(sLfixnum,MMcons(sLinteger,MMcons(sLinteger,Cnil)))) #define PT_bbb MMcons(sLvalues,MMcons(sLinteger,MMcons(sLinteger,MMcons(sLinteger,Cnil)))) #define PT_m MMcons(sLvalues,MMcons(sLinteger,MMcons(sLinteger,Cnil))) #define PT_b sLinteger #define PT_f sLfixnum #define PT(a_) Join(PT_,a_) #define PT1(a_) MMcons(Join(PT_,a_),Cnil) #define PT2(a_,b_) MMcons(PT1(a_),PT1(b_)) #define PT3(a_,b_,c_) MMcons(PT1(a_),PT2(b_,c_)) #define PT4(a_,b_,c_,d_) MMcons(PT1(a_),PT3(b_,c_,d_)) /* #define PTR_bb sLinteger */ /* #define PTR_fb sLfixnum */ /* #define PTR_fbb sLfixnum */ /* #define PTR_bbb sLinteger */ /* #define PTR_m sLinteger */ /* #define PTR_b sLinteger */ /* #define PTR_f sLfixnum */ /* #define PTR(a_) Join(PTR_,a_) */ /* #define PTR1(a_) MMcons(Join(PTR_,a_),Cnil) */ /* #define PTR2(a_,b_) MMcons(PTR1(a_),PTR1(b_)) */ /* #define PTR3(a_,b_,c_) MMcons(PTR1(a_),PTR2(b_,c_)) */ /* #define PTR4(a_,b_,c_,d_) MMcons(PTR1(a_),PTR3(b_,c_,d_)) */ #define HH_bbb(a_...) RETURN3(a_) #define HH_bb(a_...) RETURN2(a_) #define HH_fb(a_...) RETURN2(a_) #define HH_fbb(a_...) RETURN3(a_) #define HH_m(a_...) RETURN2(a_) #define HH_b(a_...) RETURN1(a_) #define HH_f(a_...) RETURN1(a_) /* #define BF1(n_,b_,r_,a_...) \ */ /* DEFUNB("mpz_" #b_,R1(r_),Join(fSmpz_,b_), \ */ /* GMP,n_,n_,NONE,Join(Q1,n_)(r_,a_),Join(Q2,n_)(r_,a_),Join(Q3,n_)(r_,a_),Join(Q4,n_)(r_,a_), \ */ /* (Join(D,n_)(a_)),PT(r_),"") { \ */ /* \ */ /* AA1(r_); \ */ /* \ */ /* Join(E,n_)(a_); \ */ /* Join(W_,r_) Join(fSmmpz_,b_)(CCR1(r_)Join(CR,n_)(a_)); \ */ /* Join(HH_,r_)(Join(Z_,r_)); \ */ /* \ */ /* } */ /* Do not expose big_fixnum registers at lisp level, as typing is undefined */ /* #define BF(n_,m_,s_,b_,r_,a_...) \ */ /* DEFUNB("mmpz_" #b_,R1(r_),Join(fSmmpz_,b_), \ */ /* GMP,n_,n_,NONE, \ */ /* QRR(1,n_,QR(r_,a_)),QRR(2,n_,QR(r_,a_)), \ */ /* QRR(3,n_,QR(r_,a_)),QRR(4,n_,QR(r_,a_)), \ */ /* (DR1(r_)Join(D,m_)(a_)),PTR(r_),"") { \ */ /* \ */ /* Join(WR_,r_) Join(m__gmpz_,b_)(CC1(r_)Join(C,m_)(a_)); \ */ /* RETURN1(u); \ */ /* \ */ /* } \ */ /* BF1(m_,b_,r_,a_); */ #define BF(n0_,n_,s_,b_,r_,a_...) \ DEFUNB("mpz_" #b_,R1(r_),Join(fSmpz_,b_), \ GMP,n_,n_,NONE,Join(Q1,n_)(r_,a_),Join(Q2,n_)(r_,a_),Join(Q3,n_)(r_,a_),Join(Q4,n_)(r_,a_), \ (Join(D,n_)(a_)),PT(r_),"") { \ \ AA1(r_); \ \ Join(E,n_)(a_); \ Join(W_,r_) Join(m__gmpz_,b_)(CC1(r_)Join(C,n_)(a_)); \ Join(HH_,r_)(Join(Z_,r_)); \ \ } gcl-2.7.1/h/PaxHeaders/sfun_argd.h0000644000000000000000000000013114542551763013727 xustar0030 mtime=1703597043.208022752 29 atime=1744339813.08740186 30 ctime=1744351535.510908967 gcl-2.7.1/h/sfun_argd.h0000755000175000017500000000153214542551763013332 0ustar00cammcamm#define VFUN_NARG_BIT (1 <<11) #define MVRET_BIT (1 <<10) #define SFUN_RETURN_MASK 0x300 #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.7.1/h/PaxHeaders/prelink.h0000644000000000000000000000013214542551763013424 xustar0030 mtime=1703597043.208022752 30 atime=1744339813.023401461 30 ctime=1744351535.506909003 gcl-2.7.1/h/prelink.h0000644000175000017500000000207314542551763013024 0ustar00cammcamm/* 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.7.1/h/PaxHeaders/object.h0000644000000000000000000000013014733440601013212 xustar0029 mtime=1735278977.03864999 29 atime=1744339801.65533062 30 ctime=1744351535.502909039 gcl-2.7.1/h/object.h0000644000175000017500000006201214733440601012613 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 NOT_OBJECT_ALIGNED(a_) ({union lispunion _t={.vw=(void *)(a_)};_t.td.emf;}) #define ROUNDUP(x_,y_) (((unsigned long)(x_)+(y_ -1)) & ~(y_ -1))/*FIXME double eval*/ #define ROUNDDN(x_,y_) (((unsigned long)(x_)) & ~(y_ -1)) #undef PAGESIZE #define PAGESIZE (1L << PAGEWIDTH) /* page size in bytes */ #ifndef plong #define plong long #endif union int_object { object o; fixnum i; }; typedef union int_object iobject; /* union int_object {object *o; fixnum i;}; */ #define CHCODELIM 256 /* character code limit */ /* ASCII character set */ #define RTABSIZE CHCODELIM /* read table size */ /* #define eql_is_eq(a_) (is_imm_fixnum(a_) || ({enum type _tp=type_of(a_); _tp == t_cons || _tp > t_complex;})) */ /* #define equal_is_eq(a_) (is_imm_fixnum(a_) || type_of(a_)>t_bitvector) */ #define Msf(obje) (obje)->SF.SFVAL #define sf(x) Msf(x) #define sfc(x) ({object _x=x;sf(_x->cmp.cmp_real)+I*sf(_x->cmp.cmp_imag);}) #define Mlf(obje) (obje)->LF.LFVAL #define lf(x) Mlf(x) #define lfc(x) ({object _x=x;lf(_x->cmp.cmp_real)+I*lf(_x->cmp.cmp_imag);}) /* EXTER struct character character_table1[256+128] OBJ_ALIGN; /\*FIXME, sync with char code constants above.*\/ */ /* #define character_table (character_table1+128) */ #define code_char(c) (object)(character_table+((unsigned char)(c))) #define char_code(obje) (obje)->ch.ch_code #define char_font(obje) (obje)->ch.ch_font #define char_bits(obje) (obje)->ch.ch_bits enum stype { /* symbol type */ stp_ordinary, /* ordinary */ stp_constant, /* constant */ stp_special /* special */ }; /* #define s_fillp st_fillp */ /* #define s_self st_self */ #define NOT_OBJECT_ALIGNED(a_) ({union lispunion _t={.vw=(void *)(a_)};_t.td.emf;}) #define Cnil ((object)&Cnil_body) #define Ct ((object)&Ct_body) #define sLnil Cnil #define sLt Ct #define NOT_SPECIAL (fixnum)Cnil /* 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 */ }; /* struct htent { /\* hash table entry *\/ */ /* object hte_key; /\* key *\/ */ /* object hte_value; /\* value *\/ */ /* }; */ typedef struct { void *dflt; object *namep; unsigned char size; } aet_type_struct; #define USHORT_GCL(x,i) (((unsigned short *)(x)->ust.ust_self)[i]) #define SHORT_GCL(x,i) ((( short *)(x)->ust.ust_self)[i]) #define UINT_GCL(x,i) (((unsigned int *)(x)->ust.ust_self)[i]) #define INT_GCL(x,i) ((( int *)(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 : 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 : 0)) 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; }; #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)))) /* 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 ((x)->d.m) system_error(); (x)->d.m=0 */ #else #define SGC_TOUCH(x) #endif #define STSET(type,x,i,val) do{SGC_TOUCH(x);STREF(type,x,i) = (val);} while(0) enum smmode { /* stream mode */ smm_input, /* input */ smm_output, /* output */ smm_io, /* input-output */ smm_probe, /* probe */ smm_file_synonym, /* synonym to file stream */ 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 */ }; /* 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 *\/ */ /* }; */ enum chatrait { /* character attribute */ trait_alpha, /* alphabetic */ trait_digit, /* digits */ trait_alphadigit, /* alpha/digit */ trait_package, /* package mrk */ trait_plus, /* plus sign */ trait_minus, /* minus sign */ trait_ratio, /* ratio mrk */ trait_exp, /* expon mrk */ trait_invalid /* unreadable */ }; struct rtent { /* read table entry */ enum chattrib rte_chattrib; /* character attribute */ enum chatrait rte_chatrait; /* constituent trait */ object rte_macro; /* macro function */ object *rte_dtab; /* pointer to the */ /* dispatch table */ /* NULL for */ /* non-dispatching */ /* macro character, or */ /* non-macro character */ }; EXTER object def_env1[2],*def_env; EXTER object src_env1[2],*src_env; #define address_int ufixnum /* 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;}) 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 */ }; #define FREE (-1) /* free object */ /* 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; enum type tm_calling_type; /* calling type */ }; /* The table of type managers. */ EXTER struct typemanager tm_table[ 32 /* (int) t_relocatable */]; #define tm_of(t) ({struct typemanager *_tm=tm_table+tm_table[t].tm_type;_tm->tm_calling_type=t;_tm;}) /* Contiguous block header. */ EXTER bool prefer_low_mem_contblock; struct contblock { /* contiguous block header */ fixnum 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. */ EXTER fixnum ncb; /* number of contblocks */ #define ncbpage tm_table[t_contiguous].tm_npage #define maxcbpage tm_table[t_contiguous].tm_maxpage #define maxrbpage tm_table[t_relocatable].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 fixnum new_holepage,starting_hole_div,starting_relb_heap_mult; EXTER ulfixnum cumulative_allocation,recent_allocation; EXTER ufixnum wait_on_abort; EXTER double gc_alloc_min,mem_multiple,gc_page_min,gc_page_max; EXTER char *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 */ EXTER char *rb_start1; /* relblock start in copy space */ EXTER char *rb_pointer1; /* relblock pointer in copy space */ #include #include #include #ifndef INLINE #define INLINE #endif 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; } INLINE int oemsg(int fd,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(fd,v,n-1) ? n : -1; } #define omsg(a_...) oemsg(1,a_) #define emsg(a_...) oemsg(2,a_) 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}; EXTER char *alloca_val; #define ALLOCA_CONS_ALIGN(n) ({alloca_val=ZALLOCA((n)*sizeof(struct cons)+sizeof(alloca_val));if (((unsigned long)alloca_val)&sizeof(alloca_val)) alloca_val+=sizeof(alloca_val);alloca_val;}) #define ON_STACK_CONS(x,y) (ALLOCA_CONS_ALIGN(1), on_stack_cons(x,y)) /*FIXME -- this is an effort to minimize uninitialized garbage in the stack. THe only comprehensive solution appears to be to wipe the stack frame on each function call. Doubling the overhead of every function call appears too expensive, though it has not been thoroughly tested. It is also quesitonable how portable the wipe_stack algorithm is. For now, we've minimized the issue by moving the cstack mark origin to the frame right above toplevel. 20050609 CM. */ /* #include */ #define CSP (CSTACK_ALIGNMENT-1) #if CSTACK_DIRECTION == -1 #define ZALLOCA(n) ({fixnum _x=0,_y=0,_n=((n)+CSP)&~CSP;void *v=NULL;v=alloca(_n+_x+_y);bzero(v,_n+_x+_y); v;}) #else #define ZALLOCA(n) ({fixnum _x=0,_y=0,_n=((n)+CSP)&~CSP;void *v=NULL;v=alloca(_n+_x+_y);bzero(v,_n+_x+_y); v;}) #endif /* #define ZALLOCA(n) ({fixnum _x=0,_y=0,_n=((n)+CSP)&~CSP;void *v=NULL;v=alloca(_n+_x+_y);wipe_stack(v+_n); v;}) */ /* #else */ /* #define ZALLOCA(n) ({fixnum _x=0,_y=0,_n=((n)+CSP)&~CSP;void *v=NULL;v=alloca(_n+_x+_y);wipe_stack(v); v;}) */ /* #endif */ #define ZALLOCA1(v,n) ((v)=alloca((n)),__builtin_bzero((v),((n)))) #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 FUN_VALP fcall.valp #define RETURN4(x,y,z,w) RETURN(3,object,x,(RV(y),RV(z),RV(w))) #define RETURN3(x,y,z) RETURN(3,object,x,(RV(y),RV(z))) #define RETURN2(x,y) RETURN(2,object,x,(RV(y))) #define RETURN3I(x,y,z) RETURN(3,fixnum,x,(RV(y),RV(z))) #define RETURN2I(x,y) RETURN(2,fixnum,x,(RV(y))) /* #define RETURN1(x) RETURN(1,object,x,) */ #define RETURN1(x) return(x) #define RETURN0 do {vs_top=vals ? (object *)vals-1 : base;return Cnil;} while (0) #define RV(x) ({if (_p) *_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=(object *)vals; listvals; vs_top=_p ? _p : base; return _val1;} while(0) /* #define CALL(n,form) (VFUN_NARGS=n,form) */ EXTER object sSlambda_block_expanded; # ifdef __GNUC__ # define assert(ex)\ {if (!(ex)){(void)fprintf(stderr, \ "Assertion failed: file \"%s\", line %d\n", __FILE__, __LINE__);gcl_abort();}} # else # define assert(ex) # endif #ifndef CHECK_INTERRUPT # define CHECK_INTERRUPT if (signals_pending) raise_pending_signals(sig_safe) #endif #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*/gcl_abort(); \ raise_pending_signals(sig_safe)}while(0) EXTER unsigned plong signals_allowed, signals_pending; #define endp(a) (consp(a) ? FALSE : ((a)==Cnil ? TRUE : ({TYPE_ERROR((a),sLlist);FALSE;}))) extern void *stack_alloc_start,*stack_alloc_end; #define stack_alloc_on(n_) ({void *_v=alloca(n_*PAGESIZE+OBJ_ALIGNMENT-1);\ if (_v) {\ stack_alloc_start=(void *)ROUNDUP(_v,OBJ_ALIGNMENT);\ memset(_v,0,stack_alloc_start-_v);\ _v+=n_*PAGESIZE+OBJ_ALIGNMENT-1;\ stack_alloc_end=(void *)ROUNDDN(_v,OBJ_ALIGNMENT);\ memset(stack_alloc_end,0,_v-stack_alloc_end);\ };\ }) #define stack_alloc_off() ({stack_alloc_start=stack_alloc_end=NULL;}) #define maybe_alloc_on_stack(n_,t_) ({void *_v=OBJNULL;\ if (stack_alloc_start) {\ unsigned _n=ROUNDUP(n_,OBJ_ALIGNMENT);\ if (stack_alloc_end-stack_alloc_start>_n) {\ _v=stack_alloc_start;\ stack_alloc_start+=_n;\ if (t_>=0) set_type_of(_v,t_);\ } else stack_alloc_off();\ }\ _v;}) #define stack_pages_left ({fixnum _val;int _w;\ _val=cs_limit-&_w;\ _val=_val<0 ? -_val : _val;\ _val=(_val>>PAGEWIDTH);}) #define myfork() ({int _p[2],_j=0;pid_t _pid;\ pipe(_p);\ _pid=fork();\ if (!_pid) { \ object _x=sSAchild_stack_allocA->s.s_dbind;\ enum type _tp=type_of(_x);\ float _fac= _tp==t_shortfloat ? sf(_x) : (_tp==t_longfloat ? lf(_x) : 0.8);\ fixnum _n=_fac*stack_pages_left;\ if (_n>0) stack_alloc_on(_n);\ close(0);close(1);close(2);\ _j=1;\ } \ close(_p[1-_j]);\ make_cons(make_fixnum(_pid),make_fixnum(_p[_j]));}) #define make_fd_stream(fd_,mode_,st_,buf_) ({object _x=alloc_object(t_stream);\ _x->sm.sm_mode=mode_;\ _x->sm.sm_fp=fdopen(fd_,st_);\ _x->sm.sm_buffer=buf_;\ setbuf(_x->sm.sm_fp,_x->sm.sm_buffer);\ _x->sm.sm_object0=sLcharacter;\ _x->sm.sm_object1=Cnil;\ _x->sm.sm_fd=fd_;\ _x;}) #define writable_ptr(a_) (((unsigned long)(a_)>=(unsigned long)data_start && (void *)(a_)<(void *)heap_end) || is_imm_fixnum(a_)) #define write_pointer_object(a_,b_) fSwrite_pointer_object(a_,b_) #define read_pointer_object(a_) fSread_pointer_object(a_) #define fixnum_float_contagion(a_,b_) \ ({register object _a=(a_),_x=_a,_b=(b_);\ register enum type _ta=type_of(_a),_tb=type_of(_b);\ if (_ta!=_tb)\ switch(_ta) {\ case t_shortfloat: if (_tb==t_longfloat) _x=make_longfloat(sf(_a)); break;\ case t_fixnum: \ switch(_tb) {\ case t_longfloat: _x=make_longfloat (fix(_a));break;\ case t_shortfloat: _x=make_shortfloat(fix(_a));break;\ default: break;}\ break;\ default: break;}\ _x;}) #define FEerror(a_,b_...) Icall_error_handler(sLerror,null_string,\ 4,sKformat_control,make_simple_string(a_),sKformat_arguments,list(b_)) #define TYPE_ERROR(a_,b_) Icall_error_handler(sLtype_error,null_string,\ 4,sKdatum,(a_),sKexpected_type,(b_)) #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 FEwrong_type_argument(a_,b_) TYPE_ERROR(b_,a_) #define VA_ARG(_a,_f,_n) \ ({object _z=_f!=OBJNULL ? _f : va_arg(_a,object);\ _f=OBJNULL;_n+=((_n<0) ? 1 : -1);_z;}) #define NEXT_ARG(_n,_a,_l,_f,_d)\ ({object _z;\ switch (_n) {\ case -1: _l=VA_ARG(_a,_f,_n); \ case 0: if (_l==Cnil) _z=_d; else {_z=_l->c.c_car;_l=_l->c.c_cdr;};break;\ default: _z=VA_ARG(_a,_f,_n);break; \ } _z;}) #define INIT_NARGS(_n) ({fixnum _v=VFUN_NARGS;_v=_v<0 ? _v+_n : _v-_n;_v;}) #define object_to_object(x) x #define proper_list(a) (type_of(a)==t_cons || (a)==Cnil) /*FIXME*/ #define IMMNIL(x) (is_imm_fixnum(x)||x==Cnil) /* #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.7.1/h/PaxHeaders/m68k-linux.h0000644000000000000000000000013214776006046013700 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.550908609 gcl-2.7.1/h/m68k-linux.h0000755000175000017500000000346514776006046013311 0ustar00cammcamm#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. */ /* #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 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.7.1/h/PaxHeaders/lu.h0000644000000000000000000000013114762110124012361 xustar0030 mtime=1741197396.789811147 29 atime=1744339801.63133047 30 ctime=1744351535.502909039 gcl-2.7.1/h/lu.h0000644000175000017500000003436514762110124011773 0ustar00cammcamm#include "pbits.h" typedef long long lfixnum; typedef unsigned long long ulfixnum; typedef long fixnum; typedef unsigned long ufixnum; #ifndef WORDS_BIGENDIAN /* high bit must be clear to distinguish from high immediate fixnum*/ #define FRSTWRD(t_,b_,a_...) ufixnum e:1,m:1,f:1, t_:5,t:5,st:3,a_,b_,h:1 #define FRSTWRDF(t_,a_...) ufixnum e:1,m:1,f:1, t_:5,t:5,st:3,a_,h:1 #define FIRSTWORD ufixnum e:1,m:1,f:1, tt:5,t:5,st:3,w:LM(17),h:1 #define FSTPWORD ufixnum emf:3, tp:10, st:3,w:LM(17),h:1 #define MARKWORD ufixnum e:1, mf:2, tt:5,t:5,xx:LM(14),h:1 #define SGCMWORD ufixnum e:1,mf:2, tt:5,t:5,xx:LM(14),h:1 #define TYPEWORD ufixnum emf:3, tt:5,t:5,xx:LM(14),h:1 #else /* high bit must be clear to distinguish from high immediate fixnum*/ #define FRSTWRD(t_,b_,a_...) ufixnum h:1,b_,a_, st:3,t:5,t_:5, f:1,m:1,e:1 #define FRSTWRDF(t_,a_...) ufixnum h:1,a_, st:3,t:5,t_:5, f:1,m:1,e:1 #define FIRSTWORD ufixnum h:1,w:LM(17),st:3,t:5,tt:5, f:1,m:1,e:1 #define FSTPWORD ufixnum h:1,w:LM(17),st:3,tp:10, emf:3 #define MARKWORD ufixnum h:1,xx:LM(14), t:5,tt:5, mf:2,e:1 #define SGCMWORD ufixnum h:1,xx:LM(14), t:5,tt:5, mf:2,e:1 #define TYPEWORD ufixnum h:1,xx:LM(14), t:5,tt:5, emf:3 #endif #if SIZEOF_LONG < 8 #define SPAD object spad #else #define SPAD #endif typedef union lispunion * object; typedef struct cons * htent; typedef struct rtent * rtentp; typedef object (*ofunc)(); typedef void (*vfunc)(); typedef object integer; typedef object keyword; typedef object direl; typedef object plist; typedef object pack; typedef object real; typedef object string; typedef object structure; typedef object symbol; typedef float shortfloat; typedef double longfloat; typedef float complex fcomplex; typedef double complex dcomplex; #undef bool typedef int bool; typedef unsigned short int ushort; typedef unsigned int uint; #if 2 * SIZEOF_INT == SIZEOF_LONG typedef int hfixnum; typedef unsigned int uhfixnum; #elif 2 * SIZEOF_SHORT == SIZEOF_LONG typedef short hfixnum; typedef unsigned short uhfixnum; #else #error No hfixnum size detected #endif /* typedef char character; */ typedef unsigned char uchar; #if 4 * SIZEOF_SHORT == SIZEOF_LONG typedef short qfixnum; typedef unsigned short uqfixnum; #elif 4 * SIZEOF_CHAR == SIZEOF_LONG typedef char qfixnum; typedef unsigned char uqfixnum; #else #error No qfixnum size detected #endif struct fixnum_struct { FIRSTWORD; fixnum FIXVAL; /* fixnum value */ }; struct shortfloat_struct { FIRSTWORD; shortfloat SFVAL; /* shortfloat value */ }; struct longfloat_struct { FIRSTWORD; longfloat LFVAL; /* longfloat value */ SPAD; }; struct bignum { FIRSTWORD; __mpz_struct big_mpz_t; /*defined by gmp/mgmp.h*/ }; struct ratio { FIRSTWORD; integer rat_den; /* denominator, must be an integer */ integer rat_num; /* numerator, must be an integer */ SPAD; }; struct ocomplex { FIRSTWORD; real cmp_real; /* real part, must be a number */ real cmp_imag; /* imaginary part, must be a number */ SPAD; }; #define j(a_,b_) a_##b_ #define J(a_,b_) j(a_,b_) #define ARRAY_DIMENSION_BITS 28 #define ARRAY_DIMENSION_LIMIT (1UL<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 ( ELF_R_TYPE(r->r_info)==R_X86_64_PLT32 || ELF_R_TYPE(r->r_info)==R_X86_64_PC32 || ELF_R_TYPE(r->r_info)==R_X86_64_32 ) { sym=sym1+ELF_R_SYM(r->r_info); if (!sym->st_size) { sym->st_size=++*gs; if (ELF_R_TYPE(r->r_info)==R_X86_64_PLT32) (*gs)+=sizeof(tramp)-1; } } (*gs)*=tz; return 0; } gcl-2.7.1/h/PaxHeaders/rgbc.h0000644000000000000000000000013214542551763012675 xustar0030 mtime=1703597043.208022752 30 atime=1744339813.027401486 30 ctime=1744351535.510908967 gcl-2.7.1/h/rgbc.h0000755000175000017500000000044114542551763012275 0ustar00cammcamm/* (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.7.1/h/PaxHeaders/elf32_hppa_reloc.h0000644000000000000000000000013214613434674015067 xustar0030 mtime=1714305468.355011841 30 atime=1744294998.073953942 30 ctime=1744351535.526908824 gcl-2.7.1/h/elf32_hppa_reloc.h0000644000175000017500000000234614613434674014472 0ustar00cammcamm 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_DIR21L: s+=a; 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_DIR14R: s+=a; s&=MASK(11); store_valu(where,MASK(14),s<<1); break; case R_PARISC_DIR17R: s+=a; s&=MASK(11); store_valu(where,MASK(17),s<<1); break; case R_PARISC_LTOFF21L: case R_PARISC_DPREL21L: s-=pltgot; s>>=11; store_valu(where,MASK(21),ASM21(s)); break; case R_PARISC_LTOFF14R: case R_PARISC_DPREL14R: 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.7.1/h/PaxHeaders/elf64_aarch64_reloc.h0000644000000000000000000000013114542551763015373 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.073953942 30 ctime=1744351535.534908752 gcl-2.7.1/h/elf64_aarch64_reloc.h0000644000175000017500000000366114542551763015000 0ustar00cammcamm 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.7.1/h/PaxHeaders/elf64_loongarch64_reloc_special.h0000644000000000000000000000013214645210066017762 xustar0030 mtime=1721045046.275539377 30 atime=1744294998.073953942 30 ctime=1744351535.538908716 gcl-2.7.1/h/elf64_loongarch64_reloc_special.h0000644000175000017500000000334014645210066017360 0ustar00cammcamm#define R_LARCH_B16 64 #define R_LARCH_B21 65 #define R_LARCH_B26 66 #define R_LARCH_PCALA_HI20 71 #define R_LARCH_PCALA_LO12 72 #define R_LARCH_GOT_PC_HI20 75 #define R_LARCH_GOT_PC_LO12 76 #define R_LARCH_32_PCREL 99 #define R_LARCH_RELAX 100 #define R_LARCH_ALIGN 102 #define R_LARCH_ADD6 105 #define R_LARCH_SUB6 106 static unsigned int tramp[] = { 0x1a00000c, /* pcalau12i $t0, %hi(sym) */ 0x4c000180 /* jirl $zero, $t0, %lo(sym) */}; 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; int idx; const int gz = sizeof(ul)/sizeof(ul), tz = sizeof(tramp)/sizeof(ul); massert(gz==1); massert(tz==1); for (sym=sym1;symst_size=0; /* Count the symbols need to be fixed first. */ 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_LARCH_GOT_PC_HI20 || ELF_R_TYPE(r->r_info)==R_LARCH_B26 ) { sym=sym1+ELF_R_SYM(r->r_info); if (ELF_R_TYPE(r->r_info)==R_LARCH_B26 && LOCAL_SYM(sym)) continue; if (ELF_R_TYPE(r->r_info)==R_LARCH_GOT_PC_HI20) sym->st_size|=0x1; if (ELF_R_TYPE(r->r_info)==R_LARCH_B26) sym->st_size|=0x2; } for (idx=0,sym=sym1;symst_size==0) continue; massert(!(sym->st_size>>2)); sym->st_size|=idx<<2; if (sym->st_size&0x1) idx+=gz; if (sym->st_size&0x2) idx+=tz; } *gs=idx; return 0; } gcl-2.7.1/h/PaxHeaders/elf32_s390_reloc.h0000644000000000000000000000013114542551763014634 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.073953942 30 ctime=1744351535.530908788 gcl-2.7.1/h/elf32_s390_reloc.h0000644000175000017500000000031114542551763014226 0ustar00cammcamm 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.7.1/h/PaxHeaders/apply_n.h0000644000000000000000000000013214542551763013422 xustar0030 mtime=1703597043.196022733 30 atime=1744339826.715486917 30 ctime=1744351535.518908896 gcl-2.7.1/h/apply_n.h0000644000175000017500000003256314542551763013031 0ustar00cammcammstatic 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; } } static inline object c_apply_n_fun(object fun,int n,object *b) { static object mb[1]={OBJNULL}; return !n && fun->fun.fun_maxarg ? c_apply_n(fun->fun.fun_self,1,mb) : c_apply_n(fun->fun.fun_self,n,b); } gcl-2.7.1/h/PaxHeaders/enum.h0000644000000000000000000000013114542551763012723 xustar0029 mtime=1703597043.20002274 30 atime=1744339801.607330321 30 ctime=1744351535.494909111 gcl-2.7.1/h/enum.h0000755000175000017500000000207514542551763012331 0ustar00cammcammenum signals_allowed_values { sig_none, sig_normal, sig_try_to_delay, sig_safe, sig_at_read, sig_use_signals_allowed_value }; enum aelttype { /* array element type */ aet_ch, /* character */ aet_bit, /* bit */ aet_nnchar, /* non-neg char */ aet_uchar, /* unsigned char */ aet_char, /* signed char */ aet_nnshort, /* non-neg short */ aet_ushort, /* unsigned short */ aet_short, /* signed short */ aet_sf, /* short-float */ #if SIZEOF_LONG != SIZEOF_INT aet_nnint, /* non-neg int */ aet_uint, /* unsigned int */ aet_int, /* signed int */ #endif aet_lf, /* plong-float */ aet_object, /* t */ aet_nnfix, /* non-neg fixnum */ aet_fix, /* fixnum */ #if SIZEOF_LONG == SIZEOF_INT aet_nnint, /* non-neg int */ aet_uint, /* unsigned int */ aet_int, /* signed int */ #endif aet_last }; enum aemode { aem_signed, aem_unsigned, aem_float, aem_complex, aem_character, aem_t }; gcl-2.7.1/h/PaxHeaders/arth.h0000644000000000000000000000013114542551763012715 xustar0030 mtime=1703597043.196022733 29 atime=1744339801.63933052 30 ctime=1744351535.514908931 gcl-2.7.1/h/arth.h0000644000175000017500000046055514542551763012333 0ustar00cammcamm#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 D_8_2 4 #define D_8_4 2 #define D_4_2 2 #define D_4_4 1 #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_) #define AD(a_,b_) AA(D,a_,b_) gcl-2.7.1/h/PaxHeaders/386-gnu.h0000644000000000000000000000013214776006046013065 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.550908609 gcl-2.7.1/h/386-gnu.h0000755000175000017500000000110314776006046012461 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/elf32_mips_reloc.h0000644000000000000000000000013014542551763015105 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.07795396 30 ctime=1744351535.530908788 gcl-2.7.1/h/elf32_mips_reloc.h0000644000175000017500000000271414542551763014511 0ustar00cammcamm 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.7.1/h/PaxHeaders/mingw.h0000644000000000000000000000013114760704751013077 xustar0030 mtime=1740868073.371093665 29 atime=1744294998.07795396 30 ctime=1744351535.558908537 gcl-2.7.1/h/mingw.h0000755000175000017500000001150114760704751012477 0ustar00cammcamm#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) seek_to_end_ofile(fp) #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.7.1/h/PaxHeaders/elf64_sparc_reloc_special.h0000644000000000000000000000012714542551763016760 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.07795396 29 ctime=1744351535.54290868 gcl-2.7.1/h/elf64_sparc_reloc_special.h0000644000175000017500000000211214542551763016346 0ustar00cammcamm#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.7.1/h/PaxHeaders/frame.h0000644000000000000000000000013214555557372013060 xustar0030 mtime=1706483450.788392733 30 atime=1744339813.007401361 30 ctime=1744351535.494909111 gcl-2.7.1/h/frame.h0000644000175000017500000000703014555557372012456 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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; EXTER ihs_ptr ihs_org,ihs_limit,ihs_top; #define ihs_check if (ihs_top >= ihs_limit) ihs_overflow() #define ihs_push(function) do {\ if (++ihs_top>=ihs_limit) ihs_overflow();\ ihs_top->ihs_function = (function); \ ihs_top->ihs_base = vs_base;} while (0) #define ihs_push_base(function,base) do {\ if (++ihs_top>=ihs_limit) ihs_overflow();\ ihs_top->ihs_function = (function); \ ihs_top->ihs_base = base;} while (0) #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; typedef struct frame { char frs_jmpbuf[SIZEOF_JMP_BUF] __attribute__ ((__aligned__ (OBJ_ALIGNMENT*2))); object *frs_lex; bds_ptr frs_bds_top; char frs_class; char frs_in_signal_handler; object frs_val; ihs_ptr frs_ihs; } *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 | ---------------------------------------------------------------- */ EXTER frame_ptr frs_org,frs_start,frs_limit,frs_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.7.1/h/PaxHeaders/make-decl.h0000644000000000000000000000013114542551763013601 xustar0030 mtime=1703597043.204022746 29 atime=1744340055.76093465 30 ctime=1744351535.518908896 gcl-2.7.1/h/make-decl.h0000755000175000017500000000002514542551763013200 0ustar00cammcamm #include "defun.h" gcl-2.7.1/h/PaxHeaders/amd64-kfreebsd.h0000644000000000000000000000013214776006046014454 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.546908644 gcl-2.7.1/h/amd64-kfreebsd.h0000644000175000017500000000053414776006046014054 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/usig.h0000644000000000000000000000013114565740505012725 xustar0029 mtime=1708638533.12156778 30 atime=1744339828.107495612 30 ctime=1744351535.510908967 gcl-2.7.1/h/usig.h0000755000175000017500000000026214565740505012327 0ustar00cammcammtypedef void (*handler_function_type)(int,siginfo_t *,void *); EXTER handler_function_type our_signal_handler[32]; #define signal_mask(n) (1 << (n)) gcl-2.7.1/h/PaxHeaders/cmponly_last.h0000644000000000000000000000013114773574763014476 xustar0030 mtime=1743714803.483930918 30 atime=1744340055.160930819 29 ctime=1744351535.52290886 gcl-2.7.1/h/cmponly_last.h0000644000175000017500000000027214773574763014076 0ustar00cammcamm /* #ifndef __ia64__/\*FIXME*\/ */ /* #undef setjmp */ /* #define setjmp ((int(*)(void *))dlsetjmp) */ /* #undef _setjmp */ /* #define _setjmp ((int(*)(void *))dlsetjmp) */ /* #endif */ gcl-2.7.1/h/PaxHeaders/elf32_i386_reloc.h0000644000000000000000000000013014542551763014626 xustar0029 mtime=1703597043.20002274 29 atime=1744294998.07795396 30 ctime=1744351535.526908824 gcl-2.7.1/h/elf32_i386_reloc.h0000644000175000017500000000020614542551763014224 0ustar00cammcamm 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.7.1/h/PaxHeaders/386-linux.h0000644000000000000000000000013214776006046013433 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.546908644 gcl-2.7.1/h/386-linux.h0000755000175000017500000000027614776006046013041 0ustar00cammcamm#include "linux.h" #define ADDITIONAL_FEATURES \ ADD_FEATURE("BSD386"); \ ADD_FEATURE("MC68020") #define I386 #define SGC #define RELOC_H "elf32_i386_reloc.h" gcl-2.7.1/h/PaxHeaders/pbits.h0000644000000000000000000000013114542551763013100 xustar0030 mtime=1703597043.208022752 29 atime=1744339801.63133047 30 ctime=1744351535.506909003 gcl-2.7.1/h/pbits.h0000644000175000017500000000051114542551763012474 0ustar00cammcamm#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_) #define HM(a_) AM(AT(AD(SIZEOF_LONG,2),8),a_) #define QM(a_) AM(AT(AD(SIZEOF_LONG,4),8),a_) #if SIZEOF_LONG == 4 #define LL 2 #elif SIZEOF_LONG == 8 #define LL 3 #else #error "unknown SIZEOF_LONG" #endif gcl-2.7.1/h/PaxHeaders/options.h0000644000000000000000000000013214542551763013453 xustar0030 mtime=1703597043.208022752 30 atime=1744339813.051401636 30 ctime=1744351535.506909003 gcl-2.7.1/h/options.h0000755000175000017500000000070614542551763013057 0ustar00cammcamm/* 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.7.1/h/PaxHeaders/compbas2.h0000644000000000000000000000013214566371416013467 xustar0030 mtime=1708782350.559205557 30 atime=1744339813.027401486 30 ctime=1744351535.490909147 gcl-2.7.1/h/compbas2.h0000755000175000017500000000174514566371416013077 0ustar00cammcamm#ifndef COMP_BAS_2 #define COMP_BAS_2 /* if already mp.h has been included skip */ #define save_avma #define restore_avma EXTER object MVloc[10]; EXTER int Rset; #ifndef U8_DEFINED typedef int8_t i8 ; typedef int16_t i16; typedef int32_t i32; typedef int64_t i64; typedef uint8_t n8 ; typedef uint16_t n16; typedef uint32_t n32; typedef uint64_t n64; typedef float f32; typedef double f64; typedef long double f128; typedef fcomplex c64; typedef dcomplex c128; typedef object o32; typedef union {int8_t i;uint8_t u;n8 n;} u8; typedef union {int16_t i;uint16_t u;n16 n;} __attribute__((__packed__)) u16; typedef union { int32_t i; #if SIZEOF_LONG!=4 uint32_t u; n32 n; #else object o; #endif float f;} __attribute__((__packed__)) u32; typedef union { #if SIZEOF_LONG!=4 int64_t i; object o; #endif double f; fcomplex c;} __attribute__((__packed__)) u64; typedef union {dcomplex c;} __attribute__((__packed__)) u128; #define U8_DEFINED #endif #endif gcl-2.7.1/h/PaxHeaders/vs.h0000644000000000000000000000013214542551763012410 xustar0030 mtime=1703597043.212022758 30 atime=1744339813.003401336 30 ctime=1744351535.514908931 gcl-2.7.1/h/vs.h0000755000175000017500000000307314542551763012014 0ustar00cammcamm/* 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 */ EXTER object *vs_org,*vs_limit,*vs_base,*vs_top; #define vs_push(x_) *vs_top++ = (x_) #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(x_) (vs_top >= vs_limit ? (object)vs_overflow() : (*vs_top++=(x_))) #define check_arg(n_) if (vs_top-vs_base!=(n_)) check_arg_failed(n_) #define CHECK_ARG_RANGE(n_,m_) if (VFUN_NARGSm_) check_arg_range(n_,m_) #define MMcheck_arg(n_) do {\ if (vs_top-vs_base<(n_)) too_few_arguments(); \ else if (vs_top-vs_base>(n_)) too_many_arguments();} while (0) #define vs_reserve(x_) if(vs_base+(x_) >= vs_limit) vs_overflow(); gcl-2.7.1/h/PaxHeaders/elf32_armhf_reloc.h0000644000000000000000000000013014542551763015232 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.081953977 29 ctime=1744351535.52290886 gcl-2.7.1/h/elf32_armhf_reloc.h0000644000175000017500000000436214542551763014637 0ustar00cammcamm#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.7.1/h/PaxHeaders/elf64_alpha_reloc.h0000644000000000000000000000013114542551763015230 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.081953977 30 ctime=1744351535.534908752 gcl-2.7.1/h/elf64_alpha_reloc.h0000644000175000017500000000211414542551763014625 0ustar00cammcamm 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.7.1/h/PaxHeaders/aarch64-linux.h0000644000000000000000000000013214776006046014343 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.554908573 gcl-2.7.1/h/aarch64-linux.h0000644000175000017500000000023614776006046013742 0ustar00cammcamm#include "linux.h" #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.7.1/h/PaxHeaders/mach32_i386_reloc.h0000644000000000000000000000013114542551763014771 xustar0030 mtime=1703597043.204022746 30 atime=1744294998.081953977 29 ctime=1744351535.54290868 gcl-2.7.1/h/mach32_i386_reloc.h0000644000175000017500000000051314542551763014367 0ustar00cammcamm 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.7.1/h/PaxHeaders/include.h0000644000000000000000000000013214555557372013411 xustar0030 mtime=1706483450.788392733 30 atime=1744339813.051401636 30 ctime=1744351535.498909075 gcl-2.7.1/h/include.h0000644000175000017500000000532014555557372013007 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 */ #ifndef INCLUDE_H #define 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 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 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/compprotos.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 "compbas2.h" #include "compat.h" #include "../h/rgbc.h" #include "../o/regexp.h" #include "../h/immnum.h" #endif gcl-2.7.1/h/PaxHeaders/alpha-linux.h0000644000000000000000000000013214776006046014200 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.550908609 gcl-2.7.1/h/alpha-linux.h0000755000175000017500000000060014776006046013575 0ustar00cammcamm#include "linux.h" #define 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.7.1/h/PaxHeaders/elf32_sh4_reloc.h0000644000000000000000000000013114542551763014634 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.085953995 30 ctime=1744351535.530908788 gcl-2.7.1/h/elf32_sh4_reloc.h0000644000175000017500000000010014542551763014222 0ustar00cammcamm case R_SH_DIR32: add_val(where,~0L,s+a); break; gcl-2.7.1/h/PaxHeaders/sparc-linux.h0000644000000000000000000000013214542551763014225 xustar0030 mtime=1703597043.208022752 30 atime=1744294998.085953995 30 ctime=1744351535.554908573 gcl-2.7.1/h/sparc-linux.h0000755000175000017500000000062514542551763013631 0ustar00cammcamm#include "linux.h" #define ADDITIONAL_FEATURES 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.7.1/h/PaxHeaders/solaris-i386.h0000644000000000000000000000013214776006046014121 xustar0030 mtime=1744309286.178034479 30 atime=1744309286.286035001 30 ctime=1744351535.562908501 gcl-2.7.1/h/solaris-i386.h0000755000175000017500000000101614776006046013520 0ustar00cammcamm#define ElfW(a) Elf32_ ## a #if !defined(HAVE_LIBBFD) && !defined(USE_DLOPEN) #define __ELF_NATIVE_CLASS 32 #include #endif #include "linux.h" #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); gcl-2.7.1/h/PaxHeaders/elf64_aarch64_reloc_special.h0000644000000000000000000000013114542551763017073 xustar0029 mtime=1703597043.20002274 30 atime=1744294998.085953995 30 ctime=1744351535.534908752 gcl-2.7.1/h/elf64_aarch64_reloc_special.h0000644000175000017500000000177414542551763016503 0ustar00cammcamm/* #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.7.1/h/PaxHeaders/ptable.h0000644000000000000000000000013114542551763013226 xustar0030 mtime=1703597043.208022752 29 atime=1744339827.16748974 30 ctime=1744351535.510908967 gcl-2.7.1/h/ptable.h0000755000175000017500000000241714542551763012634 0ustar00cammcamm/* 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.7.1/h/PaxHeaders/mgmp.h0000644000000000000000000000013114542551763012717 xustar0030 mtime=1703597043.204022746 30 atime=1744340055.764934675 29 ctime=1744351535.52290886 gcl-2.7.1/h/mgmp.h0000644000175000017500000000312714542551763012321 0ustar00cammcamm#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.7.1/PaxHeaders/clcs0000644000000000000000000000013214776006046012225 xustar0030 mtime=1744309286.142034305 30 atime=1744351538.814879383 30 ctime=1744351535.646907748 gcl-2.7.1/clcs/0000755000175000017500000000000014776006046011700 5ustar00cammcammgcl-2.7.1/clcs/PaxHeaders/gcl_clcs_condition_definitions.lisp0000644000000000000000000000013214753165412021403 xustar0030 mtime=1739385610.749118981 30 atime=1744346652.105823765 30 ctime=1744351535.646907748 gcl-2.7.1/clcs/gcl_clcs_condition_definitions.lisp0000644000175000017500000001416314753165412021006 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;;; -*- 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-condition 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 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 &aux (x (pcl::slot-value-normal condition 'function-name)));FIXME (when x (if (stringp x);FIXME compiler context (format stream "~a" x) (format stream "Condition in ~S [or a callee]: " x))) (call-next-method)))) (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))))) (macrolet ((make-fpe-conditions () (labels ((nm (x) (cadr (assoc (car x) '((floating-point-invalid-operation #\i) (division-by-zero #\d) (floating-point-overflow #\o) (floating-point-underflow #\u) (floating-point-inexact #\x))))) (fpe (st &optional (p "FPE-")) (intern (concatenate 'string p (string st)))) (fpess (st) (when (> (length st) 2) (let ((i -1)) (mapcar (lambda (x) (fpe (concatenate 'string (subseq st 0 (incf i)) (subseq st (1+ i))))) (make-list (length st)))))) (make-sub-fpe-conditions (l &optional c);FIXME, all combinations not needed nor possible per IEEE (cond (l (append (make-sub-fpe-conditions (cdr l) c) (make-sub-fpe-conditions (cdr l) (cons (car l) c)))) ((cdr c) (let ((st (nstring-upcase (coerce (mapcar (lambda (x) (nm x)) c) 'string)))) `((,(fpe st) ,(or (fpess st) (mapcar (lambda (x) (fpe (car x) "INTERNAL-SIMPLE-")) c))))))))) `(progn ,@(mapcar (lambda (x) `(define-condition ,(car x) (arithmetic-error) nil)) fpe::+fe-list+) ,@(mapcar (lambda (x) `(define-condition ,@x nil)) (make-sub-fpe-conditions fpe::+fe-list+)))))) (make-fpe-conditions)) gcl-2.7.1/clcs/PaxHeaders/gcl_clcs_conditions.lisp0000644000000000000000000000013214733440601017165 xustar0030 mtime=1735278977.010649951 30 atime=1744346652.105823765 30 ctime=1744351535.646907748 gcl-2.7.1/clcs/gcl_clcs_conditions.lisp0000644000175000017500000000611714733440601016570 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;;; -*- 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)) (declare (ignore documentation)) (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.7.1/clcs/PaxHeaders/package.lisp0000644000000000000000000000013214555557372014576 xustar0030 mtime=1706483450.776392737 30 atime=1744346652.105823765 30 ctime=1744351535.646907748 gcl-2.7.1/clcs/package.lisp0000644000175000017500000000215114555557372014173 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;;; -*- 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) (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.7.1/clcs/PaxHeaders/gcl_clcs_precom.lisp0000644000000000000000000000013214542551763016313 xustar0030 mtime=1703597043.036022482 30 atime=1744346652.105823765 30 ctime=1744351535.646907748 gcl-2.7.1/clcs/gcl_clcs_precom.lisp0000755000175000017500000000036214542551763015715 0ustar00cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (unless (find-package :conditions) (make-package :conditions :use '("LISP" "PCL"))) (in-package "CONDITIONS") #+pcl (pcl::precompile-random-code-segments clcs) gcl-2.7.1/PaxHeaders/compile0000644000000000000000000000013214776130437012733 xustar0030 mtime=1744351519.779051042 30 atime=1744351519.971049295 30 ctime=1744351535.446909541 gcl-2.7.1/compile0000755000175000017500000001670514776130437012345 0ustar00cammcamm#! /bin/sh # Wrapper for compilers which do not understand '-c -o'. scriptversion=2024-06-19.01; # UTC # Copyright (C) 1999-2024 Free Software Foundation, Inc. # Written by Tom Tromey . # # 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 # . nl=' ' # We need space, tab and new line, in precisely that order. Quoting is # there to prevent tools from complaining about whitespace usage. IFS=" "" $nl" file_conv= # func_file_conv build_file lazy # Convert a $build file to $host form and store it in $file # Currently only supports Windows hosts. If the determined conversion # type is listed in (the comma separated) LAZY, no conversion will # take place. func_file_conv () { file=$1 case $file in / | /[!/]*) # absolute file, and not a UNC file if test -z "$file_conv"; then # lazily determine how to convert abs files case `uname -s` in MINGW*) file_conv=mingw ;; CYGWIN* | MSYS*) file_conv=cygwin ;; *) file_conv=wine ;; esac fi case $file_conv/,$2, in *,$file_conv,*) ;; mingw/*) file=`cmd //C echo "$file " | sed -e 's/"\(.*\) " *$/\1/'` ;; cygwin/* | msys/*) file=`cygpath -m "$file" || echo "$file"` ;; wine/*) file=`winepath -w "$file" || echo "$file"` ;; esac ;; esac } # func_cl_dashL linkdir # Make cl look for libraries in LINKDIR func_cl_dashL () { func_file_conv "$1" if test -z "$lib_path"; then lib_path=$file else lib_path="$lib_path;$file" fi linker_opts="$linker_opts -LIBPATH:$file" } # func_cl_dashl library # Do a library search-path lookup for cl func_cl_dashl () { lib=$1 found=no save_IFS=$IFS IFS=';' for dir in $lib_path $LIB do IFS=$save_IFS if $shared && test -f "$dir/$lib.dll.lib"; then found=yes lib=$dir/$lib.dll.lib break fi if test -f "$dir/$lib.lib"; then found=yes lib=$dir/$lib.lib break fi if test -f "$dir/lib$lib.a"; then found=yes lib=$dir/lib$lib.a break fi done IFS=$save_IFS if test "$found" != yes; then lib=$lib.lib fi } # func_cl_wrapper cl arg... # Adjust compile command to suit cl func_cl_wrapper () { # Assume a capable shell lib_path= shared=: linker_opts= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as 'compile cc -o foo foo.c'. eat=1 case $2 in *.o | *.lo | *.[oO][bB][jJ]) func_file_conv "$2" set x "$@" -Fo"$file" shift ;; *) func_file_conv "$2" set x "$@" -Fe"$file" shift ;; esac ;; -I) eat=1 func_file_conv "$2" mingw set x "$@" -I"$file" shift ;; -I*) func_file_conv "${1#-I}" mingw set x "$@" -I"$file" shift ;; -l) eat=1 func_cl_dashl "$2" set x "$@" "$lib" shift ;; -l*) func_cl_dashl "${1#-l}" set x "$@" "$lib" shift ;; -L) eat=1 func_cl_dashL "$2" ;; -L*) func_cl_dashL "${1#-L}" ;; -static) shared=false ;; -Wl,*) arg=${1#-Wl,} save_ifs="$IFS"; IFS=',' for flag in $arg; do IFS="$save_ifs" linker_opts="$linker_opts $flag" done IFS="$save_ifs" ;; -Xlinker) eat=1 linker_opts="$linker_opts $2" ;; -*) set x "$@" "$1" shift ;; *.cc | *.CC | *.cxx | *.CXX | *.[cC]++) func_file_conv "$1" set x "$@" -Tp"$file" shift ;; *.c | *.cpp | *.CPP | *.lib | *.LIB | *.Lib | *.OBJ | *.obj | *.[oO]) func_file_conv "$1" mingw set x "$@" "$file" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -n "$linker_opts"; then linker_opts="-link$linker_opts" fi exec "$@" $linker_opts exit 1 } eat= case $1 in '') echo "$0: No command. Try '$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: compile [--help] [--version] PROGRAM [ARGS] Wrapper for compilers which do not understand '-c -o'. Remove '-o dest.o' from ARGS, run PROGRAM with the remaining arguments, and rename the output as expected. If you are trying to build a whole package this is not the right script to run: please start by reading the file 'INSTALL'. Report bugs to . GNU Automake home page: . General help using GNU software: . EOF exit $? ;; -v | --v*) echo "compile (GNU Automake) $scriptversion" exit $? ;; cl | *[/\\]cl | cl.exe | *[/\\]cl.exe | \ clang-cl | *[/\\]clang-cl | clang-cl.exe | *[/\\]clang-cl.exe | \ icl | *[/\\]icl | icl.exe | *[/\\]icl.exe ) func_cl_wrapper "$@" # Doesn't return... ;; esac ofile= cfile= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as 'compile cc -o foo foo.c'. # So we strip '-o arg' only if arg is an object. eat=1 case $2 in *.o | *.obj) ofile=$2 ;; *) set x "$@" -o "$2" shift ;; esac ;; *.c) cfile=$1 set x "$@" "$1" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -z "$ofile" || test -z "$cfile"; then # If no '-o' option was seen then we might have been invoked from a # pattern rule where we don't need one. That is ok -- this is a # normal compilation that the losing compiler can handle. If no # '.c' file was seen then we are probably linking. That is also # ok. exec "$@" fi # Name of file we expect compiler to create. cofile=`echo "$cfile" | sed 's|^.*[\\/]||; s|^[a-zA-Z]:||; s/\.c$/.o/'` # Create the lock directory. # Note: use '[/\\:.-]' here to ensure that we don't use the same name # that we are using for the .o file. Also, base the name on the expected # object file name, since that is what matters with a parallel build. lockdir=`echo "$cofile" | sed -e 's|[/\\:.-]|_|g'`.d while true; do if mkdir "$lockdir" >/dev/null 2>&1; then break fi sleep 1 done # FIXME: race condition here if user kills between mkdir and trap. trap "rmdir '$lockdir'; exit 1" 1 2 15 # Run the compile. "$@" ret=$? if test -f "$cofile"; then test "$cofile" = "$ofile" || mv "$cofile" "$ofile" elif test -f "${cofile}bj"; then test "${cofile}bj" = "$ofile" || mv "${cofile}bj" "$ofile" fi rmdir "$lockdir" exit $ret # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: gcl-2.7.1/PaxHeaders/info0000644000000000000000000000013214776130462012234 xustar0030 mtime=1744351538.810879419 30 atime=1744351538.814879383 30 ctime=1744351538.810879419 gcl-2.7.1/info/0000755000175000017500000000000014776130462011707 5ustar00cammcammgcl-2.7.1/info/PaxHeaders/gcl.info-20000644000000000000000000000013214776130460014070 xustar0030 mtime=1744351536.690898392 30 atime=1744351536.538899754 30 ctime=1744351538.786879634 gcl-2.7.1/info/gcl.info-20000644000175000017500000111161114776130460013470 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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.  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. gcl-2.7.1/info/PaxHeaders/gcl-si.info0000644000000000000000000000013014776130462014342 xustar0029 mtime=1744351538.29088407 29 atime=1744351538.29088407 30 ctime=1744351538.798879527 gcl-2.7.1/info/gcl-si.info0000644000175000017500000000274014776130462013745 0ustar00cammcammThis is gcl-si.info, produced by makeinfo version 7.1 from gcl-si.texi. This is a Texinfo GCL SYSTEM INTERNALS Manual Copyright 1994 William F. Schelter Copyright 2024 Camm Maguire INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-si: (gcl-si.info). GNU Common Lisp System Internals END-INFO-DIR-ENTRY  Indirect: gcl-si.info-1: 319 gcl-si.info-2: 347893  Tag Table: (Indirect) Node: Top319 Node: Numbers1239 Node: Sequences and Arrays and Hash Tables23636 Node: Characters49429 Node: Lists56825 Node: Streams and Reading70599 Node: Special Forms and Functions95986 Node: Compilation121638 Node: Symbols134272 Node: Operating System144031 Node: Command Line144247 Node: Operating System Definitions148429 Node: Environment Variables154786 Node: Structures156375 Node: Iteration and Tests157927 Node: User Interface161377 Node: Doc170439 Node: Type173724 Node: GCL Specific176384 Node: Bignums185027 Node: C Interface187717 Node: Available Symbols187909 Node: External Shared Libraries188400 Node: System Definitions203986 Node: Regular Expressions238596 Node: Debugging244844 Node: Source Level Debugging in Emacs245045 Node: Low Level Debug Functions249290 Node: Miscellaneous250290 Node: Environment250498 Node: Inititialization251123 Node: Low Level X Interface251667 Node: Compiler Definitions252264 Node: JAPI GUI Library Binding258393 Node: Function Index277447 Node: Variable Index347893  End Tag Table  Local Variables: coding: utf-8 End: gcl-2.7.1/info/PaxHeaders/chap-1.texi0000644000000000000000000000013114542551763014256 xustar0030 mtime=1703597043.212022758 29 atime=1744294998.18995445 30 ctime=1744351535.598908178 gcl-2.7.1/info/chap-1.texi0000644000175000017500000035630314542551763013667 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-25.texi0000644000000000000000000000013214542551763014345 xustar0030 mtime=1703597043.244022809 30 atime=1744294998.197954485 30 ctime=1744351535.610908071 gcl-2.7.1/info/chap-25.texi0000644000175000017500000016164414542551763013757 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-24.texi0000644000000000000000000000013214542551763014344 xustar0030 mtime=1703597043.244022809 30 atime=1744294998.197954485 30 ctime=1744351535.610908071 gcl-2.7.1/info/chap-24.texi0000644000175000017500000010470014542551763013744 0ustar00cammcamm @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.7.1/info/PaxHeaders/gcl-si.info-20000644000000000000000000000013114776130462014502 xustar0029 mtime=1744351538.29088407 30 atime=1744351538.286884106 30 ctime=1744351538.802879491 gcl-2.7.1/info/gcl-si.info-20000644000175000017500000003305014776130462014102 0ustar00cammcammThis is gcl-si.info, produced by makeinfo version 7.1 from gcl-si.texi. This is a Texinfo GCL SYSTEM INTERNALS Manual Copyright 1994 William F. Schelter Copyright 2024 Camm Maguire INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-si: (gcl-si.info). GNU Common Lisp System Internals END-INFO-DIR-ENTRY  File: gcl-si.info, Node: Variable Index, Prev: Function Index, Up: Top Appendix B Variable Index ************************* [index] * Menu: * -: User Interface. (line 6) * -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) * *: User Interface. (line 107) * **: User Interface. (line 74) * ***: User Interface. (line 25) * *AFTER-GBC-HOOK*: System Definitions. (line 360) * *ANNOTATE*: System Definitions. (line 171) * *APPLYHOOK*: Special Forms and Functions. (line 622) * *BREAK-ENABLE*: User Interface. (line 44) * *BREAK-ON-WARNINGS*: User Interface. (line 64) * *CASE-FOLD-SEARCH*: System Definitions. (line 839) * *CC*: Compiler Definitions. (line 137) * *CMPINCLUDE-STRING*: Compiler Definitions. (line 15) * *CODE-BLOCK-RESERVE*: System Definitions. (line 157) * *COMPILE-ORDINARIES*: Compiler Definitions. (line 159) * *DEBUG-IO*: User Interface. (line 61) * *DEFAULT-C-FILE*: Compilation. (line 239) * *DEFAULT-C-FILE* <1>: System Definitions. (line 186) * *DEFAULT-DATA-FILE*: Compilation. (line 247) * *DEFAULT-DATA-FILE* <1>: System Definitions. (line 196) * *DEFAULT-H-FILE*: Compilation. (line 243) * *DEFAULT-H-FILE* <1>: System Definitions. (line 191) * *DEFAULT-LARGE-MEMORY-MODEL-P*: System Definitions. (line 180) * *DEFAULT-PATHNAME-DEFAULTS*: Operating System Definitions. (line 157) * *DEFAULT-PROF-P*: System Definitions. (line 175) * *DEFAULT-SYSTEM-P*: Compilation. (line 235) * *DEFAULT-SYSTEM-P* <1>: System Definitions. (line 201) * *DEFAULT-TIME-ZONE*: System Definitions. (line 471) * *DISASSEMBLE-OBJDUMP*: System Definitions. (line 215) * *ERROR-OUTPUT*: User Interface. (line 98) * *EVALHOOK*: Special Forms and Functions. (line 248) * *FASD-DATA*: System Definitions. (line 207) * *FAST-LINK-WARNINGS*: System Definitions. (line 165) * *FEATURES*: Compilation. (line 251) * *GBC-MESSAGE*: System Definitions. (line 350) * *GBC-NOTIFY*: System Definitions. (line 355) * *IGNORE-EOF-ON-TERMINAL-IO*: System Definitions. (line 398) * *IGNORE-MAXIMUM-PAGES*: GCL Specific. (line 19) * *INDENT-FORMATTED-OUTPUT*: System Definitions. (line 270) * *info-paths*: Doc. (line 61) * *INTERRUPT-ENABLE*: System Definitions. (line 245) * *KEEP-GAZ*: System Definitions. (line 211) * *LISP-MAXPAGES*: System Definitions. (line 413) * *LOAD-PATHNAME*: System Definitions. (line 746) * *LOAD-VERBOSE*: Streams and Reading. (line 595) * *MACROEXPAND-HOOK*: Special Forms and Functions. (line 376) * *MODULES*: Operating System Definitions. (line 57) * *MULTIPLY-STACKS*: System Definitions. (line 564) * *NOTIFY-GBC*: System Definitions. (line 432) * *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 143) * *STANDARD-INPUT*: Streams and Reading. (line 640) * *STANDARD-OUTPUT*: Streams and Reading. (line 434) * *SYSTEM-DIRECTORY*: System Definitions. (line 314) * *TERMINAL-IO*: Streams and Reading. (line 287) * *TMP-DIR*: GCL Specific. (line 15) * *TOP-LEVEL-HOOK*: System Definitions. (line 822) * *TRACE-OUTPUT*: User Interface. (line 91) * /: User Interface. (line 48) * //: User Interface. (line 87) * ///: User Interface. (line 110) * +: User Interface. (line 128) * ++: User Interface. (line 94) * +++: User Interface. (line 78) * ARRAY-DIMENSION-LIMIT: Sequences and Arrays and Hash Tables. (line 595) * ARRAY-RANK-LIMIT: Sequences and Arrays and Hash Tables. (line 526) * ARRAY-TOTAL-SIZE-LIMIT: Sequences and Arrays and Hash Tables. (line 440) * 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) * CALL-ARGUMENTS-LIMIT: Special Forms and Functions. (line 523) * CHAR-BITS-LIMIT: Characters. (line 137) * CHAR-CODE-LIMIT: Numbers. (line 84) * CHAR-CONTROL-BIT: Characters. (line 94) * CHAR-FONT-LIMIT: Characters. (line 35) * CHAR-HYPER-BIT: Characters. (line 80) * CHAR-META-BIT: Characters. (line 121) * CHAR-SUPER-BIT: Characters. (line 32) * DOUBLE-FLOAT-EPSILON: Numbers. (line 754) * DOUBLE-FLOAT-NEGATIVE-EPSILON: Numbers. (line 188) * DYNAMIC-EXTENT: Type. (line 77) * GCL_GC_ALLOC_MIN: Environment Variables. (line 16) * GCL_GC_PAGE_MAX: Environment Variables. (line 26) * GCL_GC_PAGE_MIN: Environment Variables. (line 21) * GCL_MEM_BOUND: Environment Variables. (line 12) * GCL_MEM_MULTIPLE: Environment Variables. (line 8) * GCL_MULTIPROCESS_MEMORY_POOL: Environment Variables. (line 31) * GCL_WAIT_ON_ABORT: Environment Variables. (line 37) * INTERNAL-TIME-UNITS-PER-SECOND: Operating System Definitions. (line 79) * LAMBDA-LIST-KEYWORDS: Special Forms and Functions. (line 6) * LAMBDA-PARAMETERS-LIMIT: Special Forms and Functions. (line 259) * 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) * LONG-FLOAT-EPSILON: Numbers. (line 376) * LONG-FLOAT-NEGATIVE-EPSILON: Numbers. (line 590) * 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-VALUES-LIMIT: Special Forms and Functions. (line 363) * NIL: Symbols. (line 92) * PI: Numbers. (line 93) * SHORT-FLOAT-EPSILON: Numbers. (line 146) * SHORT-FLOAT-NEGATIVE-EPSILON: Numbers. (line 346) * SINGLE-FLOAT-EPSILON: Numbers. (line 573) * SINGLE-FLOAT-NEGATIVE-EPSILON: Numbers. (line 787) * T: Symbols. (line 118) gcl-2.7.1/info/PaxHeaders/chap-11.texi0000644000000000000000000000013214542551763014340 xustar0030 mtime=1703597043.228022784 30 atime=1744294998.225954607 30 ctime=1744351535.602908142 gcl-2.7.1/info/chap-11.texi0000644000175000017500000026104414542551763013745 0ustar00cammcamm @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.7.1/info/PaxHeaders/gcl.info-10000644000000000000000000000013214776130460014067 xustar0030 mtime=1744351536.538899754 30 atime=1744351536.366901294 30 ctime=1744351538.786879634 gcl-2.7.1/info/gcl.info-10000644000175000017500000111250714776130460013474 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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.  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. gcl-2.7.1/info/PaxHeaders/chap-9.texi0000644000000000000000000000013114763573237014273 xustar0030 mtime=1741616799.681591281 29 atime=1744294998.23795466 30 ctime=1744351535.618907999 gcl-2.7.1/info/chap-9.texi0000644000175000017500000043234514763573237013705 0ustar00cammcamm @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 association 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 accommodate 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 accommodate 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.7.1/info/PaxHeaders/gcl.info-80000644000000000000000000000013214776130461014077 xustar0030 mtime=1744351537.674889581 30 atime=1744351537.522890942 30 ctime=1744351538.794879562 gcl-2.7.1/info/gcl.info-80000644000175000017500000110520014776130461013474 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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.  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. gcl-2.7.1/info/PaxHeaders/chap-7.texi0000644000000000000000000000013214542551763014265 xustar0030 mtime=1703597043.248022815 30 atime=1744294998.257954747 30 ctime=1744351535.618907999 gcl-2.7.1/info/chap-7.texi0000644000175000017500000067740414542551763013705 0ustar00cammcamm @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.7.1/info/PaxHeaders/sequence.texi0000644000000000000000000000013214542551763015016 xustar0030 mtime=1703597043.256022827 30 atime=1744294998.261954764 30 ctime=1744351535.630907891 gcl-2.7.1/info/sequence.texi0000755000175000017500000005661314542551763014432 0ustar00cammcamm@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.7.1/info/PaxHeaders/symbol.texi0000644000000000000000000000013214542551763014513 xustar0030 mtime=1703597043.256022827 30 atime=1744294998.261954764 30 ctime=1744351535.630907891 gcl-2.7.1/info/symbol.texi0000755000175000017500000002212714542551763014120 0ustar00cammcamm@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.7.1/info/PaxHeaders/character.texi0000644000000000000000000000013214542551763015142 xustar0030 mtime=1703597043.252022821 30 atime=1744294998.273954817 30 ctime=1744351535.618907999 gcl-2.7.1/info/character.texi0000755000175000017500000001561514542551763014553 0ustar00cammcamm@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.7.1/info/PaxHeaders/gcl-si.texi0000644000000000000000000000013114776006046014361 xustar0030 mtime=1744309286.186034518 29 atime=1744309286.29003502 30 ctime=1744351535.574908393 gcl-2.7.1/info/gcl-si.texi0000644000175000017500000000472214776006046013765 0ustar00cammcamm\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 @settitle GCL SI Manual @c @synindex vr fn @c to update the menus do: @c (texinfo-multiple-files-update "gcl-si.texi" t t) @setchapternewpage odd @ifinfo This is a Texinfo GCL SYSTEM INTERNALS Manual Copyright 1994 William F. Schelter Copyright 2024 Camm Maguire @format INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-si: (gcl-si.info). GNU Common Lisp System Internals END-INFO-DIR-ENTRY @end format @end ifinfo @titlepage @sp 10 @comment The title is printed in a large font. @center @titlefont{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:: * JAPI GUI Library Binding:: * Function Index:: * 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 japi.texi @node Function Index,Variable Index ,JAPI GUI Library Binding, Top @appendix Function Index @printindex fn @node Variable Index, ,Function Index, Top @appendix Variable Index @printindex vr @summarycontents @contents @bye gcl-2.7.1/info/PaxHeaders/japi.texi0000644000000000000000000000013214542551763014131 xustar0030 mtime=1703597043.256022827 30 atime=1744294998.289954887 30 ctime=1744351535.626907927 gcl-2.7.1/info/japi.texi0000644000175000017500000004124014542551763013530 0ustar00cammcamm @node JAPI GUI Library Binding, Function Index, Compiler Definitions, Top @chapter JAPI GUI Library Binding @heading Introduction:: The JAPI GUI library is hosted on the internet at: @example http://www.japi.de @end example It has bindings to many common languages. @heading Including JAPI in your GCL build:: The GCL binding presented here is based on the C language version of the library, statically linked into GCL and uses the standard GCL FFI macros to import the functions and constants provided by JAPI. To include the library in your build of GCL, simply download the version of JAPI needed for your computer system, install the headers and libraries, and add the GCL configure switch ``--enable-japi=yes'' to your usual configuration parameters. Build GCL as usual. To run the GUI from GCL programs, you do need to have either of the executables "java" or "jre" in your PATH. @heading How it works:: As downloaded from the above web site, JAPI uses a socket connection to a Java GUI which is, fortunately for us, invisible to GCL. This gives the GCL JAPI binding the advantages and disadvantages of any non-native GUI system which trades off portability, speed and OS specific look and feel. The GCL JAPI binding works on Windows which is it's main advantage over GCL-Tk other than ease of maintenance at the Lisp level. The main disadvantage of GCL JAPI relative to GCL-Tk is that the JAPI library is no longer actively developed. It has also been criticised for depending on Java, a proprietary system. This binding does nothing more than provide Lisp wrappers around the JAPI primitives; there are no higher order functional wrappers. Never-the-less the interface is easy to understand, maintain and use at the Lisp level. The documentation for JAPI available from the web site is pretty much all you need to get started with the library under GCL. All of the exposed library functions and constants are provided in GCL and a comprehensive example is provided here to give you some idea of how to start using the system. Here is a simple example of how to use JAPI. It displays an empty frame for five seconds and then kills the GUI. @example ;; 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))) @end example The macros ``with-server'' and ``with-frame'' are defined in the larger example below. The first, ``with-server'', takes two arguments, an application name string and a debug level. With debug level zero there is no debug output on the console. The second, ``with-frame'' takes two arguments, a variable name and a frame title string. You use the variable name, here ``frame'', to refer to the frame in later function calls. The longer example below which includes the small example just explained, also displays various kinds of dialog, does some graphics and mouse handling including the ability to save graphics to disk, and shows one way of implementing a very simple text editor. @heading Example:: @example ;;; ;;; 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 (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))))) ;; 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 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))) ;; 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)))) )))))))))))))))))) (defun mandel (drawable min_x max_x min_y max_y step_x step_y) (let* ((scale_x (/ 1 step_x)) (scale_y (/ 1 step_y))) (loop for y from min_y to max_y by step_y do (loop for x from min_x to max_x by step_x do (let* ((c 255) (z (complex x y)) (a z)) (loop while (and (< (abs (setq z (+ (* z z) a))) 2) (>= (decf c) 0))) (j_setcolor drawable c c c) (j_drawpixel drawable (* scale_x (+ (abs min_x) x)) (* scale_y (+ (abs min_y) y)) )))))) ;;; Monochrome Mandelbrot (with-server ("GCL Japi library test GUI 4" 0) (let* ((min_x -2) (max_x 1) (min_y -1) (max_y 1.1) (step_x 0.01) (step_y 0.01) (size_x (+ 1 (/ (- max_x min_x) step_x))) (size_y (+ 1 (/ (- max_y min_y) step_y)))) (with-frame (frame "Mandelbrot") (j_setsize frame size_x size_y) (j_setborderlayout frame) (with-menu-bar (menubar frame) (with-menu (file menubar "File") (with-menu-item (save file "Save BMP") (with-menu-item (quit file "Quit") (with-canvas (canvas1 frame size_x size_y) (j_pack frame) (j_show frame) (j_show canvas1) (mandel canvas1 min_x max_x min_y max_y step_x step_y) (do ((obj (j_nextaction) (j_nextaction))) ((or (= obj frame) (= obj quit)) t) (when (= obj save) (let ((image (j_getimage canvas1))) (when (= 0 (j_saveimage image "mandel.bmp" J_BMP)) (j_alertbox frame "Problems" "Can't save the image" "OK")) (j_dispose image) ))))))))))) @end example gcl-2.7.1/info/PaxHeaders/chap-8.texi0000644000000000000000000000013214542551763014266 xustar0030 mtime=1703597043.252022821 30 atime=1744294998.289954887 30 ctime=1744351535.618907999 gcl-2.7.1/info/chap-8.texi0000644000175000017500000012421414542551763013670 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-23.texi0000644000000000000000000000013214542551763014343 xustar0030 mtime=1703597043.244022809 30 atime=1744294998.325955045 30 ctime=1744351535.610908071 gcl-2.7.1/info/chap-23.texi0000644000175000017500000013647014542551763013754 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-26.texi0000644000000000000000000000013214763573237014353 xustar0030 mtime=1741616799.677591263 30 atime=1744294998.341955115 30 ctime=1744351535.614908035 gcl-2.7.1/info/chap-26.texi0000644000175000017500000061733114763573237013764 0ustar00cammcamm @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 accommodate 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.7.1/info/PaxHeaders/type.texi0000644000000000000000000000013114542551763014166 xustar0030 mtime=1703597043.256022827 29 atime=1744294998.50995585 30 ctime=1744351535.634907855 gcl-2.7.1/info/type.texi0000755000175000017500000000476114542551763013600 0ustar00cammcamm@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.7.1/info/PaxHeaders/gcl-tk.info-10000644000000000000000000000013114776130462014504 xustar0029 mtime=1744351538.75487992 30 atime=1744351538.642880922 30 ctime=1744351538.810879419 gcl-2.7.1/info/gcl-tk.info-10000644000175000017500000111566514776130462014122 0ustar00cammcammThis is gcl-tk.info, produced by makeinfo version 7.1 from gcl-tk.texi. This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-tk: (gcl-tk.info). GNU Common Lisp Tk Manual END-INFO-DIR-ENTRY  File: gcl-tk.info, Node: Top, Next: General, Prev: (dir), Up: (dir) GCL TK Manual ************* * 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 funcions (*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.7.1/info/PaxHeaders/misc.texi0000644000000000000000000000013114542551763014140 xustar0030 mtime=1703597043.256022827 29 atime=1744294998.50995585 30 ctime=1744351535.626907927 gcl-2.7.1/info/misc.texi0000755000175000017500000000333614542551763013547 0ustar00cammcamm @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.7.1/info/PaxHeaders/gcl.texi0000644000000000000000000000013214773070437013753 xustar0030 mtime=1743548703.424359547 30 atime=1744339795.467292101 30 ctime=1744351535.570908429 gcl-2.7.1/info/gcl.texi0000644000175000017500000013050414773070437013354 0ustar00cammcamm\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.7.1/info/PaxHeaders/io.texi0000644000000000000000000000013214542551763013615 xustar0030 mtime=1703597043.256022827 30 atime=1744294998.525955919 30 ctime=1744351535.626907927 gcl-2.7.1/info/io.texi0000755000175000017500000005643014542551763013226 0ustar00cammcamm@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.7.1/info/PaxHeaders/compile.texi0000644000000000000000000000013214763573237014643 xustar0030 mtime=1741616799.681591281 30 atime=1744294998.541955989 30 ctime=1744351535.618907999 gcl-2.7.1/info/compile.texi0000755000175000017500000002735514763573237014260 0ustar00cammcamm@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* Package:COMPILER Specifies the default setting of :SYSTEM-P used by COMPILE. Defaults to NIL. @end defvar @defvar *DEFAULT-C-FILE* Package:COMPILER Specifies the default setting of :C-FILE used by COMPILE. Defaults to NIL. @end defvar @defvar *DEFAULT-H-FILE* Package:COMPILER Specifies the default setting of :H-FILE used by COMPILE. Defaults to NIL. @end defvar @defvar *DEFAULT-DATA-FILE* Package: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.7.1/info/PaxHeaders/bind.texi0000644000000000000000000000013214542551763014122 xustar0030 mtime=1703597043.212022758 30 atime=1744294998.545956007 30 ctime=1744351535.598908178 gcl-2.7.1/info/bind.texi0000755000175000017500000004140614542551763013530 0ustar00cammcamm@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.7.1/info/PaxHeaders/iteration.texi0000644000000000000000000000013214542551763015204 xustar0030 mtime=1703597043.256022827 30 atime=1744294998.545956007 30 ctime=1744351535.626907927 gcl-2.7.1/info/iteration.texi0000755000175000017500000000641014542551763014606 0ustar00cammcamm@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.7.1/info/PaxHeaders/gcl.info-60000644000000000000000000000013214776130461014075 xustar0030 mtime=1744351537.362892374 30 atime=1744351537.178894021 30 ctime=1744351538.794879562 gcl-2.7.1/info/gcl.info-60000644000175000017500000111356214776130461013504 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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 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 association 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 association 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)  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. gcl-2.7.1/info/PaxHeaders/gcl.info-40000644000000000000000000000013114776130460014071 xustar0029 mtime=1744351536.98689574 30 atime=1744351536.846896994 30 ctime=1744351538.790879598 gcl-2.7.1/info/gcl.info-40000644000175000017500000110562214776130460013477 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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 (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 association 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 accommodate 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) ...)))))  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:: gcl-2.7.1/info/PaxHeaders/chap-5.texi0000644000000000000000000000013114770537330014257 xustar0029 mtime=1742913240.10648996 30 atime=1744294998.573956129 30 ctime=1744351535.614908035 gcl-2.7.1/info/chap-5.texi0000644000175000017500000060271114770537330013665 0ustar00cammcamm @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:: pronounced p\=e'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}. @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 following 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.7.1/info/PaxHeaders/system.texi0000644000000000000000000000013114776006046014527 xustar0030 mtime=1744309286.186034518 29 atime=1744309286.29003502 30 ctime=1744351535.630907891 gcl-2.7.1/info/system.texi0000644000175000017500000002665514776006046014144 0ustar00cammcamm @node Operating System, Structures, Symbols, Top @chapter Operating System @menu * Command Line:: * Operating System Definitions:: * Environment Variables:: @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 @node Environment Variables, Operating System Definitions, Operating System, Operating System @section Environment Variables Several environment variables affect GCL: @defvr {Environment Variable} GCL_MEM_MULTIPLE A positive float indicating the fraction of available memory GCL should use. Defaults to 1.0. @end defvr @defvr {Environment Variable} GCL_MEM_BOUND A positive integer bounding GCL's heap to 1<<(n+1) bytes. Trumps GCL_MEM_MULTIPLE. Defaults to sizeof(long)-1. @end defvr @defvr {Environment Variable} GCL_GC_ALLOC_MIN A positive float indicating the minimum fraction of heap to be allocated between garbage collection (GC) cycles. Defaults to 0.05. @end defvr @defvr {Environment Variable} GCL_GC_PAGE_MIN A positive float indicating the minimum fraction of heap to be allocated before garbage collection (GC) commences. Defaults to 0.5. @end defvr @defvr {Environment Variable} GCL_GC_PAGE_MAX A positive float indicating the maximum fraction of heap to be allocated after which garbage collection (GC) is mandatory. Defaults to 0.75. @end defvr @defvr {Environment Variable} GCL_MULTIPROCESS_MEMORY_POOL A string when set indicating a directory in which to place the file gcl_pool used for coordinating memory management among multiple GCL processes. This should be a local directory for performance reasons. Default is unset. @end defvr @defvr {Environment Variable} GCL_WAIT_ON_ABORT A non-negative integer indicating how many seconds to sleep before aborting on fatal error. Defaults to 0. @end defvr gcl-2.7.1/info/PaxHeaders/gcl-dwdoc.info0000644000000000000000000000013214776130462015031 xustar0030 mtime=1744351538.462882531 30 atime=1744351538.446882675 30 ctime=1744351538.806879455 gcl-2.7.1/info/gcl-dwdoc.info0000644000175000017500000011356114776130462014436 0ustar00cammcammThis is gcl-dwdoc.info, produced by makeinfo version 7.1 from gcl-dwdoc.texi. This is a Texinfo GCL DWDOC Manual Copyright 1994 William F. Schelter Copyright 08 Oct 92; 08 Oct 93; 16 Nov 94; 05 Jan 95; 25 Jan 06; 26 Jan 06; 08 Dec 08 Gordon S. Novak Jr. Copyright 2024 Camm Maguire INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-dwdoc: (gcl-dwdoc.info). GNU Common Lisp Dwdoc END-INFO-DIR-ENTRY  File: gcl-dwdoc.info, Node: Top, Next: Introduction, Up: (dir) Top *** *Interface from GCL to X Windows* Gordon S. Novak Jr. 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. * Menu: * Introduction:: * Examples and Utilities:: * Menus:: * Windows:: * Drawing Functions:: * Fonts Operations Colors:: * Mouse Interaction:: * Miscellaneous Functions:: * Examples:: * Web Interface:: * Files:: * Data Types:: * Copyright::  File: gcl-dwdoc.info, Node: Introduction, Next: Examples and Utilities, Prev: Top, Up: Top 1 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.  File: gcl-dwdoc.info, Node: Examples and Utilities, Next: Menus, Prev: Introduction, Up: Top 2 Examples and Utilities ************************ * Menu: * dwtest:: * pcalc:: * draw:: * editors::  File: gcl-dwdoc.info, Node: dwtest, Next: pcalc, Up: Examples and Utilities 2.1 ‘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.  File: gcl-dwdoc.info, Node: pcalc, Next: draw, Prev: dwtest, Up: Examples and Utilities 2.2 ‘pcalc’ =========== The file ‘pcalc.lsp’ implements a pocket calculator as a ‘picmenu’; its entry is ‘(pcalc)’.  File: gcl-dwdoc.info, Node: draw, Next: editors, Prev: pcalc, Up: Examples and Utilities 2.3 ‘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 LaTeX 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’.  File: gcl-dwdoc.info, Node: editors, Prev: draw, Up: Examples and Utilities 2.4 ‘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 *note 6.2: #texted. and *note 6.3: #emacsed. below.  File: gcl-dwdoc.info, Node: Menus, Next: Windows, Prev: Examples and Utilities, Up: Top 3 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. * Menu: * Picmenus:: * Barmenus:: * Menu Sets and Menu Conns::  File: gcl-dwdoc.info, Node: Picmenus, Next: Barmenus, Up: Menus 3.1 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.  File: gcl-dwdoc.info, Node: Barmenus, Next: Menu Sets and Menu Conns, Prev: Picmenus, Up: Menus 3.2 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.  File: gcl-dwdoc.info, Node: Menu Sets and Menu Conns, Prev: Barmenus, Up: Menus 3.3 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’.  File: gcl-dwdoc.info, Node: Windows, Next: Drawing Functions, Prev: Menus, Up: Top 4 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)’  File: gcl-dwdoc.info, Node: Drawing Functions, Next: Fonts Operations Colors, Prev: Windows, Up: Top 5 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.  File: gcl-dwdoc.info, Node: Fonts Operations Colors, Next: Mouse Interaction, Prev: Drawing Functions, Up: Top 6 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)’ * Menu: * Color:: * Character Input:: * Emacs-like Editing::  File: gcl-dwdoc.info, Node: Color, Next: Character Input, Up: Fonts Operations Colors 6.1 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.  File: gcl-dwdoc.info, Node: Character Input, Next: Emacs-like Editing, Prev: Color, Up: Fonts Operations Colors 6.2 Character Input =================== 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.  File: gcl-dwdoc.info, Node: Emacs-like Editing, Prev: Character Input, Up: Fonts Operations Colors 6.3 Emacs-like Editing ====================== ‘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"))  File: gcl-dwdoc.info, Node: Mouse Interaction, Next: Miscellaneous Functions, Prev: Fonts Operations Colors, Up: Top 7 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 LaTeX can draw; if ‘flg’ is non-‘nil’, the slope is restricted to be a LaTeX ‘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.  File: gcl-dwdoc.info, Node: Miscellaneous Functions, Next: Examples, Prev: Mouse Interaction, Up: Top 8 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.  File: gcl-dwdoc.info, Node: Examples, Next: Web Interface, Prev: Miscellaneous Functions, Up: Top 9 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.  File: gcl-dwdoc.info, Node: Web Interface, Next: Files, Prev: Examples, Up: Top 10 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’  File: gcl-dwdoc.info, Node: Files, Next: Data Types, Prev: Web Interface, Up: Top 11 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’ LaTeX 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’  File: gcl-dwdoc.info, Node: Data Types, Next: Copyright, Prev: Files, Up: Top 12 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)))  File: gcl-dwdoc.info, Node: Copyright, Prev: Data Types, Up: Top 13 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. ;;*****************************************************************  Tag Table: Node: Top415 Node: Introduction1126 Ref: #introduction1255 Node: Examples and Utilities3186 Ref: #examples-and-utilities3337 Node: dwtest3389 Ref: #dwtest3502 Node: pcalc3880 Ref: #pcalc4004 Node: draw4109 Ref: #draw4232 Node: editors4743 Ref: #editors4858 Node: Menus5332 Ref: #menus5444 Node: Picmenus9385 Ref: #picmenus9482 Node: Barmenus12220 Ref: #barmenus12350 Node: Menu Sets and Menu Conns13123 Ref: #menu-sets-and-menu-conns13268 Node: Windows15988 Ref: #windows16099 Node: Drawing Functions17724 Ref: #drawing-functions17873 Node: Fonts Operations Colors20669 Ref: #fonts-operations-colors20844 Node: Color22290 Ref: #color22403 Node: Character Input23682 Ref: #texted23842 Node: Emacs-like Editing24449 Ref: #emacsed24601 Node: Mouse Interaction25338 Ref: #mouse-interaction25503 Node: Miscellaneous Functions30523 Ref: #miscellaneous-functions30685 Node: Examples31098 Ref: #examples31226 Node: Web Interface31400 Ref: #web-interface31522 Node: Files31848 Ref: #files31956 Node: Data Types33205 Ref: #data-types33319 Node: Copyright36108 Ref: #copyright36206  End Tag Table  Local Variables: coding: utf-8 End: gcl-2.7.1/info/PaxHeaders/chap-13.texi0000644000000000000000000000013214542551763014342 xustar0030 mtime=1703597043.228022784 30 atime=1744294999.601960624 30 ctime=1744351535.602908142 gcl-2.7.1/info/chap-13.texi0000644000175000017500000014335114542551763013747 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-18.texi0000644000000000000000000000013214542551763014347 xustar0030 mtime=1703597043.240022802 30 atime=1744294999.609960659 30 ctime=1744351535.606908106 gcl-2.7.1/info/chap-18.texi0000644000175000017500000010176514542551763013757 0ustar00cammcamm @node Hash Tables, Filenames, Sequences, Top @chapter Hash Tables @menu * Hash Table Concepts:: * Hash Tables Dictionary:: @end menu @node Hash Table Concepts, Hash Tables Dictionary, Hash Tables, Hash Tables @section Hash Table Concepts @c including concept-hash-tables @menu * Hash-Table Operations:: * Modifying Hash Table Keys:: @end menu @node Hash-Table Operations, Modifying Hash Table Keys, Hash Table Concepts, Hash Table Concepts @subsection Hash-Table Operations Figure 18--1 lists some @i{defined names} that are applicable to @i{hash tables}. The following rules apply to @i{hash tables}. @table @asis @item -- A @i{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 @i{hash table} is a destructive operation; the @i{hash table} is modified. @item -- There are four kinds of @i{hash tables}: those whose keys are compared with @b{eq}, those whose keys are compared with @b{eql}, those whose keys are compared with @b{equal}, and those whose keys are compared with @b{equalp}. @item -- @i{Hash tables} are created by @b{make-hash-table}. @b{gethash} is used to look up a key and find the associated value. New entries are added to @i{hash tables} using @b{setf} with @b{gethash}. @b{remhash} is used to remove an entry. For example: @example (setq a (make-hash-table)) @result{} # (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.7.1/info/PaxHeaders/general.texi0000644000000000000000000000013214542551763014623 xustar0030 mtime=1703597043.256022827 30 atime=1744294999.609960659 30 ctime=1744351535.626907927 gcl-2.7.1/info/general.texi0000755000175000017500000006303314542551763014231 0ustar00cammcamm@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} funcions (@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.7.1/info/PaxHeaders/structure.texi0000644000000000000000000000013214542551763015246 xustar0030 mtime=1703597043.256022827 30 atime=1744294999.613960677 30 ctime=1744351535.630907891 gcl-2.7.1/info/structure.texi0000755000175000017500000000252114542551763014647 0ustar00cammcamm@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.7.1/info/PaxHeaders/gcl.info0000644000000000000000000000013114776130461013731 xustar0030 mtime=1744351537.790888543 30 atime=1744351537.786888579 29 ctime=1744351538.78287967 gcl-2.7.1/info/gcl.info0000644000175000017500000014346614776130461013346 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 300673 gcl.info-3: 600586 gcl.info-4: 904020 gcl.info-5: 1201894 gcl.info-6: 1501104 gcl.info-7: 1802018 gcl.info-8: 2102858 gcl.info-9: 2400458  Tag Table: (Indirect) Node: Top314 Node: Introduction (Introduction)41180 Node: Scope41532 Node: Scope and Purpose41780 Node: History42223 Node: Organization of the Document51794 Node: Referenced Publications54049 Node: Definitions57706 Node: Notational Conventions58098 Node: Font Key58727 Node: Modified BNF Syntax60568 Node: Splicing in Modified BNF Syntax60943 Node: Indirection in Modified BNF Syntax63439 Node: Additional Uses for Indirect Definitions in Modified BNF Syntax64087 Node: Special Symbols65271 Node: Objects with Multiple Notations70068 Node: Case in Symbols70512 Node: Numbers (Objects with Multiple Notations)71682 Node: Use of the Dot Character72082 Node: NIL73024 Node: Designators75082 Node: Nonsense Words77493 Node: Error Terminology78172 Node: Sections Not Formally Part Of This Standard85495 Node: Interpreting Dictionary Entries87005 Node: The "Affected By" Section of a Dictionary Entry89404 Node: The "Arguments" Section of a Dictionary Entry89937 Node: The "Arguments and Values" Section of a Dictionary Entry90459 Node: The "Binding Types Affected" Section of a Dictionary Entry91222 Node: The "Class Precedence List" Section of a Dictionary Entry91910 Node: Dictionary Entries for Type Specifiers93086 Node: The "Compound Type Specifier Kind" Section of a Dictionary Entry94228 Node: The "Compound Type Specifier Syntax" Section of a Dictionary Entry95279 Node: The "Compound Type Specifier Arguments" Section of a Dictionary Entry95955 Node: The "Compound Type Specifier Description" Section of a Dictionary Entry96522 Node: The "Constant Value" Section of a Dictionary Entry97073 Node: The "Description" Section of a Dictionary Entry97527 Node: The "Examples" Section of a Dictionary Entry98052 Node: The "Exceptional Situations" Section of a Dictionary Entry98541 Node: The "Initial Value" Section of a Dictionary Entry99382 Node: The "Argument Precedence Order" Section of a Dictionary Entry99906 Node: The "Method Signature" Section of a Dictionary Entry100434 Node: The "Name" Section of a Dictionary Entry101970 Node: The "Notes" Section of a Dictionary Entry104030 Node: The "Pronunciation" Section of a Dictionary Entry104740 Node: The "See Also" Section of a Dictionary Entry105555 Node: The "Side Effects" Section of a Dictionary Entry106030 Node: The "Supertypes" Section of a Dictionary Entry106462 Node: The "Syntax" Section of a Dictionary Entry107099 Node: Special "Syntax" Notations for Overloaded Operators108288 Node: Naming Conventions for Rest Parameters109441 Node: Requiring Non-Null Rest Parameters in The "Syntax" Section110300 Node: Return values in The "Syntax" Section111200 Node: No Arguments or Values in The "Syntax" Section111890 Node: Unconditional Transfer of Control in The "Syntax" Section112491 Node: The "Valid Context" Section of a Dictionary Entry113061 Node: The "Value Type" Section of a Dictionary Entry113702 Node: Conformance114057 Node: Conforming Implementations114473 Node: Required Language Features115078 Node: Documentation of Implementation-Dependent Features115707 Node: Documentation of Extensions116434 Node: Treatment of Exceptional Situations117077 Node: Resolution of Apparent Conflicts in Exceptional Situations117476 Node: Examples of Resolution of Apparent Conflict in Exceptional Situations118146 Node: Conformance Statement119150 Node: Conforming Programs120133 Node: Use of Implementation-Defined Language Features121094 Node: Use of Read-Time Conditionals122310 Node: Language Extensions123461 Node: Language Subsets125874 Node: Deprecated Language Features126591 Node: Deprecated Functions127432 Node: Deprecated Argument Conventions127991 Node: Deprecated Variables129001 Node: Deprecated Reader Syntax129250 Node: Symbols in the COMMON-LISP Package129721 Node: Syntax152233 Node: Character Syntax152477 Node: Readtables153230 Node: The Current Readtable154064 Node: The Standard Readtable154649 Node: The Initial Readtable155186 Node: Variables that affect the Lisp Reader155641 Node: Standard Characters156195 Node: Character Syntax Types160645 Node: Constituent Characters164581 Node: Constituent Traits165196 Node: Invalid Characters168740 Node: Macro Characters169288 Node: Multiple Escape Characters172062 Node: Examples of Multiple Escape Characters172717 Node: Single Escape Character173222 Node: Examples of Single Escape Characters173717 Node: Whitespace Characters174211 Node: Examples of Whitespace Characters174560 Node: Reader Algorithm174926 Node: Interpretation of Tokens181432 Node: Numbers as Tokens181792 Node: Potential Numbers as Tokens182896 Node: Escape Characters and Potential Numbers185486 Node: Examples of Potential Numbers186251 Node: Constructing Numbers from Tokens187377 Node: Syntax of a Rational188178 Node: Syntax of an Integer188393 Node: Syntax of a Ratio188984 Node: Syntax of a Float190114 Node: Syntax of a Complex192612 Node: The Consing Dot193668 Node: Symbols as Tokens194192 Node: Valid Patterns for Tokens197687 Node: Package System Consistency Rules201027 Node: Standard Macro Characters202688 Node: Left-Parenthesis203460 Node: Right-Parenthesis204990 Node: Single-Quote205317 Node: Examples of Single-Quote205775 Node: Semicolon206012 Node: Examples of Semicolon206576 Node: Notes about Style for Semicolon206803 Node: Use of Single Semicolon207220 Node: Use of Double Semicolon207811 Node: Use of Triple Semicolon208309 Node: Use of Quadruple Semicolon208689 Node: Examples of Style for Semicolon209199 Node: Double-Quote210172 Node: Backquote211618 Node: Notes about Backquote215542 Node: Comma216613 Node: Sharpsign216904 Node: Sharpsign Backslash221458 Node: Sharpsign Single-Quote222621 Node: Sharpsign Left-Parenthesis223094 Node: Sharpsign Asterisk224614 Node: Examples of Sharpsign Asterisk225878 Node: Sharpsign Colon226296 Node: Sharpsign Dot226812 Node: Sharpsign B227490 Node: Sharpsign O227881 Node: Sharpsign X228288 Node: Sharpsign R228794 Node: Sharpsign C230089 Node: Sharpsign A231168 Node: Sharpsign S232365 Node: Sharpsign P233472 Node: Sharpsign Equal-Sign233889 Node: Sharpsign Sharpsign234410 Node: Sharpsign Plus235479 Node: Sharpsign Minus236521 Node: Sharpsign Vertical-Bar236881 Node: Examples of Sharpsign Vertical-Bar237248 Node: Notes about Style for Sharpsign Vertical-Bar240239 Node: Sharpsign Less-Than-Sign241209 Node: Sharpsign Whitespace241647 Node: Sharpsign Right-Parenthesis242034 Node: Re-Reading Abbreviated Expressions242334 Node: Evaluation and Compilation242827 Node: Evaluation243208 Node: Introduction to Environments244496 Node: The Global Environment245354 Node: Dynamic Environments246005 Node: Lexical Environments247164 Node: The Null Lexical Environment248389 Node: Environment Objects248903 Node: The Evaluation Model249870 Node: Form Evaluation250565 Node: Symbols as Forms250868 Node: Lexical Variables252916 Node: Dynamic Variables253947 Node: Constant Variables255692 Node: Symbols Naming Both Lexical and Dynamic Variables256408 Node: Conses as Forms257260 Node: Special Forms258207 Node: Macro Forms259721 Node: Function Forms261547 Node: Lambda Forms263997 Node: Self-Evaluating Objects264655 Node: Examples of Self-Evaluating Objects265377 Node: Lambda Expressions265838 Node: Closures and Lexical Binding266477 Node: Shadowing270233 Node: Extent273405 Node: Return Values275671 Node: Compilation277013 Node: Compiler Terminology277320 Node: Compilation Semantics281613 Node: Compiler Macros282296 Node: Purpose of Compiler Macros283957 Node: Naming of Compiler Macros285672 Node: When Compiler Macros Are Used286650 Node: Notes about the Implementation of Compiler Macros288291 Node: Minimal Compilation289408 Node: Semantic Constraints290584 Node: File Compilation294238 Node: Processing of Top Level Forms296211 Node: Processing of Defining Macros300673 Node: Constraints on Macros and Compiler Macros303180 Node: Literal Objects in Compiled Files303980 Node: Externalizable Objects305390 Node: Similarity of Literal Objects307018 Node: Similarity of Aggregate Objects307262 Node: Definition of Similarity307846 Node: Extensions to Similarity Rules312714 Node: Additional Constraints on Externalizable Objects313590 Node: Exceptional Situations in the Compiler318327 Node: Declarations320426 Node: Minimal Declaration Processing Requirements321213 Node: Declaration Specifiers322379 Node: Declaration Identifiers322881 Node: Shorthand notation for Type Declarations323697 Node: Declaration Scope324064 Node: Examples of Declaration Scope326037 Node: Lambda Lists329237 Node: Ordinary Lambda Lists331669 Node: Specifiers for the required parameters334135 Node: Specifiers for optional parameters334985 Node: A specifier for a rest parameter336166 Node: Specifiers for keyword parameters337171 Node: Suppressing Keyword Argument Checking341194 Node: Examples of Suppressing Keyword Argument Checking341885 Node: Specifiers for &aux variables343127 Node: Examples of Ordinary Lambda Lists343978 Node: Generic Function Lambda Lists347919 Node: Specialized Lambda Lists349247 Node: Macro Lambda Lists350554 Node: Destructuring by Lambda Lists355840 Node: Data-directed Destructuring by Lambda Lists357031 Node: Examples of Data-directed Destructuring by Lambda Lists357578 Node: Lambda-list-directed Destructuring by Lambda Lists358291 Node: Destructuring Lambda Lists361352 Node: Boa Lambda Lists362584 Node: Defsetf Lambda Lists366462 Node: Deftype Lambda Lists367377 Node: Define-modify-macro Lambda Lists367995 Node: Define-method-combination Arguments Lambda Lists368863 Node: Syntactic Interaction of Documentation Strings and Declarations369709 Node: Error Checking in Function Calls370460 Node: Argument Mismatch Detection370731 Node: Safe and Unsafe Calls371220 Node: Error Detection Time in Safe Calls373983 Node: Too Few Arguments374566 Node: Too Many Arguments375091 Node: Unrecognized Keyword Arguments375739 Node: Invalid Keyword Arguments376359 Node: Odd Number of Keyword Arguments376963 Node: Destructuring Mismatch377549 Node: Errors When Calling a Next Method378086 Node: Traversal Rules and Side Effects379061 Node: Destructive Operations380307 Node: Modification of Literal Objects380632 Node: Transfer of Control during a Destructive Operation383030 Node: Examples of Transfer of Control during a Destructive Operation383527 Node: Evaluation and Compilation Dictionary384409 Node: lambda (Symbol)385092 Node: lambda386294 Node: compile387416 Node: eval390637 Node: eval-when392579 Node: load-time-value399022 Node: quote404840 Node: compiler-macro-function406424 Node: define-compiler-macro407395 Node: defmacro414887 Node: macro-function421070 Node: macroexpand423326 Node: define-symbol-macro428393 Node: symbol-macrolet430959 Node: *macroexpand-hook*434090 Node: proclaim436356 Node: declaim438480 Node: declare439293 Node: ignore443327 Node: dynamic-extent445364 Node: type451758 Node: inline458535 Node: ftype462361 Node: declaration463895 Node: optimize464823 Node: special466980 Node: locally471468 Node: the473644 Node: special-operator-p476052 Node: constantp476973 Node: Types and Classes480013 Node: Introduction (Types and Classes)480275 Node: Types482433 Node: Data Type Definition482645 Node: Type Relationships483787 Node: Type Specifiers485712 Node: Classes493953 Node: Introduction to Classes494815 Node: Standard Metaclasses499543 Node: Defining Classes500502 Node: Creating Instances of Classes502174 Node: Inheritance502965 Node: Examples of Inheritance503429 Node: Inheritance of Class Options504406 Node: Determining the Class Precedence List505226 Node: Topological Sorting507286 Node: Examples of Class Precedence List Determination509719 Node: Redefining Classes513273 Node: Modifying the Structure of Instances516377 Node: Initializing Newly Added Local Slots (Redefining Classes)517562 Node: Customizing Class Redefinition519463 Node: Integrating Types and Classes520542 Node: Types and Classes Dictionary526807 Node: nil (Type)527576 Node: boolean528032 Node: function (System Class)528832 Node: compiled-function533548 Node: generic-function534387 Node: standard-generic-function535424 Node: class535947 Node: built-in-class536483 Node: structure-class537409 Node: standard-class537824 Node: method538222 Node: standard-method539361 Node: structure-object539792 Node: standard-object540391 Node: method-combination540829 Node: t (System Class)541488 Node: satisfies541854 Node: member (Type Specifier)543027 Node: not (Type Specifier)544042 Node: and (Type Specifier)544758 Node: or (Type Specifier)545596 Node: values (Type Specifier)546627 Node: eql (Type Specifier)547894 Node: coerce548669 Node: deftype553331 Node: subtypep556484 Node: type-of563450 Node: typep566367 Node: type-error569776 Node: type-error-datum570479 Node: simple-type-error571825 Node: Data and Control Flow572569 Node: Generalized Reference572834 Node: Overview of Places and Generalized Reference573161 Node: Evaluation of Subforms to Places575480 Node: Examples of Evaluation of Subforms to Places577985 Node: Setf Expansions578711 Node: Examples of Setf Expansions580781 Node: Kinds of Places582666 Node: Variable Names as Places583304 Node: Function Call Forms as Places583582 Node: VALUES Forms as Places591704 Node: THE Forms as Places592842 Node: APPLY Forms as Places593301 Node: Setf Expansions and Places594670 Node: Macro Forms as Places595090 Node: Symbol Macros as Places595624 Node: Other Compound Forms as Places596003 Node: Treatment of Other Macros Based on SETF597034 Node: Transfer of Control to an Exit Point598451 Node: Data and Control Flow Dictionary600586 Node: apply601820 Node: defun603853 Node: fdefinition607600 Node: fboundp609447 Node: fmakunbound611260 Node: flet612245 Node: funcall620119 Node: function (Special Operator)621828 Node: function-lambda-expression623911 Node: functionp627159 Node: compiled-function-p628117 Node: call-arguments-limit629264 Node: lambda-list-keywords629897 Node: lambda-parameters-limit630640 Node: defconstant631291 Node: defparameter634137 Node: destructuring-bind640716 Node: let642039 Node: progv645358 Node: setq646867 Node: psetq648555 Node: block650545 Node: catch652357 Node: go655050 Node: return-from656492 Node: return658776 Node: tagbody659769 Node: throw662181 Node: unwind-protect664850 Node: nil670087 Node: not670482 Node: t671332 Node: eq672319 Node: eql674742 Node: equal677723 Node: equalp681330 Node: identity685272 Node: complement686031 Node: constantly687735 Node: every688709 Node: and691704 Node: cond693464 Node: if695109 Node: or696366 Node: when697782 Node: case700382 Node: typecase705491 Node: multiple-value-bind711071 Node: multiple-value-call712938 Node: multiple-value-list714194 Node: multiple-value-prog1715015 Node: multiple-value-setq715972 Node: values717586 Node: values-list719522 Node: multiple-values-limit720504 Node: nth-value721330 Node: prog722623 Node: prog1726375 Node: progn728534 Node: define-modify-macro729921 Node: defsetf732405 Node: define-setf-expander738548 Node: get-setf-expansion743384 Node: setf745138 Node: shiftf747602 Node: rotatef750209 Node: control-error751930 Node: program-error752551 Node: undefined-function753097 Node: Iteration753702 Node: The LOOP Facility753876 Node: Overview of the Loop Facility754342 Node: Simple vs Extended Loop755123 Node: Simple Loop755424 Node: Extended Loop756117 Node: Loop Keywords756748 Node: Parsing Loop Clauses757682 Node: Expanding Loop Forms759305 Node: Summary of Loop Clauses762002 Node: Summary of Variable Initialization and Stepping Clauses762303 Node: Summary of Value Accumulation Clauses763136 Node: Summary of Termination Test Clauses764926 Node: Summary of Unconditional Execution Clauses766633 Node: Summary of Conditional Execution Clauses767353 Node: Summary of Miscellaneous Clauses768445 Node: Order of Execution769138 Node: Destructuring771010 Node: Restrictions on Side-Effects775430 Node: Variable Initialization and Stepping Clauses775667 Node: Iteration Control776519 Node: The for-as-arithmetic subclause779433 Node: Examples of for-as-arithmetic subclause783281 Node: The for-as-in-list subclause784034 Node: Examples of for-as-in-list subclause784828 Node: The for-as-on-list subclause785617 Node: Examples of for-as-on-list subclause786370 Node: The for-as-equals-then subclause786991 Node: Examples of for-as-equals-then subclause787749 Node: The for-as-across subclause788206 Node: Examples of for-as-across subclause788908 Node: The for-as-hash subclause789295 Node: The for-as-package subclause791517 Node: Examples of for-as-package subclause794081 Node: Local Variable Initializations794702 Node: Examples of WITH clause797545 Node: Value Accumulation Clauses798587 Node: Examples of COLLECT clause804424 Node: Examples of APPEND and NCONC clauses805177 Node: Examples of COUNT clause805798 Node: Examples of MAXIMIZE and MINIMIZE clauses806120 Node: Examples of SUM clause806991 Node: Termination Test Clauses807397 Node: Examples of REPEAT clause811567 Node: Examples of ALWAYS812094 Node: Examples of WHILE and UNTIL clauses814117 Node: Unconditional Execution Clauses814912 Node: Examples of unconditional execution815805 Node: Conditional Execution Clauses816302 Node: Examples of WHEN clause818007 Node: Miscellaneous Clauses819686 Node: Control Transfer Clauses820001 Node: Examples of NAMED clause820829 Node: Initial and Final Execution821220 Node: Examples of Miscellaneous Loop Features822849 Node: Examples of clause grouping823919 Node: Notes about Loop826366 Node: Iteration Dictionary827388 Node: do827593 Node: dotimes836034 Node: dolist839489 Node: loop841711 Node: loop-finish847171 Node: Objects849997 Node: Object Creation and Initialization850301 Node: Initialization Arguments854213 Node: Declaring the Validity of Initialization Arguments856820 Node: Defaulting of Initialization Arguments860319 Node: Rules for Initialization Arguments863590 Node: Shared-Initialize867442 Node: Initialize-Instance870124 Node: Definitions of Make-Instance and Initialize-Instance872859 Node: Changing the Class of an Instance874957 Node: Modifying the Structure of the Instance876209 Node: Initializing Newly Added Local Slots (Changing the Class of an Instance)877147 Node: Customizing the Change of Class of an Instance878884 Node: Reinitializing an Instance879687 Node: Customizing Reinitialization881150 Node: Meta-Objects881814 Node: Standard Meta-objects882340 Node: Slots883379 Node: Introduction to Slots883603 Node: Accessing Slots886241 Node: Inheritance of Slots and Slot Options888818 Node: Generic Functions and Methods893560 Node: Introduction to Generic Functions894055 Node: Introduction to Methods897558 Node: Agreement on Parameter Specializers and Qualifiers904020 Node: Congruent Lambda-lists for all Methods of a Generic Function905017 Node: Keyword Arguments in Generic Functions and Methods907159 Node: Examples of Keyword Arguments in Generic Functions and Methods908851 Node: Method Selection and Combination910190 Node: Determining the Effective Method911656 Node: Selecting the Applicable Methods912250 Node: Sorting the Applicable Methods by Precedence Order912591 Node: Applying method combination to the sorted list of applicable methods914656 Node: Standard Method Combination916823 Node: Declarative Method Combination921770 Node: Built-in Method Combination Types922681 Node: Inheritance of Methods926755 Node: Objects Dictionary927326 Node: function-keywords928334 Node: ensure-generic-function929961 Node: allocate-instance933269 Node: reinitialize-instance934796 Node: shared-initialize937031 Node: update-instance-for-different-class941539 Node: update-instance-for-redefined-class945677 Node: change-class950951 Node: slot-boundp954973 Node: slot-exists-p956755 Node: slot-makunbound957557 Node: slot-missing959095 Node: slot-unbound961434 Node: slot-value963106 Node: method-qualifiers965917 Node: no-applicable-method966714 Node: no-next-method967839 Node: remove-method969042 Node: make-instance969864 Node: make-instances-obsolete971279 Node: make-load-form972594 Node: make-load-form-saving-slots984111 Node: with-accessors986059 Node: with-slots989000 Node: defclass992371 Node: defgeneric1004581 Node: defmethod1015268 Node: find-class1022161 Node: next-method-p1024140 Node: call-method1025245 Node: call-next-method1028261 Node: compute-applicable-methods1031322 Node: define-method-combination1032384 Node: find-method1056137 Node: add-method1058794 Node: initialize-instance1060028 Node: class-name1061820 Node: setf class-name1062577 Node: class-of1063206 Node: unbound-slot1064210 Node: unbound-slot-instance1064878 Node: Structures1065446 Node: Structures Dictionary1065591 Node: defstruct1065771 Node: copy-structure1106547 Node: Conditions1107143 Node: Condition System Concepts1107318 Node: Condition Types1110927 Node: Serious Conditions1113346 Node: Creating Conditions1113727 Node: Condition Designators1114280 Node: Printing Conditions1116120 Node: Recommended Style in Condition Reporting1117463 Node: Capitalization and Punctuation in Condition Reports1118592 Node: Leading and Trailing Newlines in Condition Reports1119315 Node: Embedded Newlines in Condition Reports1120277 Node: Note about Tabs in Condition Reports1121450 Node: Mentioning Containing Function in Condition Reports1122075 Node: Signaling and Handling Conditions1122560 Node: Signaling1124826 Node: Resignaling a Condition1126016 Node: Restarts1127076 Node: Interactive Use of Restarts1129253 Node: Interfaces to Restarts1130449 Node: Restart Tests1131345 Node: Associating a Restart with a Condition1131825 Node: Assertions1132724 Node: Notes about the Condition System`s Background1133221 Node: Conditions Dictionary1133712 Node: condition1134727 Node: warning1136521 Node: style-warning1136878 Node: serious-condition1138082 Node: error (Condition Type)1139315 Node: cell-error1139680 Node: cell-error-name1140286 Node: parse-error1141281 Node: storage-condition1141751 Node: assert1143337 Node: error1147298 Node: cerror1150994 Node: check-type1156124 Node: simple-error1160414 Node: invalid-method-error1160913 Node: method-combination-error1162470 Node: signal1163600 Node: simple-condition1166161 Node: simple-condition-format-control1167090 Node: warn1168470 Node: simple-warning1170904 Node: invoke-debugger1171377 Node: break1172879 Node: *debugger-hook*1175321 Node: *break-on-signals*1177816 Node: handler-bind1180456 Node: handler-case1183047 Node: ignore-errors1188248 Node: define-condition1190142 Node: make-condition1201894 Node: restart1203203 Node: compute-restarts1203835 Node: find-restart1206600 Node: invoke-restart1208605 Node: invoke-restart-interactively1210346 Node: restart-bind1212665 Node: restart-case1216713 Node: restart-name1226531 Node: with-condition-restarts1227497 Node: with-simple-restart1228834 Node: abort (Restart)1232322 Node: continue1233316 Node: muffle-warning1234477 Node: store-value1236100 Node: use-value1237337 Node: abort (Function)1237974 Node: Symbols1244311 Node: Symbol Concepts1244467 Node: Symbols Dictionary1245054 Node: symbol1245484 Node: keyword1250497 Node: symbolp1251097 Node: keywordp1251851 Node: make-symbol1252735 Node: copy-symbol1254350 Node: gensym1256795 Node: *gensym-counter*1259107 Node: gentemp1259877 Node: symbol-function1262729 Node: symbol-name1265698 Node: symbol-package1266401 Node: symbol-plist1268258 Node: symbol-value1269474 Node: get1271489 Node: remprop1274749 Node: boundp1277377 Node: makunbound1278371 Node: set1279138 Node: unbound-variable1280882 Node: Packages1281453 Node: Package Concepts1281620 Node: Introduction to Packages1281833 Node: Package Names and Nicknames1283633 Node: Symbols in a Package1284404 Node: Internal and External Symbols1284617 Node: Package Inheritance1285532 Node: Accessibility of Symbols in a Package1286482 Node: Locating a Symbol in a Package1288095 Node: Prevention of Name Conflicts in Packages1288714 Node: Standardized Packages1292078 Node: The COMMON-LISP Package1293018 Node: Constraints on the COMMON-LISP Package for Conforming Implementations1294353 Node: Constraints on the COMMON-LISP Package for Conforming Programs1295899 Node: Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs1298010 Node: The COMMON-LISP-USER Package1299857 Node: The KEYWORD Package1300456 Node: Interning a Symbol in the KEYWORD Package1301319 Node: Notes about The KEYWORD Package1301909 Node: Implementation-Defined Packages1302832 Node: Packages Dictionary1303401 Node: package1304073 Node: export1304526 Node: find-symbol1307608 Node: find-package1310037 Node: find-all-symbols1311063 Node: import1312059 Node: list-all-packages1314566 Node: rename-package1315240 Node: shadow1316528 Node: shadowing-import1318907 Node: delete-package1320839 Node: make-package1325858 Node: with-package-iterator1327910 Node: unexport1333557 Node: unintern1335117 Node: in-package1337212 Node: unuse-package1338185 Node: use-package1339602 Node: defpackage1341691 Node: do-symbols1350040 Node: intern1353622 Node: package-name1355967 Node: package-nicknames1357023 Node: package-shadowing-symbols1357802 Node: package-use-list1359034 Node: package-used-by-list1359932 Node: packagep1360806 Node: *package*1361459 Node: package-error1362832 Node: package-error-package1363491 Node: Numbers (Numbers)1364189 Node: Number Concepts1364355 Node: Numeric Operations1364733 Node: Associativity and Commutativity in Numeric Operations1366757 Node: Examples of Associativity and Commutativity in Numeric Operations1367880 Node: Contagion in Numeric Operations1369540 Node: Viewing Integers as Bits and Bytes1370057 Node: Logical Operations on Integers1370311 Node: Byte Operations on Integers1371392 Node: Implementation-Dependent Numeric Constants1372189 Node: Rational Computations1373377 Node: Rule of Unbounded Rational Precision1373789 Node: Rule of Canonical Representation for Rationals1374244 Node: Rule of Float Substitutability1375355 Node: Floating-point Computations1377758 Node: Rule of Float and Rational Contagion1378238 Node: Examples of Rule of Float and Rational Contagion1379135 Node: Rule of Float Approximation1380199 Node: Rule of Float Underflow and Overflow1381381 Node: Rule of Float Precision Contagion1381823 Node: Complex Computations1382174 Node: Rule of Complex Substitutability1382661 Node: Rule of Complex Contagion1383062 Node: Rule of Canonical Representation for Complex Rationals1383469 Node: Examples of Rule of Canonical Representation for Complex Rationals1384333 Node: Principal Values and Branch Cuts1384998 Node: Interval Designators1387034 Node: Random-State Operations1388549 Node: Numbers Dictionary1388900 Node: number1390271 Node: complex (System Class)1391433 Node: real1393677 Node: float (System Class)1394836 Node: short-float1397498 Node: rational (System Class)1401489 Node: ratio1402525 Node: integer1403124 Node: signed-byte1404496 Node: unsigned-byte1405533 Node: mod (System Class)1406663 Node: bit (System Class)1407409 Node: fixnum1407770 Node: bignum1408261 Node: =1408567 Node: max1411973 Node: minusp1414051 Node: zerop1414983 Node: floor1415970 Node: sin1420833 Node: asin1421664 Node: pi1428500 Node: sinh1429610 Node: *1434158 Node: +1434996 Node: -1435797 Node: /1436958 Node: 1+1438589 Node: abs1439555 Node: evenp1441002 Node: exp1441920 Node: gcd1445121 Node: incf1446157 Node: lcm1447353 Node: log1448471 Node: mod (Function)1450640 Node: signum1451962 Node: sqrt1453634 Node: random-state1455719 Node: make-random-state1456564 Node: random1458507 Node: random-state-p1460008 Node: *random-state*1460781 Node: numberp1462211 Node: cis1462886 Node: complex1463462 Node: complexp1465115 Node: conjugate1465770 Node: phase1466549 Node: realpart1468109 Node: upgraded-complex-part-type1469108 Node: realp1470092 Node: numerator1470725 Node: rational (Function)1471790 Node: rationalp1473354 Node: ash1474023 Node: integer-length1475530 Node: integerp1477194 Node: parse-integer1477845 Node: boole1479962 Node: boole-11484483 Node: logand1485594 Node: logbitp1489575 Node: logcount1490770 Node: logtest1492189 Node: byte1493262 Node: deposit-field1494517 Node: dpb1495547 Node: ldb1496995 Node: ldb-test1498605 Node: mask-field1499446 Node: most-positive-fixnum1501104 Node: decode-float1501778 Node: float1507557 Node: floatp1508496 Node: most-positive-short-float1509130 Node: short-float-epsilon1513431 Node: arithmetic-error1514816 Node: arithmetic-error-operands1515570 Node: division-by-zero1516491 Node: floating-point-invalid-operation1516969 Node: floating-point-inexact1517757 Node: floating-point-overflow1518512 Node: floating-point-underflow1519021 Node: Characters1519504 Node: Character Concepts1519680 Node: Introduction to Characters1520174 Node: Introduction to Scripts and Repertoires1521581 Node: Character Scripts1521889 Node: Character Repertoires1522902 Node: Character Attributes1523813 Node: Character Categories1524821 Node: Graphic Characters1526044 Node: Alphabetic Characters1526971 Node: Characters With Case1527634 Node: Uppercase Characters1528088 Node: Lowercase Characters1528543 Node: Corresponding Characters in the Other Case1529017 Node: Case of Implementation-Defined Characters1529548 Node: Numeric Characters1530049 Node: Alphanumeric Characters1530557 Node: Digits in a Radix1530876 Node: Identity of Characters1531604 Node: Ordering of Characters1531874 Node: Character Names1533664 Node: Treatment of Newline during Input and Output1534807 Node: Character Encodings1535358 Node: Documentation of Implementation-Defined Scripts1536156 Node: Characters Dictionary1537627 Node: character (System Class)1538130 Node: base-char1538741 Node: standard-char1540725 Node: extended-char1541265 Node: char=1541726 Node: character1547890 Node: characterp1548769 Node: alpha-char-p1549707 Node: alphanumericp1550878 Node: digit-char1552273 Node: digit-char-p1553393 Node: graphic-char-p1554893 Node: standard-char-p1555779 Node: char-upcase1556627 Node: upper-case-p1559065 Node: char-code1560614 Node: char-int1561341 Node: code-char1562337 Node: char-code-limit1563099 Node: char-name1563759 Node: name-char1565683 Node: Conses1566561 Node: Cons Concepts1566709 Node: Conses as Trees1567246 Node: General Restrictions on Parameters that must be Trees1568215 Node: Conses as Lists1568649 Node: Lists as Association Lists1570049 Node: Lists as Sets1570577 Node: General Restrictions on Parameters that must be Lists1571128 Node: Conses Dictionary1571785 Node: list (System Class)1572547 Node: null (System Class)1573781 Node: cons (System Class)1574273 Node: atom (Type)1575503 Node: cons1575743 Node: consp1576660 Node: atom1577382 Node: rplaca1578089 Node: car1579229 Node: copy-tree1585615 Node: sublis1587244 Node: subst1590990 Node: tree-equal1595379 Node: copy-list1597162 Node: list (Function)1598484 Node: list-length1600112 Node: listp1602023 Node: make-list1602828 Node: push1603790 Node: pop1605036 Node: first1606335 Node: nth1609212 Node: endp1610271 Node: null1611672 Node: nconc1612482 Node: append1614623 Node: revappend1615757 Node: butlast1617949 Node: last1619785 Node: ldiff1621553 Node: nthcdr1625188 Node: rest1626323 Node: member (Function)1627307 Node: mapc1629610 Node: acons1633848 Node: assoc1634867 Node: copy-alist1638119 Node: pairlis1639397 Node: rassoc1640922 Node: get-properties1643056 Node: getf1644440 Node: remf1647311 Node: intersection1648666 Node: adjoin1652608 Node: pushnew1654554 Node: set-difference1657299 Node: set-exclusive-or1660676 Node: subsetp1663774 Node: union1665800 Node: Arrays1668901 Node: Array Concepts1669047 Node: Array Elements1669235 Node: Array Indices1669792 Node: Array Dimensions1670207 Node: Implementation Limits on Individual Array Dimensions1670797 Node: Array Rank1671222 Node: Vectors1671707 Node: Fill Pointers1671913 Node: Multidimensional Arrays1672645 Node: Storage Layout for Multidimensional Arrays1672856 Node: Implementation Limits on Array Rank1673370 Node: Specialized Arrays1673744 Node: Array Upgrading1675061 Node: Required Kinds of Specialized Arrays1676443 Node: Arrays Dictionary1677938 Node: array1678753 Node: simple-array1681805 Node: vector (System Class)1683758 Node: simple-vector1685858 Node: bit-vector1686871 Node: simple-bit-vector1687916 Node: make-array1688902 Node: adjust-array1697581 Node: adjustable-array-p1705592 Node: aref1706568 Node: array-dimension1708259 Node: array-dimensions1709126 Node: array-element-type1709980 Node: array-has-fill-pointer-p1711372 Node: array-displacement1712530 Node: array-in-bounds-p1714211 Node: array-rank1715392 Node: array-row-major-index1716170 Node: array-total-size1717694 Node: arrayp1718976 Node: fill-pointer1719739 Node: row-major-aref1720898 Node: upgraded-array-element-type1721996 Node: array-dimension-limit1723603 Node: array-rank-limit1724132 Node: array-total-size-limit1724626 Node: simple-vector-p1725394 Node: svref1726155 Node: vector1727229 Node: vector-pop1728135 Node: vector-push1729406 Node: vectorp1732238 Node: bit (Array)1732946 Node: bit-and1734292 Node: bit-vector-p1738490 Node: simple-bit-vector-p1739295 Node: Strings1740005 Node: String Concepts1740158 Node: Implications of Strings Being Arrays1740374 Node: Subtypes of STRING1740863 Node: Strings Dictionary1741270 Node: string (System Class)1741609 Node: base-string1742681 Node: simple-string1743631 Node: simple-base-string1744674 Node: simple-string-p1745588 Node: char1746349 Node: string1747896 Node: string-upcase1749163 Node: string-trim1753224 Node: string=1754871 Node: stringp1760411 Node: make-string1761032 Node: Sequences1761976 Node: Sequence Concepts1762173 Node: General Restrictions on Parameters that must be Sequences1763810 Node: Rules about Test Functions1764195 Node: Satisfying a Two-Argument Test1764464 Node: Examples of Satisfying a Two-Argument Test1766921 Node: Satisfying a One-Argument Test1768223 Node: Examples of Satisfying a One-Argument Test1770095 Node: Sequences Dictionary1770692 Node: sequence1771131 Node: copy-seq1771838 Node: elt1772999 Node: fill1774085 Node: make-sequence1775484 Node: subseq1777598 Node: map1779695 Node: map-into1782562 Node: reduce1785450 Node: count1788762 Node: length1790858 Node: reverse1791849 Node: sort1793997 Node: find1799450 Node: position1802018 Node: search1804179 Node: mismatch1806112 Node: replace1808424 Node: substitute1810739 Node: concatenate1816693 Node: merge1818871 Node: remove1823021 Node: remove-duplicates1829433 Node: Hash Tables1832943 Node: Hash Table Concepts1833119 Node: Hash-Table Operations1833351 Node: Modifying Hash Table Keys1835369 Node: Visible Modification of Objects with respect to EQ and EQL1837278 Node: Visible Modification of Objects with respect to EQUAL1837739 Node: Visible Modification of Conses with respect to EQUAL1838334 Node: Visible Modification of Bit Vectors and Strings with respect to EQUAL1838821 Node: Visible Modification of Objects with respect to EQUALP1839482 Node: Visible Modification of Structures with respect to EQUALP1840092 Node: Visible Modification of Arrays with respect to EQUALP1840573 Node: Visible Modification of Hash Tables with respect to EQUALP1841177 Node: Visible Modifications by Language Extensions1841886 Node: Hash Tables Dictionary1842646 Node: hash-table1843068 Node: make-hash-table1843845 Node: hash-table-p1846765 Node: hash-table-count1847512 Node: hash-table-rehash-size1848911 Node: hash-table-rehash-threshold1850429 Node: hash-table-size1851481 Node: hash-table-test1852259 Node: gethash1853122 Node: remhash1855289 Node: maphash1856137 Node: with-hash-table-iterator1857980 Node: clrhash1861417 Node: sxhash1862271 Node: Filenames1865253 Node: Overview of Filenames1865457 Node: Namestrings as Filenames1866256 Node: Pathnames as Filenames1867349 Node: Parsing Namestrings Into Pathnames1870698 Node: Pathnames1871440 Node: Pathname Components1871678 Node: The Pathname Host Component1872166 Node: The Pathname Device Component1872474 Node: The Pathname Directory Component1872855 Node: The Pathname Name Component1873204 Node: The Pathname Type Component1873521 Node: The Pathname Version Component1873934 Node: Interpreting Pathname Component Values1874583 Node: Strings in Component Values1875787 Node: Special Characters in Pathname Components1876058 Node: Case in Pathname Components1876962 Node: Local Case in Pathname Components1877749 Node: Common Case in Pathname Components1878548 Node: Special Pathname Component Values1879341 Node: NIL as a Component Value1879609 Node: ->WILD as a Component Value1880153 Node: ->UNSPECIFIC as a Component Value1881184 Node: Relation between component values NIL and ->UNSPECIFIC1882575 Node: Restrictions on Wildcard Pathnames1883422 Node: Restrictions on Examining Pathname Components1884285 Node: Restrictions on Examining a Pathname Host Component1885333 Node: Restrictions on Examining a Pathname Device Component1885772 Node: Restrictions on Examining a Pathname Directory Component1886476 Node: Directory Components in Non-Hierarchical File Systems1890002 Node: Restrictions on Examining a Pathname Name Component1890650 Node: Restrictions on Examining a Pathname Type Component1891077 Node: Restrictions on Examining a Pathname Version Component1891505 Node: Notes about the Pathname Version Component1892484 Node: Restrictions on Constructing Pathnames1893096 Node: Merging Pathnames1894638 Node: Examples of Merging Pathnames1895416 Node: Logical Pathnames1896296 Node: Syntax of Logical Pathname Namestrings1896535 Node: Additional Information about Parsing Logical Pathname Namestrings1898475 Node: The Host part of a Logical Pathname Namestring1898865 Node: The Device part of a Logical Pathname Namestring1899510 Node: The Directory part of a Logical Pathname Namestring1900041 Node: The Type part of a Logical Pathname Namestring1900639 Node: The Version part of a Logical Pathname Namestring1901134 Node: Wildcard Words in a Logical Pathname Namestring1901786 Node: Lowercase Letters in a Logical Pathname Namestring1902301 Node: Other Syntax in a Logical Pathname Namestring1902741 Node: Logical Pathname Components1903256 Node: Unspecific Components of a Logical Pathname1903563 Node: Null Strings as Components of a Logical Pathname1903995 Node: Filenames Dictionary1904357 Node: pathname (System Class)1904913 Node: logical-pathname (System Class)1905357 Node: pathname1905980 Node: make-pathname1908718 Node: pathnamep1913243 Node: pathname-host1914123 Node: load-logical-pathname-translations1918886 Node: logical-pathname-translations1920745 Node: logical-pathname1928794 Node: *default-pathname-defaults*1930166 Node: namestring1931389 Node: parse-namestring1935356 Node: wild-pathname-p1940118 Node: pathname-match-p1942251 Node: translate-logical-pathname1943474 Node: translate-pathname1946158 Node: merge-pathnames1952787 Node: Files1957429 Node: File System Concepts1957580 Node: Coercion of Streams to Pathnames1958564 Node: File Operations on Open and Closed Streams1959501 Node: Truenames1960741 Node: Examples of Truenames1961656 Node: Files Dictionary1963226 Node: directory1963543 Node: probe-file1965097 Node: ensure-directories-exist1966363 Node: truename1967994 Node: file-author1970636 Node: file-write-date1971667 Node: rename-file1972937 Node: delete-file1975471 Node: file-error1977278 Node: file-error-pathname1978037 Node: Streams1978586 Node: Stream Concepts1978736 Node: Introduction to Streams1979022 Node: Abstract Classifications of Streams (Introduction to Streams)1980229 Node: Input1980484 Node: Open and Closed Streams1982112 Node: Interactive Streams1983068 Node: Abstract Classifications of Streams1984464 Node: File Streams1984696 Node: Other Subclasses of Stream1985400 Node: Stream Variables1986616 Node: Stream Arguments to Standardized Functions1987900 Node: Restrictions on Composite Streams1990428 Node: Streams Dictionary1990935 Node: stream1992212 Node: broadcast-stream1992805 Node: concatenated-stream1995590 Node: echo-stream1996835 Node: file-stream1997591 Node: string-stream1998159 Node: synonym-stream1998782 Node: two-way-stream1999606 Node: input-stream-p2000162 Node: interactive-stream-p2001281 Node: open-stream-p2002370 Node: stream-element-type2003270 Node: streamp2004636 Node: read-byte2005299 Node: write-byte2006741 Node: peek-char2007866 Node: read-char2010678 Node: read-char-no-hang2012513 Node: terpri2014718 Node: unread-char2016286 Node: write-char2018259 Node: read-line2019144 Node: write-string2021165 Node: read-sequence2022765 Node: write-sequence2025066 Node: file-length2026693 Node: file-position2027735 Node: file-string-length2031602 Node: open2032383 Node: stream-external-format2042146 Node: with-open-file2043086 Node: close2046380 Node: with-open-stream2048547 Node: listen2049797 Node: clear-input2050918 Node: finish-output2052772 Node: y-or-n-p2054465 Node: make-synonym-stream2057114 Node: synonym-stream-symbol2058222 Node: broadcast-stream-streams2058747 Node: make-broadcast-stream2059293 Node: make-two-way-stream2060359 Node: two-way-stream-input-stream2061434 Node: echo-stream-input-stream2062285 Node: make-echo-stream2063051 Node: concatenated-stream-streams2064124 Node: make-concatenated-stream2064908 Node: get-output-stream-string2065811 Node: make-string-input-stream2067399 Node: make-string-output-stream2068566 Node: with-input-from-string2069693 Node: with-output-to-string2072253 Node: *debug-io*2074947 Node: *terminal-io*2079648 Node: stream-error2081164 Node: stream-error-stream2081813 Node: end-of-file2082558 Node: Printer2083048 Node: The Lisp Printer2083249 Node: Overview of The Lisp Printer2083532 Node: Multiple Possible Textual Representations2084234 Node: Printer Escaping2086358 Node: Printer Dispatching2087282 Node: Default Print-Object Methods2087848 Node: Printing Numbers2088759 Node: Printing Integers2088953 Node: Printing Ratios2089686 Node: Printing Floats2090436 Node: Printing Complexes2092071 Node: Note about Printing Numbers2092571 Node: Printing Characters2092919 Node: Printing Symbols2093858 Node: Package Prefixes for Symbols2095381 Node: Effect of Readtable Case on the Lisp Printer2097274 Node: Examples of Effect of Readtable Case on the Lisp Printer2099127 Node: Printing Strings2102858 Node: Printing Lists and Conses2103489 Node: Printing Bit Vectors2105935 Node: Printing Other Vectors2106584 Node: Printing Other Arrays2108082 Node: Examples of Printing Arrays2110343 Node: Printing Random States2111067 Node: Printing Pathnames2111952 Node: Printing Structures2112539 Node: Printing Other Objects2113481 Node: Examples of Printer Behavior2114357 Node: The Lisp Pretty Printer2115868 Node: Pretty Printer Concepts2116168 Node: Dynamic Control of the Arrangement of Output2117782 Node: Format Directive Interface2120823 Node: Compiling Format Strings2122073 Node: Pretty Print Dispatch Tables2122706 Node: Pretty Printer Margins2124310 Node: Examples of using the Pretty Printer2124807 Node: Notes about the Pretty Printer`s Background2136508 Node: Formatted Output2137029 Node: FORMAT Basic Output2141681 Node: Tilde C-> Character2142008 Node: Tilde Percent-> Newline2143820 Node: Tilde Ampersand-> Fresh-Line2144174 Node: Tilde Vertical-Bar-> Page2144584 Node: Tilde Tilde-> Tilde2144875 Node: FORMAT Radix Control2145084 Node: Tilde R-> Radix2145397 Node: Tilde D-> Decimal2146667 Node: Tilde B-> Binary2147982 Node: Tilde O-> Octal2148419 Node: Tilde X-> Hexadecimal2148857 Node: FORMAT Floating-Point Printers2149290 Node: Tilde F-> Fixed-Format Floating-Point2149687 Node: Tilde E-> Exponential Floating-Point2153778 Node: Tilde G-> General Floating-Point2158895 Node: Tilde Dollarsign-> Monetary Floating-Point2160262 Node: FORMAT Printer Operations2162528 Node: Tilde A-> Aesthetic2162827 Node: Tilde S-> Standard2164066 Node: Tilde W-> Write2164493 Node: FORMAT Pretty Printer Operations2165301 Node: Tilde Underscore-> Conditional Newline2165739 Node: Tilde Less-Than-Sign-> Logical Block2166231 Node: Tilde I-> Indent2169749 Node: Tilde Slash-> Call Function2170115 Node: FORMAT Layout Control2171975 Node: Tilde T-> Tabulate2172310 Node: Tilde Less-Than-Sign-> Justification2174535 Node: Tilde Greater-Than-Sign-> End of Justification2177951 Node: FORMAT Control-Flow Operations2178284 Node: Tilde Asterisk-> Go-To2178773 Node: Tilde Left-Bracket-> Conditional Expression2179666 Node: Tilde Right-Bracket-> End of Conditional Expression2182176 Node: Tilde Left-Brace-> Iteration2182577 Node: Tilde Right-Brace-> End of Iteration2185861 Node: Tilde Question-Mark-> Recursive Processing2186216 Node: FORMAT Miscellaneous Operations2187573 Node: Tilde Left-Paren-> Case Conversion2187936 Node: Tilde Right-Paren-> End of Case Conversion2189225 Node: Tilde P-> Plural2189579 Node: FORMAT Miscellaneous Pseudo-Operations2190361 Node: Tilde Semicolon-> Clause Separator2190759 Node: Tilde Circumflex-> Escape Upward2191144 Node: Tilde Newline-> Ignored Newline2194588 Node: Additional Information about FORMAT Operations2196000 Node: Nesting of FORMAT Operations2196444 Node: Missing and Additional FORMAT Arguments2197835 Node: Additional FORMAT Parameters2198328 Node: Undefined FORMAT Modifier Combinations2198729 Node: Examples of FORMAT2199140 Node: Notes about FORMAT2203164 Node: Printer Dictionary2203806 Node: copy-pprint-dispatch2204575 Node: formatter2205320 Node: pprint-dispatch2206517 Node: pprint-exit-if-list-exhausted2208053 Node: pprint-fill2209651 Node: pprint-indent2213094 Node: pprint-logical-block2214955 Node: pprint-newline2220449 Node: pprint-pop2224793 Node: pprint-tab2228009 Node: print-object2229399 Node: print-unreadable-object2234169 Node: set-pprint-dispatch2235994 Node: write2238185 Node: write-to-string2242257 Node: *print-array*2244469 Node: *print-base*2245317 Node: *print-case*2247630 Node: *print-circle*2249989 Node: *print-escape*2251610 Node: *print-gensym*2252751 Node: *print-level*2253402 Node: *print-lines*2256487 Node: *print-miser-width*2257874 Node: *print-pprint-dispatch*2258420 Node: *print-pretty*2259730 Node: *print-readably*2261644 Node: *print-right-margin*2265421 Node: print-not-readable2266299 Node: print-not-readable-object2267145 Node: format2267721 Node: Reader2269485 Node: Reader Concepts2269645 Node: Dynamic Control of the Lisp Reader2269931 Node: Effect of Readtable Case on the Lisp Reader2270317 Node: Examples of Effect of Readtable Case on the Lisp Reader2271362 Node: Argument Conventions of Some Reader Functions2272883 Node: The EOF-ERROR-P argument2273204 Node: The RECURSIVE-P argument2274833 Node: Reader Dictionary2277604 Node: readtable2278124 Node: copy-readtable2278933 Node: make-dispatch-macro-character2280840 Node: read2282101 Node: read-delimited-list2287318 Node: read-from-string2291029 Node: readtable-case2293509 Node: readtablep2294711 Node: set-dispatch-macro-character2295384 Node: set-macro-character2298467 Node: set-syntax-from-char2301037 Node: with-standard-io-syntax2303156 Node: *read-base*2305176 Node: *read-default-float-format*2306531 Node: *read-eval*2308076 Node: *read-suppress*2308786 Node: *readtable*2312435 Node: reader-error2313495 Node: System Construction2314029 Node: System Construction Concepts2314245 Node: Loading2314497 Node: Features2315454 Node: Feature Expressions2315963 Node: Examples of Feature Expressions2316986 Node: System Construction Dictionary2318577 Node: compile-file2318984 Node: compile-file-pathname2323747 Node: load2325797 Node: with-compilation-unit2331390 Node: *features*2333616 Node: *compile-file-pathname*2339053 Node: *load-pathname*2340365 Node: *compile-print*2341587 Node: *load-print*2342189 Node: *modules*2342827 Node: provide2343385 Node: Environment2346236 Node: The External Environment2346437 Node: Top level loop2346704 Node: Debugging Utilities2347560 Node: Environment Inquiry2348056 Node: Time2348746 Node: Decoded Time2349986 Node: Universal Time2351555 Node: Internal Time2352611 Node: Seconds2353192 Node: Environment Dictionary2353737 Node: decode-universal-time2354443 Node: encode-universal-time2356390 Node: get-universal-time2357560 Node: sleep2359710 Node: apropos2360797 Node: describe2362343 Node: describe-object2364191 Node: trace2367094 Node: step2369975 Node: time2371307 Node: internal-time-units-per-second2373187 Node: get-internal-real-time2373799 Node: get-internal-run-time2374654 Node: disassemble2375992 Node: documentation2377376 Node: room2383694 Node: ed2384792 Node: inspect2386255 Node: dribble2387151 Node: - (Variable)2389031 Node: + (Variable)2389674 Node: * (Variable)2390745 Node: / (Variable)2392292 Node: lisp-implementation-type2393438 Node: short-site-name2394670 Node: machine-instance2395633 Node: machine-type2396440 Node: machine-version2397102 Node: software-type2397814 Node: user-homedir-pathname2398832 Node: Glossary (Glossary)2400458 Node: Glossary2400599 Node: Appendix2561441 Node: Removed Language Features2561579 Node: Requirements for removed and deprecated features2561942 Node: Removed Types2563145 Node: Removed Operators2563378 Node: Removed Argument Conventions2563757 Node: Removed Variables2564075 Node: Removed Reader Syntax2564439 Node: Packages No Longer Required2564695  End Tag Table  Local Variables: coding: utf-8 End: gcl-2.7.1/info/PaxHeaders/si-defs.texi0000644000000000000000000000013214776120200014523 xustar0030 mtime=1744347264.217606819 30 atime=1744347265.869617036 30 ctime=1744351535.630907891 gcl-2.7.1/info/si-defs.texi0000644000175000017500000011364614776120200014134 0ustar00cammcamm @node System Definitions, Debugging, C Interface, Top @chapter System Definitions @defun SOCKET (port :host host) Package:SI GCL specific: Open a socket connection to HOST at PORT. @end defun @defun OPEN-NAMED-SOCKET (port) Package:SI GCL specific: Open a socket on PORT, returning (cons fd portname) where fd is a small fixnum which is the write file descriptor for the socket. If PORT is zero do automatic allocation of port. @end defun @defun ACCEPT-SOCKET-CONNECTION (NAMED_SOCKET) Package:SI GCL specific: Wait for a connection on NAMED_SOCKET and return (list* named_socket fd name1) when one is established. @end defun @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 *CODE-BLOCK-RESERVE* Package:SI GCL specific: Set this variable to a static array (supply :static t to 'make-array) to reserve space for loading code in low memory as the heap grows large. On large systems, it may prove impossible without this to find unallocated memory below, for example, the 2Gb limit required for the default 'medium model' code produced by gcc on x86_64 systems. @end defvar @defvar *FAST-LINK-WARNINGS* Package:SI GCL specific: Set to non-NIL to trace function calls that cannot proceed through a simple pointer dereference, usually because the signature of the callee is substantially different than that assumed when compiling the caller. @end defvar @defvar *ANNOTATE* Package:COMPILER GCL specific: Set to non-NIL to add comments in the generated C code indicating lisp function inlining. @end defvar @defvar *DEFAULT-PROF-P* Package:COMPILER GCL specific: Set to non-NIL to add the :prof t option to compile file by default to indicate code which should be prepared for gprof profiling. @end defvar @defvar *DEFAULT-LARGE-MEMORY-MODEL-P* Package:COMPILER GCL specific: Set to non-NIL to add the :large-memory-model t option to compile file by default to instruct gcc to produce code that can be loaded at any address, typically at a 10% performance penalty. @end defvar @defvar *DEFAULT-C-FILE* Package:COMPILER GCL specific: Set to non-NIL to add the :c-file t option to compile file by default to keep the intermediate generated C file. @end defvar @defvar *DEFAULT-H-FILE* Package:COMPILER GCL specific: Set to non-NIL to add the :h-file t option to compile file by default to keep the intermediate generated header file. @end defvar @defvar *DEFAULT-DATA-FILE* Package:COMPILER GCL specific: Set to non-NIL to add the :data-file t option to compile file by default to keep the intermediate generated data file. @end defvar @defvar *DEFAULT-SYSTEM-P* Package:COMPILER GCL specific: Set to non-NIL to add the :system-p t option to compile file by default to write a reference to the system cmpinclude.h file in the generated C code as opposed to inserting its contents in the file directly. @end defvar @defvar *FASD-DATA* Package:COMPILER GCL specific: Set to NIL to write the data file in human readable format. @end defvar @defvar *KEEP-GAZ* Package:COMPILER GCL specific: Set to non-NIL to preserve anonymous ``gazonk'' .o files. @end defvar @defvar *DISASSEMBLE-OBJDUMP* Package:COMPILER GCL specific: When set to non-NIL, 'disassemble will report assembly instructions output by objdump in addition to the C code output by GCL. @end defvar @defun FILE Package:SI GCL specific: Return the source file from which the designated function was loaded. @end defun @defun SIGNATURE Package:SI GCL specific: Return the call signature of the designated function. @end defun @defun INTERPRET Package:COMPILER GCL specific: Just as (compile 'foo) will replace an interpreted function designated by 'foo with a compiled one, (compiler::interpret 'foo) will do the reverse. Both functions are idempotent operations. @end defun @defun WATCH Package:COMPILER GCL specific: (watch 'foo) will trace compiler logic pertaining to 'foo. (watch 'compiler::tail-recursion) will trace the compiler's treatment of tail recursion optimization. Other useful options include 'compiler::type-inference, 'compiler::branch-elimination, and 'compiler::inline. @end defun @defun UNWATCH Package:COMPILER GCL specific: (unwatch 'foo) will stop tracing 'foo. (unwatch) will stop all compiler tracing. @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 listener 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 matches. 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.7.1/info/PaxHeaders/gcl-tk.info0000644000000000000000000000013214776130462014347 xustar0030 mtime=1744351538.774879741 30 atime=1744351538.774879741 30 ctime=1744351538.806879455 gcl-2.7.1/info/gcl-tk.info0000644000175000017500000000300014776130462013736 0ustar00cammcammThis is gcl-tk.info, produced by makeinfo version 7.1 from gcl-tk.texi. This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-tk: (gcl-tk.info). GNU Common Lisp Tk Manual END-INFO-DIR-ENTRY  Indirect: gcl-tk.info-1: 270 gcl-tk.info-2: 302275  Tag Table: (Indirect) Node: Top270 Node: General1128 Node: Introduction1415 Node: Getting Started2924 Node: Common Features of Widgets4546 Node: Return Values8296 Node: Argument Lists12450 Node: Lisp Functions Invoked from Graphics15958 Node: Linked Variables21111 Node: tkconnect24944 Node: Widgets26927 Node: button27215 Node: listbox33968 Node: scale42387 Node: canvas49722 Node: menu110471 Node: scrollbar129646 Node: checkbutton136951 Node: menubutton146753 Node: text154763 Node: entry188936 Node: message199294 Node: frame205276 Node: label209295 Node: radiobutton212726 Node: toplevel222219 Node: Control226061 Node: after226440 Node: bind227596 Node: destroy243279 Node: tk-dialog243864 Node: exit245679 Node: focus246356 Node: grab251071 Node: tk-listbox-single-select255740 Node: lower256644 Node: tk-menu-bar257522 Node: option263190 Node: options266272 Node: pack-old284168 Node: pack291928 Node: place302276 Node: raise311097 Node: selection311956 Node: send317162 Node: tk318983 Node: tkerror320820 Node: tkvars322544 Node: tkwait324812 Node: update326296 Node: winfo327818 Node: wm336261  End Tag Table  Local Variables: coding: utf-8 End: gcl-2.7.1/info/PaxHeaders/compiler-defs.texi0000644000000000000000000000013214542551763015737 xustar0030 mtime=1703597043.252022821 30 atime=1744294999.649960834 30 ctime=1744351535.622907963 gcl-2.7.1/info/compiler-defs.texi0000755000175000017500000001262514542551763015346 0ustar00cammcamm @node Compiler Definitions, JAPI GUI Library Binding, 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 COMPILER-DEFAULT-TYPE (pathname) Package:COMPILER Allows you to set the default file extension for compiler source files. The argument can either be a pathname or a string. For example, imagine you have two files, ``foo.lisp'' and ``foo1.lsp'' in your working directory. (Note the different extensions.) Then: @example >(compile-file "foo") The source file foo.lsp is not found. NIL >(compile-file "foo1") Compiling foo1.lsp. End of Pass 1. End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 Finished compiling foo1. #p"foo1.o" >(compiler::COMPILER-default-TYPE "lisp") #p".lisp" >(compile-file "foo") Compiling foo.lisp. End of Pass 1. End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 Finished compiling foo. #p"foo.o" >(compile-file "foo1") The source file foo1.lisp is not found. NIL > @end example @end defun @defun COMPILER-RESET-TYPE () Package:COMPILER Resets the default compiler input file extension to the GCL historical value of #''.lsp''. @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.7.1/info/PaxHeaders/gcl-tk.texi0000644000000000000000000000013214773072355014370 xustar0030 mtime=1743549677.342525456 30 atime=1744339795.483292201 30 ctime=1744351535.574908393 gcl-2.7.1/info/gcl-tk.texi0000755000175000017500000000316614773072355013777 0ustar00cammcamm\input texinfo @c -*-texinfo-*- @c @smallbook @settitle GCL TK Manual @setfilename gcl-tk.info @c to update the menus do: @c (texinfo-multiple-files-update "gcl-tk.texi" t t) @setchapternewpage odd @ifinfo This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter @format INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-tk: (gcl-tk.info). GNU Common Lisp Tk Manual END-INFO-DIR-ENTRY @end format @end ifinfo @titlepage @sp 10 @comment The title is printed in a large font. @center @titlefont{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.7.1/info/PaxHeaders/form.texi0000644000000000000000000000013114776006046014146 xustar0030 mtime=1744309286.182034498 29 atime=1744309286.29003502 30 ctime=1744351535.622907963 gcl-2.7.1/info/form.texi0000644000175000017500000006134114776006046013552 0ustar00cammcamm@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 @defun GET-SETF-METHOD (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. It is an error if the third value (i.e., the list of store variables) is not a one-element list. See the doc of GET-SETF-METHOD-MULTIPLE-VALUE for comparison. @end defun @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.7.1/info/PaxHeaders/list.texi0000644000000000000000000000013214542551763014161 xustar0030 mtime=1703597043.256022827 30 atime=1744294999.653960851 30 ctime=1744351535.626907927 gcl-2.7.1/info/list.texi0000755000175000017500000003142014542551763013562 0ustar00cammcamm@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.7.1/info/PaxHeaders/chap-14.texi0000644000000000000000000000013214763573237014350 xustar0030 mtime=1741616799.677591263 30 atime=1744294999.653960851 30 ctime=1744351535.602908142 gcl-2.7.1/info/chap-14.texi0000644000175000017500000034053214763573237013755 0ustar00cammcamm @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 association 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 association 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.7.1/info/PaxHeaders/user-interface.texi0000644000000000000000000000013214542551763016122 xustar0030 mtime=1703597043.256022827 30 atime=1744294999.653960851 30 ctime=1744351535.634907855 gcl-2.7.1/info/user-interface.texi0000755000175000017500000002010014542551763015514 0ustar00cammcamm@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.7.1/info/PaxHeaders/number.texi0000644000000000000000000000013214542551763014476 xustar0030 mtime=1703597043.256022827 30 atime=1744294999.653960851 30 ctime=1744351535.630907891 gcl-2.7.1/info/number.texi0000755000175000017500000005311314542551763014102 0ustar00cammcamm@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.7.1/info/PaxHeaders/doc.texi0000644000000000000000000000013214542551763013753 xustar0030 mtime=1703597043.252022821 30 atime=1744294999.657960869 30 ctime=1744351535.622907963 gcl-2.7.1/info/doc.texi0000755000175000017500000000600114542551763013351 0ustar00cammcamm@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.7.1/info/PaxHeaders/gcl-si.info-10000644000000000000000000000013114776130462014501 xustar0030 mtime=1744351538.286884106 29 atime=1744351538.00688661 30 ctime=1744351538.802879491 gcl-2.7.1/info/gcl-si.info-10000644000175000017500000124666614776130462014125 0ustar00cammcammThis is gcl-si.info, produced by makeinfo version 7.1 from gcl-si.texi. This is a Texinfo GCL SYSTEM INTERNALS Manual Copyright 1994 William F. Schelter Copyright 2024 Camm Maguire INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-si: (gcl-si.info). GNU Common Lisp System Internals END-INFO-DIR-ENTRY  File: gcl-si.info, Node: Top, Next: Numbers, Prev: (dir), Up: (dir) GCL SI Manual ************* * 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:: * JAPI GUI Library Binding:: * Function Index:: * 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. -- Function: GET-SETF-METHOD (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. It is an error if the third value (i.e., the list of store variables) is not a one-element list. See the doc of GET-SETF-METHOD-MULTIPLE-VALUE for comparison. -- 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* Package:COMPILER Specifies the default setting of :SYSTEM-P used by COMPILE. Defaults to NIL. -- Variable: *DEFAULT-C-FILE* Package:COMPILER Specifies the default setting of :C-FILE used by COMPILE. Defaults to NIL. -- Variable: *DEFAULT-H-FILE* Package:COMPILER Specifies the default setting of :H-FILE used by COMPILE. Defaults to NIL. -- Variable: *DEFAULT-DATA-FILE* Package: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:: * Environment Variables::  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.  File: gcl-si.info, Node: Environment Variables, Next: Operating System Definitions, Prev: Operating System, Up: Operating System 9.3 Environment Variables ========================= Several environment variables affect GCL: -- Environment Variable: GCL_MEM_MULTIPLE A positive float indicating the fraction of available memory GCL should use. Defaults to 1.0. -- Environment Variable: GCL_MEM_BOUND A positive integer bounding GCL's heap to 1<<(n+1) bytes. Trumps GCL_MEM_MULTIPLE. Defaults to sizeof(long)-1. -- Environment Variable: GCL_GC_ALLOC_MIN A positive float indicating the minimum fraction of heap to be allocated between garbage collection (GC) cycles. Defaults to 0.05. -- Environment Variable: GCL_GC_PAGE_MIN A positive float indicating the minimum fraction of heap to be allocated before garbage collection (GC) commences. Defaults to 0.5. -- Environment Variable: GCL_GC_PAGE_MAX A positive float indicating the maximum fraction of heap to be allocated after which garbage collection (GC) is mandatory. Defaults to 0.75. -- Environment Variable: GCL_MULTIPROCESS_MEMORY_POOL A string when set indicating a directory in which to place the file gcl_pool used for coordinating memory management among multiple GCL processes. This should be a local directory for performance reasons. Default is unset. -- Environment Variable: GCL_WAIT_ON_ABORT A non-negative integer indicating how many seconds to sleep before aborting on fatal error. Defaults to 0.  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: SET-LOG-MAXPAGE-BOUND (positive-integer) Package:SYSTEM GCL specific: Limits the heap to 1<<(positive-integer+1) bytes. Trumps any limits specified in the environment. -- 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:: * External Shared Libraries::  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: External Shared Libraries, Prev: C Interface, Up: C Interface 16.2 External Shared Libraries ============================== -- Macro: DEFDLFUN Package:SYSTEM Syntax: (compile (DEFDLFUN {RETURN NAME &optional LIBNAME) ARGS*)) GCL specific: Produces an entry function to function NAME in external shared library LIBNAME with the specified args/return signature. This function must be compiled to run. When inlined, the function call collapses to a single reference to a pointer which is automatically updated to the location of the external function at image startup. The connection to the external library is persistent across image saves and re-executions. The RETURN and ARGS specifiers are keywords from the following list corresponding to the accompanying C programming types: :char :short :int :long :float :double Unsigned versions available are: :uchar :ushort :uint Complex float and complex double types can be access via: :fcomplex :dcomples Pointers to types available are :void* :char* :long* :float* :double* Example usage: GCL (GNU Common Lisp) 2.7.0 Thu Oct 26 12:00:01 PM EDT 2023 CLtL1 git: Version_2_7_0pre38 Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl) Binary License: GPL due to GPL'ed components: (XGCL READLINE UNEXEC) 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. Temporary directory for compiler files set to /tmp/ >(do-symbols (s :lib) (print s)) LIB:|libm| LIB:|libc| NIL >(compile (si::defdlfun (:double "cblas_ddot" "libblas.so") :uint :double* :uint :double* :uint)) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. ;; Loading #P"/tmp/gazonk_653784_0.o" ;; start address for /tmp/gazonk_653784_0.o 0x2700860 ;; Finished loading #P"/tmp/gazonk_653784_0.o" # NIL NIL >(do-symbols (s :lib) (print s)) LIB:|libblas| LIB:|libm| LIB:|libc| NIL >(do-symbols (s 'lib::|libblas|) (unless (find-symbol (symbol-name s) :user) (print s))) |libblas|:|cblas_ddot| NIL NIL >(setq a (make-array 3 :element-type 'long-float) b (make-array 3 :element-type 'long-float)) #(0.0 0.0 0.0) >(setf (aref a 1) 1.2 (aref b 1) 2.3) 2.3 >(|libblas|:|cblas_ddot| 3 a 1 b 1) 2.76 >(compile (defun foo (a b) (declare ((vector long-float) a b)) (|libblas|:|cblas_ddot| (length a) a 1 b 1))) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. ;; Loading #P"/tmp/gazonk_653784_0.o" ;; start address for /tmp/gazonk_653784_0.o 0x2715050 ;; Finished loading #P"/tmp/gazonk_653784_0.o" # NIL NIL >(compile (defun bar (a b) (declare (inline |libblas|:|cblas_ddot|) ((vector long-float) a b)) (|libblas|:|cblas_ddot| (length a) a 1 b 1))) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. ;; Loading #P"/tmp/gazonk_653784_0.o" ;; start address for /tmp/gazonk_653784_0.o 0x2729570 ;; Finished loading #P"/tmp/gazonk_653784_0.o" # NIL NIL >(foo a b) 2.76 >(bar a b) 2.76 >(setq compiler::*disassemble-objdump* nil) NIL >(disassemble '|libblas|:|cblas_ddot|) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. #include "gazonk_653784_0.h" void init_code(){do_init((void *)VV);} /* local entry for function libblas::cblas_ddot */ static object LI1__cblas_ddot___gazonk_653784_0(fixnum V6,object V7,fixnum V8,object V9,fixnum V10) { VMB1 VMS1 VMV1 if(!(((char)tp0(make_fixnum(V6)))==(1))){ goto T8; } if(!((0)<=(V6))){ goto T13; } if(!((V6)<=((fixnum)4294967295))){ goto T11; } goto T12; goto T13; T13:; goto T11; goto T12; T12:; goto T7; goto T11; T11:; goto T6; goto T8; T8:; goto T6; goto T7; T7:; goto T5; goto T6; T6:; goto T3; goto T5; T5:; goto T2; goto T3; T3:; V11= CMPmake_fixnum(V6); V6= fixint((fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[1]),(V11),((object)VV[2]),Cnil))); goto T2; T2:; switch(tp6(V7)){ case 428: goto T27; T27:; case 492: goto T28; T28:; goto T25; default: goto T29; T29:; goto T24; goto T24; } goto T24; goto T25; T25:; goto T23; goto T24; T24:; goto T22; goto T23; T23:; goto T21; goto T22; T22:; goto T19; goto T21; T21:; goto T18; goto T19; T19:; V7= (fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[3]),(V7),((object)VV[4]),Cnil)); goto T18; T18:; if(!(((char)tp0(make_fixnum(V8)))==(1))){ goto T39; } if(!((0)<=(V8))){ goto T44; } if(!((V8)<=((fixnum)4294967295))){ goto T42; } goto T43; goto T44; T44:; goto T42; goto T43; T43:; goto T38; goto T42; T42:; goto T37; goto T39; T39:; goto T37; goto T38; T38:; goto T36; goto T37; T37:; goto T34; goto T36; T36:; goto T33; goto T34; T34:; V12= CMPmake_fixnum(V8); V8= fixint((fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[5]),(V12),((object)VV[2]),Cnil))); goto T33; T33:; switch(tp6(V9)){ case 428: goto T58; T58:; case 492: goto T59; T59:; goto T56; default: goto T60; T60:; goto T55; goto T55; } goto T55; goto T56; T56:; goto T54; goto T55; T55:; goto T53; goto T54; T54:; goto T52; goto T53; T53:; goto T50; goto T52; T52:; goto T49; goto T50; T50:; V9= (fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[6]),(V9),((object)VV[4]),Cnil)); goto T49; T49:; if(!(((char)tp0(make_fixnum(V10)))==(1))){ goto T70; } if(!((0)<=(V10))){ goto T75; } if(!((V10)<=((fixnum)4294967295))){ goto T73; } goto T74; goto T75; T75:; goto T73; goto T74; T74:; goto T69; goto T73; T73:; goto T68; goto T70; T70:; goto T68; goto T69; T69:; goto T67; goto T68; T68:; goto T65; goto T67; T67:; goto T64; goto T65; T65:; V13= CMPmake_fixnum(V10); V10= fixint((fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[7]),(V13),((object)VV[2]),Cnil))); goto T64; T64:; {object V14 = make_longfloat(((double(*)(uint,double*,uint,double*,uint))(dlcblas_ddot))((uint)V6,(double*)V7->v.v_self,(uint)V8,(double*)V9->v.v_self,(uint)V10)); VMR1(V14);} } static object LnkTLI2(object first,...){object V1;va_list ap;va_start(ap,first);V1=(object )call_proc_new(((object)VV[0]),0,262147,(void **)(void *)&LnkLI2,0,first,ap);va_end(ap);return V1;} /* SYSTEM::CHECK-TYPE-SYMBOL */ (9 (MAPC 'EVAL *COMPILER-COMPILE-DATA*)) static object LI1__cblas_ddot___gazonk_653784_0(fixnum V6,object V7,fixnum V8,object V9,fixnum V10) ; static void *dlcblas_ddot; #define VMB1 object V13 ,V12 ,V11; #define VMS1 #define VMV1 #define VMRV1(a_,b_) return((object )a_); #define VMR1(a_) VMRV1(a_,0); #define VM1 0 static void * VVi[9]={ #define Cdata VV[8] (void *)(&dlcblas_ddot), (void *)(LI1__cblas_ddot___gazonk_653784_0) }; #define VV (VVi) static object LnkTLI2(object,...); static object (*LnkLI2)() = (object (*)()) LnkTLI2; NIL >(disassemble 'foo) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. #include "gazonk_653784_0.h" void init_code(){do_init((void *)VV);} /* local entry for function COMMON-LISP-USER::FOO */ static object LI1__FOO___gazonk_653784_0(object V3,object V4) { VMB1 VMS1 VMV1 if(!(((char)((fixnum)((uchar*)((fixnum)V3))[(fixnum)2]&(fixnum)1))==(0))){ goto T5; } goto T2; goto T5; T5:; V5= ((fixnum)((uint*)((fixnum)V3))[(fixnum)4]&268435455); goto T1; goto T2; T2:; V5= (((fixnum)((uint*)((fixnum)V3))[(fixnum)1]>>(fixnum)3)&268435455); goto T1; T1:; {object V6 = (/* libblas::cblas_ddot */(object )(*LnkLI2)(V5,(V3),(fixnum)1,(V4),(fixnum)1)); VMR1(V6);} } static object LnkTLI2(object first,...){object V1;va_list ap;va_start(ap,first);V1=(object )call_proc_new(((object)VV[0]),0,5,(void **)(void *)&LnkLI2,1092,first,ap);va_end(ap);return V1;} /* libblas::cblas_ddot */ (2 (MAPC 'EVAL *COMPILER-COMPILE-DATA*)) static object LI1__FOO___gazonk_653784_0(object V3,object V4) ; #define VMB1 fixnum V5; #define VMS1 #define VMV1 #define VMRV1(a_,b_) return((object )a_); #define VMR1(a_) VMRV1(a_,0); #define VM1 0 static void * VVi[2]={ #define Cdata VV[1] (void *)(LI1__FOO___gazonk_653784_0) }; #define VV (VVi) static object LnkTLI2(object,...); static object (*LnkLI2)() = (object (*)()) LnkTLI2; NIL >(disassemble 'bar) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. #include "gazonk_653784_0.h" void init_code(){do_init((void *)VV);} /* local entry for function COMMON-LISP-USER::BAR */ static object LI1__BAR___gazonk_653784_0(object V3,object V4) { VMB1 VMS1 VMV1 {fixnum V5; if(!(((char)((fixnum)((uchar*)((fixnum)V3))[(fixnum)2]&(fixnum)1))==(0))){ goto T5; } goto T2; goto T5; T5:; V5= ((fixnum)((uint*)((fixnum)V3))[(fixnum)4]&268435455); goto T1; goto T2; T2:; V5= (((fixnum)((uint*)((fixnum)V3))[(fixnum)1]>>(fixnum)3)&268435455); goto T1; T1:; {object V6 = make_longfloat(((double(*)(uint,double*,uint,double*,uint))(dlcblas_ddot))((uint)V5,(double*)V3->v.v_self,(uint)1,(double*)V4->v.v_self,(uint)1)); VMR1(V6);}} } (2 (MAPC 'EVAL *COMPILER-COMPILE-DATA*)) static object LI1__BAR___gazonk_653784_0(object V3,object V4) ; static void *dlcblas_ddot; #define VMB1 #define VMS1 #define VMV1 #define VMRV1(a_,b_) return((object )a_); #define VMR1(a_) VMRV1(a_,0); #define VM1 0 static void * VVi[2]={ #define Cdata VV[1] (void *)(&dlcblas_ddot), (void *)(LI1__BAR___gazonk_653784_0) }; #define VV (VVi) NIL >(si::save-system "ff") $ ./ff GCL (GNU Common Lisp) 2.7.0 Thu Oct 26 12:00:01 PM EDT 2023 CLtL1 git: Version_2_7_0pre38 Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl) Binary License: GPL due to GPL'ed components: (XGCL READLINE UNEXEC) 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. Temporary directory for compiler files set to /tmp/ >(foo a b) 2.76 >(bar a b) 2.76 >  File: gcl-si.info, Node: System Definitions, Next: Debugging, Prev: C Interface, Up: Top 17 System Definitions ********************* -- Function: SOCKET (port :host host) Package:SI GCL specific: Open a socket connection to HOST at PORT. -- Function: OPEN-NAMED-SOCKET (port) Package:SI GCL specific: Open a socket on PORT, returning (cons fd portname) where fd is a small fixnum which is the write file descriptor for the socket. If PORT is zero do automatic allocation of port. -- Function: ACCEPT-SOCKET-CONNECTION (NAMED_SOCKET) Package:SI GCL specific: Wait for a connection on NAMED_SOCKET and return (list* named_socket fd name1) when one is established. -- 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: *CODE-BLOCK-RESERVE* Package:SI GCL specific: Set this variable to a static array (supply :static t to 'make-array) to reserve space for loading code in low memory as the heap grows large. On large systems, it may prove impossible without this to find unallocated memory below, for example, the 2Gb limit required for the default 'medium model' code produced by gcc on x86_64 systems. -- Variable: *FAST-LINK-WARNINGS* Package:SI GCL specific: Set to non-NIL to trace function calls that cannot proceed through a simple pointer dereference, usually because the signature of the callee is substantially different than that assumed when compiling the caller. -- Variable: *ANNOTATE* Package:COMPILER GCL specific: Set to non-NIL to add comments in the generated C code indicating lisp function inlining. -- Variable: *DEFAULT-PROF-P* Package:COMPILER GCL specific: Set to non-NIL to add the :prof t option to compile file by default to indicate code which should be prepared for gprof profiling. -- Variable: *DEFAULT-LARGE-MEMORY-MODEL-P* Package:COMPILER GCL specific: Set to non-NIL to add the :large-memory-model t option to compile file by default to instruct gcc to produce code that can be loaded at any address, typically at a 10% performance penalty. -- Variable: *DEFAULT-C-FILE* Package:COMPILER GCL specific: Set to non-NIL to add the :c-file t option to compile file by default to keep the intermediate generated C file. -- Variable: *DEFAULT-H-FILE* Package:COMPILER GCL specific: Set to non-NIL to add the :h-file t option to compile file by default to keep the intermediate generated header file. -- Variable: *DEFAULT-DATA-FILE* Package:COMPILER GCL specific: Set to non-NIL to add the :data-file t option to compile file by default to keep the intermediate generated data file. -- Variable: *DEFAULT-SYSTEM-P* Package:COMPILER GCL specific: Set to non-NIL to add the :system-p t option to compile file by default to write a reference to the system cmpinclude.h file in the generated C code as opposed to inserting its contents in the file directly. -- Variable: *FASD-DATA* Package:COMPILER GCL specific: Set to NIL to write the data file in human readable format. -- Variable: *KEEP-GAZ* Package:COMPILER GCL specific: Set to non-NIL to preserve anonymous "gazonk" .o files. -- Variable: *DISASSEMBLE-OBJDUMP* Package:COMPILER GCL specific: When set to non-NIL, 'disassemble will report assembly instructions output by objdump in addition to the C code output by GCL. -- Function: FILE Package:SI GCL specific: Return the source file from which the designated function was loaded. -- Function: SIGNATURE Package:SI GCL specific: Return the call signature of the designated function. -- Function: INTERPRET Package:COMPILER GCL specific: Just as (compile 'foo) will replace an interpreted function designated by 'foo with a compiled one, (compiler::interpret 'foo) will do the reverse. Both functions are idempotent operations. -- Function: WATCH Package:COMPILER GCL specific: (watch 'foo) will trace compiler logic pertaining to 'foo. (watch 'compiler::tail-recursion) will trace the compiler's treatment of tail recursion optimization. Other useful options include 'compiler::type-inference, 'compiler::branch-elimination, and 'compiler::inline. -- Function: UNWATCH Package:COMPILER GCL specific: (unwatch 'foo) will stop tracing 'foo. (unwatch) will stop all compiler tracing. -- 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 listener 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 matches. 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: JAPI GUI Library Binding, 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: COMPILER-DEFAULT-TYPE (pathname) Package:COMPILER Allows you to set the default file extension for compiler source files. The argument can either be a pathname or a string. For example, imagine you have two files, "foo.lisp" and "foo1.lsp" in your working directory. (Note the different extensions.) Then: >(compile-file "foo") The source file foo.lsp is not found. NIL >(compile-file "foo1") Compiling foo1.lsp. End of Pass 1. End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 Finished compiling foo1. #p"foo1.o" >(compiler::COMPILER-default-TYPE "lisp") #p".lisp" >(compile-file "foo") Compiling foo.lisp. End of Pass 1. End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 Finished compiling foo. #p"foo.o" >(compile-file "foo1") The source file foo1.lisp is not found. NIL > -- Function: COMPILER-RESET-TYPE () Package:COMPILER Resets the default compiler input file extension to the GCL historical value of #".lsp". -- 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: JAPI GUI Library Binding, Next: Function Index, Prev: Compiler Definitions, Up: Top 21 JAPI GUI Library Binding *************************** Introduction:: ============== The JAPI GUI library is hosted on the internet at: http://www.japi.de It has bindings to many common languages. Including JAPI in your GCL build:: ================================== The GCL binding presented here is based on the C language version of the library, statically linked into GCL and uses the standard GCL FFI macros to import the functions and constants provided by JAPI. To include the library in your build of GCL, simply download the version of JAPI needed for your computer system, install the headers and libraries, and add the GCL configure switch "-enable-japi=yes" to your usual configuration parameters. Build GCL as usual. To run the GUI from GCL programs, you do need to have either of the executables "java" or "jre" in your PATH. How it works:: ============== As downloaded from the above web site, JAPI uses a socket connection to a Java GUI which is, fortunately for us, invisible to GCL. This gives the GCL JAPI binding the advantages and disadvantages of any non-native GUI system which trades off portability, speed and OS specific look and feel. The GCL JAPI binding works on Windows which is it's main advantage over GCL-Tk other than ease of maintenance at the Lisp level. The main disadvantage of GCL JAPI relative to GCL-Tk is that the JAPI library is no longer actively developed. It has also been criticised for depending on Java, a proprietary system. This binding does nothing more than provide Lisp wrappers around the JAPI primitives; there are no higher order functional wrappers. Never-the-less the interface is easy to understand, maintain and use at the Lisp level. The documentation for JAPI available from the web site is pretty much all you need to get started with the library under GCL. All of the exposed library functions and constants are provided in GCL and a comprehensive example is provided here to give you some idea of how to start using the system. Here is a simple example of how to use JAPI. It displays an empty frame for five seconds and then kills the GUI. ;; 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))) The macros "with-server" and "with-frame" are defined in the larger example below. The first, "with-server", takes two arguments, an application name string and a debug level. With debug level zero there is no debug output on the console. The second, "with-frame" takes two arguments, a variable name and a frame title string. You use the variable name, here "frame", to refer to the frame in later function calls. The longer example below which includes the small example just explained, also displays various kinds of dialog, does some graphics and mouse handling including the ability to save graphics to disk, and shows one way of implementing a very simple text editor. Example:: ========= ;;; ;;; 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 (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))))) ;; 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 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))) ;; 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)))) )))))))))))))))))) (defun mandel (drawable min_x max_x min_y max_y step_x step_y) (let* ((scale_x (/ 1 step_x)) (scale_y (/ 1 step_y))) (loop for y from min_y to max_y by step_y do (loop for x from min_x to max_x by step_x do (let* ((c 255) (z (complex x y)) (a z)) (loop while (and (< (abs (setq z (+ (* z z) a))) 2) (>= (decf c) 0))) (j_setcolor drawable c c c) (j_drawpixel drawable (* scale_x (+ (abs min_x) x)) (* scale_y (+ (abs min_y) y)) )))))) ;;; Monochrome Mandelbrot (with-server ("GCL Japi library test GUI 4" 0) (let* ((min_x -2) (max_x 1) (min_y -1) (max_y 1.1) (step_x 0.01) (step_y 0.01) (size_x (+ 1 (/ (- max_x min_x) step_x))) (size_y (+ 1 (/ (- max_y min_y) step_y)))) (with-frame (frame "Mandelbrot") (j_setsize frame size_x size_y) (j_setborderlayout frame) (with-menu-bar (menubar frame) (with-menu (file menubar "File") (with-menu-item (save file "Save BMP") (with-menu-item (quit file "Quit") (with-canvas (canvas1 frame size_x size_y) (j_pack frame) (j_show frame) (j_show canvas1) (mandel canvas1 min_x max_x min_y max_y step_x step_y) (do ((obj (j_nextaction) (j_nextaction))) ((or (= obj frame) (= obj quit)) t) (when (= obj save) (let ((image (j_getimage canvas1))) (when (= 0 (j_saveimage image "mandel.bmp" J_BMP)) (j_alertbox frame "Problems" "Can't save the image" "OK")) (j_dispose image) )))))))))))  File: gcl-si.info, Node: Function Index, Next: Variable Index, Prev: JAPI GUI Library Binding, Up: Top Appendix A Function Index ************************* [index] * Menu: * -: User Interface. (line 10) * *: Numbers. (line 557) * *MAKE-CONSTANT: System Definitions. (line 292) * *MAKE-SPECIAL: System Definitions. (line 387) * /: Numbers. (line 199) * /=: Numbers. (line 72) * +: Numbers. (line 658) * <: Numbers. (line 562) * <=: Numbers. (line 416) * =: Numbers. (line 663) * >: Numbers. (line 743) * >=: Numbers. (line 594) * 1-: Numbers. (line 411) * 1+: Numbers. (line 208) * ABS: Numbers. (line 707) * ACCEPT: System Definitions. (line 894) * ACCEPT-SOCKET-CONNECTION: System Definitions. (line 18) * ACONS: Lists. (line 254) * ACOS: Numbers. (line 603) * ACOSH: Numbers. (line 631) * ADDRESS: System Definitions. (line 405) * 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 108) * ALLOCATE-CONTIGUOUS-PAGES: System Definitions. (line 24) * ALLOCATE-GROWTH: System Definitions. (line 652) * ALLOCATE-RELOCATABLE-PAGES: System Definitions. (line 62) * ALLOCATE-SGC: System Definitions. (line 643) * ALLOCATED: System Definitions. (line 365) * ALLOCATED-CONTIGUOUS-PAGES: System Definitions. (line 68) * ALLOCATED-PAGES: System Definitions. (line 56) * ALLOCATED-RELOCATABLE-PAGES: System Definitions. (line 45) * ALPHA-CHAR-P: Characters. (line 151) * ALPHANUMERICP: Characters. (line 230) * AND: Special Forms and Functions. (line 450) * APPEND: Lists. (line 585) * APPLY: Special Forms and Functions. (line 410) * APPLYHOOK: Special Forms and Functions. (line 368) * APROPOS: Doc. (line 6) * APROPOS-LIST: Symbols. (line 315) * AREF: Sequences and Arrays and Hash Tables. (line 634) * ARGC: System Definitions. (line 418) * ARGV: System Definitions. (line 465) * ARRAY-DIMENSION: Sequences and Arrays and Hash Tables. (line 108) * 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-ROW-MAJOR-INDEX: Sequences and Arrays and Hash Tables. (line 102) * ARRAY-TOTAL-SIZE: Sequences and Arrays and Hash Tables. (line 690) * 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 302) * BDS-VAR: System Definitions. (line 109) * 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 391) * BOOLE: Numbers. (line 135) * BOTH-CASE-P: Characters. (line 20) * BOUNDP: Symbols. (line 230) * BREAK: User Interface. (line 120) * BREAK-FUNCTION: System Definitions. (line 782) * BUTLAST: Lists. (line 281) * BY: GCL Specific. (line 39) * BYE: GCL Specific. (line 219) * 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) * CAR: Lists. (line 460) * CASE: Special Forms and Functions. (line 528) * CATCH: Special Forms and Functions. (line 487) * CATCH-BAD-SIGNALS: System Definitions. (line 331) * CATCH-FATAL: System Definitions. (line 554) * CCASE: Special Forms and Functions. (line 62) * 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-CODE: Characters. (line 89) * CHAR-DOWNCASE: Characters. (line 39) * CHAR-EQUAL: Characters. (line 179) * CHAR-FONT: Characters. (line 104) * CHAR-GREATERP: Characters. (line 223) * CHAR-INT: Numbers. (line 63) * CHAR-LESSP: Characters. (line 97) * CHAR-NAME: Characters. (line 13) * CHAR-NOT-EQUAL: Characters. (line 130) * CHAR-NOT-GREATERP: Characters. (line 186) * CHAR-NOT-LESSP: Characters. (line 52) * 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 251) * 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 724) * 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 125) * COMPILED-FUNCTION-P: Compilation. (line 196) * COMPILER-DEFAULT-TYPE: Compiler Definitions. (line 87) * COMPILER-LET: Special Forms and Functions. (line 559) * COMPILER-RESET-TYPE: Compiler Definitions. (line 131) * COMPLEX: Numbers. (line 568) * COMPLEXP: Numbers. (line 507) * CONCATENATE: Sequences and Arrays and Hash Tables. (line 464) * COND: Special Forms and Functions. (line 469) * 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 213) * 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 257) * 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 733) * DBL: System Definitions. (line 768) * DECF: Numbers. (line 448) * DECLARE: Special Forms and Functions. (line 173) * DECODE-FLOAT: Numbers. (line 366) * DECODE-UNIVERSAL-TIME: Operating System Definitions. (line 42) * DEFCFUN: GCL Specific. (line 44) * DEFCONSTANT: Special Forms and Functions. (line 675) * DEFDLFUN: External Shared Libraries. (line 6) * DEFENTRY: GCL Specific. (line 159) * DEFINE-COMPILER-MACRO: System Definitions. (line 760) * DEFINE-INLINE-FUNCTION: System Definitions. (line 750) * DEFINE-MODIFY-MACRO: Special Forms and Functions. (line 497) * DEFINE-SETF-METHOD: Special Forms and Functions. (line 539) * DEFLA: GCL Specific. (line 142) * DEFMACRO: Special Forms and Functions. (line 216) * DEFPARAMETER: Special Forms and Functions. (line 769) * DEFSETF: Special Forms and Functions. (line 88) * DEFSTRUCT: Structures. (line 6) * DEFTYPE: Type. (line 58) * DEFUN: Special Forms and Functions. (line 150) * DEFVAR: Special Forms and Functions. (line 779) * 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 459) * DO: Streams and Reading. (line 188) * DO-ALL-SYMBOLS: Iteration and Tests. (line 28) * DO-EXTERNAL-SYMBOLS: Iteration and Tests. (line 6) * DO-SYMBOLS: Iteration and Tests. (line 90) * DO*: Iteration and Tests. (line 18) * DOCUMENTATION: Symbols. (line 236) * DOLIST: Iteration and Tests. (line 59) * DOTIMES: Special Forms and Functions. (line 315) * DPB: Numbers. (line 701) * DRIBBLE: User Interface. (line 101) * ECASE: Special Forms and Functions. (line 278) * 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 691) * ERROR-SET: System Definitions. (line 115) * ETYPECASE: Special Forms and Functions. (line 120) * EVAL: Special Forms and Functions. (line 744) * EVAL-WHEN: Compilation. (line 65) * EVALHOOK: Special Forms and Functions. (line 716) * 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 483) * FBOUNDP: Symbols. (line 164) * FCEILING: Numbers. (line 216) * FFLOOR: Numbers. (line 642) * FIFTH: Lists. (line 40) * FILE: System Definitions. (line 220) * 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 736) * FIND-SYMBOL: Symbols. (line 149) * FINISH-OUTPUT: Streams and Reading. (line 172) * FIRST: Lists. (line 372) * FIXNUMP: System Definitions. (line 297) * FLET: Special Forms and Functions. (line 264) * 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 798) * FP-OUTPUT-STREAM: System Definitions. (line 804) * FREAD: System Definitions. (line 598) * FREEZE-DEFSTRUCT: System Definitions. (line 32) * FRESH-LINE: Streams and Reading. (line 488) * FROUND: Numbers. (line 380) * FRS-BDS: System Definitions. (line 280) * FRS-IHS: System Definitions. (line 318) * FRS-VS: System Definitions. (line 516) * FTRUNCATE: Numbers. (line 169) * FUNCALL: Special Forms and Functions. (line 518) * FUNCTION: Special Forms and Functions. (line 354) * FUNCTIONP: Special Forms and Functions. (line 253) * FWRITE: System Definitions. (line 590) * GBC: GCL Specific. (line 116) * GBC-TIME: System Definitions. (line 581) * 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 80) * 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: Special Forms and Functions. (line 9) * GET-SETF-METHOD-MULTIPLE-VALUE: Special Forms and Functions. (line 480) * GET-STRING-INPUT-STREAM-INDEX: System Definitions. (line 98) * GET-UNIVERSAL-TIME: Operating System Definitions. (line 144) * GETENV: System Definitions. (line 476) * GETF: Lists. (line 424) * GETHASH: Sequences and Arrays and Hash Tables. (line 297) * GO: Special Forms and Functions. (line 604) * 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 133) * HOST-NAMESTRING: Operating System Definitions. (line 13) * IDENTITY: Special Forms and Functions. (line 665) * IF: Special Forms and Functions. (line 696) * IHS-FUN: System Definitions. (line 286) * IHS-VS: System Definitions. (line 136) * 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 263) * 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) * INTERPRET: System Definitions. (line 228) * INTERSECTION: Lists. (line 215) * ISQRT: Numbers. (line 732) * KEYWORDP: Symbols. (line 14) * LABELS: Special Forms and Functions. (line 416) * LAST: Lists. (line 195) * LCM: Numbers. (line 438) * LDB: Numbers. (line 335) * LDB-TEST: Numbers. (line 78) * LDIFF: Lists. (line 431) * LENGTH: Lists. (line 81) * LET: Special Forms and Functions. (line 460) * LET*: Special Forms and Functions. (line 131) * 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-ALL-PACKAGES: Symbols. (line 126) * LIST-LENGTH: Lists. (line 205) * LIST-UNDEFINED-FUNCTIONS: Compiler Definitions. (line 73) * LIST*: Lists. (line 471) * LISTEN: Streams and Reading. (line 290) * LISTP: Lists. (line 65) * LOAD: Streams and Reading. (line 16) * LOCALLY: Special Forms and Functions. (line 657) * 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-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 73) * MACROEXPAND-1: Special Forms and Functions. (line 511) * MACROLET: Special Forms and Functions. (line 592) * 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 392) * 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 854) * MATCH-END: System Definitions. (line 861) * MAX: Numbers. (line 515) * MAXIMUM-ALLOCATABLE-PAGES: System Definitions. (line 39) * MAXIMUM-CONTIGUOUS-PAGES: System Definitions. (line 74) * 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) * MULTIPLE-VALUE-BIND: Special Forms and Functions. (line 164) * MULTIPLE-VALUE-CALL: Special Forms and Functions. (line 80) * MULTIPLE-VALUE-LIST: Special Forms and Functions. (line 575) * MULTIPLE-VALUE-PROG1: Special Forms and Functions. (line 583) * MULTIPLE-VALUE-SETQ: Special Forms and Functions. (line 648) * NAME-CHAR: Characters. (line 6) * NAMESTRING: Streams and Reading. (line 382) * NANI: System Definitions. (line 424) * NBUTLAST: Lists. (line 97) * NCONC: Lists. (line 45) * NINTERSECTION: Lists. (line 6) * NINTH: Lists. (line 477) * NLOAD: System Definitions. (line 775) * NOT: Special Forms and Functions. (line 670) * 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 684) * OPEN-NAMED-SOCKET: System Definitions. (line 11) * OR: Special Forms and Functions. (line 723) * OUTPUT-STREAM-P: Streams and Reading. (line 252) * OUTPUT-STREAM-STRING: System Definitions. (line 92) * 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) * 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 152) * PROF: System Definitions. (line 531) * PROG: Special Forms and Functions. (line 613) * PROG*: Special Forms and Functions. (line 382) * PROG1: Special Forms and Functions. (line 141) * PROG2: Special Forms and Functions. (line 289) * PROGN: Special Forms and Functions. (line 401) * PROGV: Special Forms and Functions. (line 298) * PROVIDE: Compilation. (line 190) * PSETF: Special Forms and Functions. (line 749) * PSETQ: Symbols. (line 73) * PUSH: Lists. (line 349) * PUSHNEW: Lists. (line 395) * PUTPROP: System Definitions. (line 51) * QUOTE: Special Forms and Functions. (line 308) * 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 717) * 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 324) * RESET-STACK-LIMITS: System Definitions. (line 342) * REST: Lists. (line 242) * RETURN: Special Forms and Functions. (line 429) * RETURN-FROM: Special Forms and Functions. (line 629) * 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 828) * SAVE: GCL Specific. (line 124) * SAVE-SYSTEM: System Definitions. (line 437) * 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 275) * SET-LOG-MAXPAGE-BOUND: GCL Specific. (line 102) * SET-MACRO-CHARACTER: Streams and Reading. (line 119) * SET-SYNTAX-FROM-CHAR: Streams and Reading. (line 403) * SETF: Special Forms and Functions. (line 27) * SETQ: Symbols. (line 101) * SEVENTH: Lists. (line 173) * SGC-ON: System Definitions. (line 607) * SHADOW: Symbols. (line 157) * SHADOWING-IMPORT: Symbols. (line 36) * SHIFTF: Numbers. (line 265) * SHORT-SITE-NAME: Operating System Definitions. (line 61) * SIGNATURE: System Definitions. (line 224) * 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) * SINH: Numbers. (line 124) * SIXTH: Lists. (line 290) * SLEEP: Operating System Definitions. (line 201) * SOCKET: System Definitions. (line 6) * SOCKET <1>: System Definitions. (line 864) * 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 325) * SPECIALP: System Definitions. (line 86) * 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 103) * 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 842) * 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 308) * 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 130) * 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) * TAGBODY: Special Forms and Functions. (line 112) * 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 18) * THIRD: Lists. (line 128) * THROW: Special Forms and Functions. (line 759) * TIME: Operating System Definitions. (line 181) * TOP-LEVEL: System Definitions. (line 507) * 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 439) * TYPEP: Type. (line 22) * UNCATCH-BAD-SIGNALS: System Definitions. (line 449) * UNEXPORT: Symbols. (line 267) * UNINTERN: Symbols. (line 260) * UNION: Lists. (line 438) * UNIVERSAL-ERROR-HANDLER: System Definitions. (line 142) * UNLESS: Special Forms and Functions. (line 639) * UNREAD-CHAR: Streams and Reading. (line 387) * UNTRACE: User Interface. (line 16) * UNUSE-PACKAGE: Symbols. (line 112) * UNWATCH: System Definitions. (line 241) * UNWIND-PROTECT: Special Forms and Functions. (line 706) * UPPER-CASE-P: Characters. (line 157) * USE-FAST-LINKS: GCL Specific. (line 224) * USE-PACKAGE: Symbols. (line 59) * USER-HOMEDIR-PATHNAME: Operating System Definitions. (line 51) * VALUES: Special Forms and Functions. (line 570) * VALUES-LIST: Special Forms and Functions. (line 686) * 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 454) * WARN: User Interface. (line 114) * WATCH: System Definitions. (line 234) * WHEN: Special Forms and Functions. (line 53) * 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 522) * WRITE-FASD-TOP: System Definitions. (line 712) * 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 790) * XDR-READ: System Definitions. (line 810) * XDR-WRITE: System Definitions. (line 817) * Y-OR-N-P: Streams and Reading. (line 224) * YES-OR-NO-P: Iteration and Tests. (line 38) * ZEROP: Numbers. (line 480) gcl-2.7.1/info/PaxHeaders/gcl.info-90000644000000000000000000000013214776130461014100 xustar0030 mtime=1744351537.786888579 30 atime=1744351537.674889581 30 ctime=1744351538.798879527 gcl-2.7.1/info/gcl.info-90000644000175000017500000050207414776130461013506 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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 accommodate 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.7.1/info/PaxHeaders/c-interface.texi0000644000000000000000000000013214770537330015363 xustar0030 mtime=1742913240.030489619 30 atime=1744294999.685960992 30 ctime=1744351535.598908178 gcl-2.7.1/info/c-interface.texi0000755000175000017500000002616214770537330014773 0ustar00cammcamm@c Copyright (c) 1994 William Schelter. @node C Interface, System Definitions, GCL Specific, Top @chapter C Interface @menu * Available Symbols:: * External Shared Libraries:: @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. @node External Shared Libraries, , C Interface, C Interface @section External Shared Libraries @deffn {Macro} DEFDLFUN Package:SYSTEM Syntax: @example (compile (DEFDLFUN @{RETURN NAME &optional LIBNAME) ARGS*)) @end example GCL specific: Produces an entry function to function NAME in external shared library LIBNAME with the specified args/return signature. This function must be compiled to run. When inlined, the function call collapses to a single reference to a pointer which is automatically updated to the location of the external function at image startup. The connection to the external library is persistent across image saves and re-executions. The RETURN and ARGS specifiers are keywords from the following list corresponding to the accompanying C programming types: :char :short :int :long :float :double Unsigned versions available are: :uchar :ushort :uint Complex float and complex double types can be access via: :fcomplex :dcomples Pointers to types available are :void* :char* :long* :float* :double* Example usage: @example @verbatim GCL (GNU Common Lisp) 2.7.0 Thu Oct 26 12:00:01 PM EDT 2023 CLtL1 git: Version_2_7_0pre38 Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl) Binary License: GPL due to GPL'ed components: (XGCL READLINE UNEXEC) 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. Temporary directory for compiler files set to /tmp/ >(do-symbols (s :lib) (print s)) LIB:|libm| LIB:|libc| NIL >(compile (si::defdlfun (:double "cblas_ddot" "libblas.so") :uint :double* :uint :double* :uint)) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. ;; Loading #P"/tmp/gazonk_653784_0.o" ;; start address for /tmp/gazonk_653784_0.o 0x2700860 ;; Finished loading #P"/tmp/gazonk_653784_0.o" # NIL NIL >(do-symbols (s :lib) (print s)) LIB:|libblas| LIB:|libm| LIB:|libc| NIL >(do-symbols (s 'lib::|libblas|) (unless (find-symbol (symbol-name s) :user) (print s))) |libblas|:|cblas_ddot| NIL NIL >(setq a (make-array 3 :element-type 'long-float) b (make-array 3 :element-type 'long-float)) #(0.0 0.0 0.0) >(setf (aref a 1) 1.2 (aref b 1) 2.3) 2.3 >(|libblas|:|cblas_ddot| 3 a 1 b 1) 2.76 >(compile (defun foo (a b) (declare ((vector long-float) a b)) (|libblas|:|cblas_ddot| (length a) a 1 b 1))) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. ;; Loading #P"/tmp/gazonk_653784_0.o" ;; start address for /tmp/gazonk_653784_0.o 0x2715050 ;; Finished loading #P"/tmp/gazonk_653784_0.o" # NIL NIL >(compile (defun bar (a b) (declare (inline |libblas|:|cblas_ddot|) ((vector long-float) a b)) (|libblas|:|cblas_ddot| (length a) a 1 b 1))) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. ;; Loading #P"/tmp/gazonk_653784_0.o" ;; start address for /tmp/gazonk_653784_0.o 0x2729570 ;; Finished loading #P"/tmp/gazonk_653784_0.o" # NIL NIL >(foo a b) 2.76 >(bar a b) 2.76 >(setq compiler::*disassemble-objdump* nil) NIL >(disassemble '|libblas|:|cblas_ddot|) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. #include "gazonk_653784_0.h" void init_code(){do_init((void *)VV);} /* local entry for function libblas::cblas_ddot */ static object LI1__cblas_ddot___gazonk_653784_0(fixnum V6,object V7,fixnum V8,object V9,fixnum V10) { VMB1 VMS1 VMV1 if(!(((char)tp0(make_fixnum(V6)))==(1))){ goto T8; } if(!((0)<=(V6))){ goto T13; } if(!((V6)<=((fixnum)4294967295))){ goto T11; } goto T12; goto T13; T13:; goto T11; goto T12; T12:; goto T7; goto T11; T11:; goto T6; goto T8; T8:; goto T6; goto T7; T7:; goto T5; goto T6; T6:; goto T3; goto T5; T5:; goto T2; goto T3; T3:; V11= CMPmake_fixnum(V6); V6= fixint((fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[1]),(V11),((object)VV[2]),Cnil))); goto T2; T2:; switch(tp6(V7)){ case 428: goto T27; T27:; case 492: goto T28; T28:; goto T25; default: goto T29; T29:; goto T24; goto T24; } goto T24; goto T25; T25:; goto T23; goto T24; T24:; goto T22; goto T23; T23:; goto T21; goto T22; T22:; goto T19; goto T21; T21:; goto T18; goto T19; T19:; V7= (fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[3]),(V7),((object)VV[4]),Cnil)); goto T18; T18:; if(!(((char)tp0(make_fixnum(V8)))==(1))){ goto T39; } if(!((0)<=(V8))){ goto T44; } if(!((V8)<=((fixnum)4294967295))){ goto T42; } goto T43; goto T44; T44:; goto T42; goto T43; T43:; goto T38; goto T42; T42:; goto T37; goto T39; T39:; goto T37; goto T38; T38:; goto T36; goto T37; T37:; goto T34; goto T36; T36:; goto T33; goto T34; T34:; V12= CMPmake_fixnum(V8); V8= fixint((fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[5]),(V12),((object)VV[2]),Cnil))); goto T33; T33:; switch(tp6(V9)){ case 428: goto T58; T58:; case 492: goto T59; T59:; goto T56; default: goto T60; T60:; goto T55; goto T55; } goto T55; goto T56; T56:; goto T54; goto T55; T55:; goto T53; goto T54; T54:; goto T52; goto T53; T53:; goto T50; goto T52; T52:; goto T49; goto T50; T50:; V9= (fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[6]),(V9),((object)VV[4]),Cnil)); goto T49; T49:; if(!(((char)tp0(make_fixnum(V10)))==(1))){ goto T70; } if(!((0)<=(V10))){ goto T75; } if(!((V10)<=((fixnum)4294967295))){ goto T73; } goto T74; goto T75; T75:; goto T73; goto T74; T74:; goto T69; goto T73; T73:; goto T68; goto T70; T70:; goto T68; goto T69; T69:; goto T67; goto T68; T68:; goto T65; goto T67; T67:; goto T64; goto T65; T65:; V13= CMPmake_fixnum(V10); V10= fixint((fcall.argd=4,/* SYSTEM::CHECK-TYPE-SYMBOL */(object )(*LnkLI2)(((object)VV[7]),(V13),((object)VV[2]),Cnil))); goto T64; T64:; {object V14 = make_longfloat(((double(*)(uint,double*,uint,double*,uint))(dlcblas_ddot))((uint)V6,(double*)V7->v.v_self,(uint)V8,(double*)V9->v.v_self,(uint)V10)); VMR1(V14);} } static object LnkTLI2(object first,...){object V1;va_list ap;va_start(ap,first);V1=(object )call_proc_new(((object)VV[0]),0,262147,(void **)(void *)&LnkLI2,0,first,ap);va_end(ap);return V1;} /* SYSTEM::CHECK-TYPE-SYMBOL */ (9 (MAPC 'EVAL *COMPILER-COMPILE-DATA*)) static object LI1__cblas_ddot___gazonk_653784_0(fixnum V6,object V7,fixnum V8,object V9,fixnum V10) ; static void *dlcblas_ddot; #define VMB1 object V13 ,V12 ,V11; #define VMS1 #define VMV1 #define VMRV1(a_,b_) return((object )a_); #define VMR1(a_) VMRV1(a_,0); #define VM1 0 static void * VVi[9]={ #define Cdata VV[8] (void *)(&dlcblas_ddot), (void *)(LI1__cblas_ddot___gazonk_653784_0) }; #define VV (VVi) static object LnkTLI2(object,...); static object (*LnkLI2)() = (object (*)()) LnkTLI2; NIL >(disassemble 'foo) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. #include "gazonk_653784_0.h" void init_code(){do_init((void *)VV);} /* local entry for function COMMON-LISP-USER::FOO */ static object LI1__FOO___gazonk_653784_0(object V3,object V4) { VMB1 VMS1 VMV1 if(!(((char)((fixnum)((uchar*)((fixnum)V3))[(fixnum)2]&(fixnum)1))==(0))){ goto T5; } goto T2; goto T5; T5:; V5= ((fixnum)((uint*)((fixnum)V3))[(fixnum)4]&268435455); goto T1; goto T2; T2:; V5= (((fixnum)((uint*)((fixnum)V3))[(fixnum)1]>>(fixnum)3)&268435455); goto T1; T1:; {object V6 = (/* libblas::cblas_ddot */(object )(*LnkLI2)(V5,(V3),(fixnum)1,(V4),(fixnum)1)); VMR1(V6);} } static object LnkTLI2(object first,...){object V1;va_list ap;va_start(ap,first);V1=(object )call_proc_new(((object)VV[0]),0,5,(void **)(void *)&LnkLI2,1092,first,ap);va_end(ap);return V1;} /* libblas::cblas_ddot */ (2 (MAPC 'EVAL *COMPILER-COMPILE-DATA*)) static object LI1__FOO___gazonk_653784_0(object V3,object V4) ; #define VMB1 fixnum V5; #define VMS1 #define VMV1 #define VMRV1(a_,b_) return((object )a_); #define VMR1(a_) VMRV1(a_,0); #define VM1 0 static void * VVi[2]={ #define Cdata VV[1] (void *)(LI1__FOO___gazonk_653784_0) }; #define VV (VVi) static object LnkTLI2(object,...); static object (*LnkLI2)() = (object (*)()) LnkTLI2; NIL >(disassemble 'bar) ;; Compiling /tmp/gazonk_653784_0.lsp. ;; End of Pass 1. ;; End of Pass 2. OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3 ;; Finished compiling /tmp/gazonk_653784_0.o. #include "gazonk_653784_0.h" void init_code(){do_init((void *)VV);} /* local entry for function COMMON-LISP-USER::BAR */ static object LI1__BAR___gazonk_653784_0(object V3,object V4) { VMB1 VMS1 VMV1 {fixnum V5; if(!(((char)((fixnum)((uchar*)((fixnum)V3))[(fixnum)2]&(fixnum)1))==(0))){ goto T5; } goto T2; goto T5; T5:; V5= ((fixnum)((uint*)((fixnum)V3))[(fixnum)4]&268435455); goto T1; goto T2; T2:; V5= (((fixnum)((uint*)((fixnum)V3))[(fixnum)1]>>(fixnum)3)&268435455); goto T1; T1:; {object V6 = make_longfloat(((double(*)(uint,double*,uint,double*,uint))(dlcblas_ddot))((uint)V5,(double*)V3->v.v_self,(uint)1,(double*)V4->v.v_self,(uint)1)); VMR1(V6);}} } (2 (MAPC 'EVAL *COMPILER-COMPILE-DATA*)) static object LI1__BAR___gazonk_653784_0(object V3,object V4) ; static void *dlcblas_ddot; #define VMB1 #define VMS1 #define VMV1 #define VMRV1(a_,b_) return((object )a_); #define VMR1(a_) VMRV1(a_,0); #define VM1 0 static void * VVi[2]={ #define Cdata VV[1] (void *)(&dlcblas_ddot), (void *)(LI1__BAR___gazonk_653784_0) }; #define VV (VVi) NIL >(si::save-system "ff") $ ./ff GCL (GNU Common Lisp) 2.7.0 Thu Oct 26 12:00:01 PM EDT 2023 CLtL1 git: Version_2_7_0pre38 Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl) Binary License: GPL due to GPL'ed components: (XGCL READLINE UNEXEC) 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. Temporary directory for compiler files set to /tmp/ >(foo a b) 2.76 >(bar a b) 2.76 > @end verbatim @end example @end deffn gcl-2.7.1/info/PaxHeaders/chap-10.texi0000644000000000000000000000013214763573237014344 xustar0030 mtime=1741616799.677591263 30 atime=1744294999.685960992 30 ctime=1744351535.602908142 gcl-2.7.1/info/chap-10.texi0000644000175000017500000011757314763573237013760 0ustar00cammcamm @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 association 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.7.1/info/PaxHeaders/internal.texi0000644000000000000000000000013114770537330015016 xustar0029 mtime=1742913240.16649023 30 atime=1744294999.685960992 30 ctime=1744351535.626907927 gcl-2.7.1/info/internal.texi0000755000175000017500000002464314770537330014431 0ustar00cammcamm@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 SET-LOG-MAXPAGE-BOUND (positive-integer) Package:SYSTEM GCL specific: Limits the heap to 1<<(positive-integer+1) bytes. Trumps any limits specified in the environment. @end defun @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.7.1/info/PaxHeaders/chap-12.texi0000644000000000000000000000013214542551763014341 xustar0030 mtime=1703597043.228022784 30 atime=1744294999.685960992 30 ctime=1744351535.602908142 gcl-2.7.1/info/chap-12.texi0000644000175000017500000051510614542551763013747 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-15.texi0000644000000000000000000000013114542551763014343 xustar0029 mtime=1703597043.23202279 30 atime=1744294999.689961009 30 ctime=1744351535.606908106 gcl-2.7.1/info/chap-15.texi0000644000175000017500000023120214542551763013742 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-22.texi0000644000000000000000000000013214542551763014342 xustar0030 mtime=1703597043.244022809 30 atime=1744294999.697961044 30 ctime=1744351535.610908071 gcl-2.7.1/info/chap-22.texi0000644000175000017500000057345414542551763013762 0ustar00cammcamm @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.7.1/info/PaxHeaders/control.texi0000644000000000000000000000013214776006046014664 xustar0030 mtime=1744309286.182034498 30 atime=1744309286.286035001 30 ctime=1744351535.622907963 gcl-2.7.1/info/control.texi0000644000175000017500000042657614776006046014306 0ustar00cammcamm@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.7.1/info/PaxHeaders/widgets.texi0000644000000000000000000000013214776006046014652 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.294035039 30 ctime=1744351535.634907855 gcl-2.7.1/info/widgets.texi0000644000175000017500000061670314776006046014265 0ustar00cammcamm@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.7.1/info/PaxHeaders/chap-20.texi0000644000000000000000000000013214542551763014340 xustar0030 mtime=1703597043.240022802 30 atime=1744294999.797961481 30 ctime=1744351535.610908071 gcl-2.7.1/info/chap-20.texi0000644000175000017500000005421014542551763013740 0ustar00cammcamm @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.7.1/info/PaxHeaders/debug.texi0000644000000000000000000000013114776006046014271 xustar0030 mtime=1744309286.182034498 29 atime=1744309286.29003502 30 ctime=1744351535.622907963 gcl-2.7.1/info/debug.texi0000644000175000017500000001241214776006046013670 0ustar00cammcamm@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.7.1/info/PaxHeaders/chap-17.texi0000644000000000000000000000013214542551763014346 xustar0030 mtime=1703597043.236022796 30 atime=1744294999.833961638 30 ctime=1744351535.606908106 gcl-2.7.1/info/chap-17.texi0000644000175000017500000023133514542551763013753 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-6.texi0000644000000000000000000000013214542551763014264 xustar0030 mtime=1703597043.248022815 30 atime=1744294999.873961814 30 ctime=1744351535.614908035 gcl-2.7.1/info/chap-6.texi0000644000175000017500000030366014542551763013672 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-21.texi0000644000000000000000000000013214763573237014346 xustar0030 mtime=1741616799.677591263 30 atime=1744294999.873961814 30 ctime=1744351535.610908071 gcl-2.7.1/info/chap-21.texi0000644000175000017500000033611614763573237013756 0ustar00cammcamm @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 accommodate at least the specified type, ;; but might accommodate other types. Further note that even if it does ;; accommodate 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 accommodate 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.7.1/info/PaxHeaders/chap-2.texi0000644000000000000000000000013214542551763014260 xustar0030 mtime=1703597043.240022802 30 atime=1744294999.873961814 30 ctime=1744351535.606908106 gcl-2.7.1/info/chap-2.texi0000644000175000017500000030610714542551763013665 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-a.texi0000644000000000000000000000013214542551763014337 xustar0030 mtime=1703597043.252022821 30 atime=1744294999.885961866 30 ctime=1744351535.618907999 gcl-2.7.1/info/chap-a.texi0000644000175000017500000000731114542551763013737 0ustar00cammcamm @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.7.1/info/PaxHeaders/gcl.info-30000644000000000000000000000013214776130460014071 xustar0030 mtime=1744351536.846896994 30 atime=1744351536.690898392 30 ctime=1744351538.790879598 gcl-2.7.1/info/gcl.info-30000644000175000017500000112051214776130460013471 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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:: ............... pronounced p\=e'set ,ky\"u 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 following 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::  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. gcl-2.7.1/info/PaxHeaders/gcl-dwdoc.texi0000644000000000000000000000013214776006046015047 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.258034866 30 ctime=1744351535.574908393 gcl-2.7.1/info/gcl-dwdoc.texi0000644000175000017500000011062014776006046014445 0ustar00cammcamm\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-dwdoc.info @settitle GCL DWDOC Manual @c @synindex vr fn @c to update the menus do: @c (texinfo-multiple-files-update "gcl-si.texi" t t) @setchapternewpage odd @ifinfo This is a Texinfo GCL DWDOC Manual Copyright 1994 William F. Schelter Copyright 08 Oct 92; 08 Oct 93; 16 Nov 94; 05 Jan 95; 25 Jan 06; 26 Jan 06; 08 Dec 08 Gordon S. Novak Jr. Copyright 2024 Camm Maguire @format INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-dwdoc: (gcl-dwdoc.info). GNU Common Lisp Dwdoc END-INFO-DIR-ENTRY @end format @end ifinfo @titlepage @sp 10 @comment The title is printed in a large font. @center @titlefont{GCL DWDOC Manual} @end titlepage @node Top @top Top @strong{Interface from GCL to X Windows}@* Gordon S. Novak Jr.@* 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. @menu * Introduction:: * Examples and Utilities:: * Menus:: * Windows:: * Drawing Functions:: * Fonts Operations Colors:: * Mouse Interaction:: * Miscellaneous Functions:: * Examples:: * Web Interface:: * Files:: * Data Types:: * Copyright:: @end menu @node Introduction @chapter Introduction @anchor{#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: @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 @code{dwindow} functions easier to use. There is little documentation of these functions, but the Xlib documentation can be consulted, and the @code{dwindow} functions can be examined as examples. @item The @code{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 @code{dwindow.lsp}; this file is compiled into a file in plain Lisp, @code{dwtrans.lsp}. @code{dwtrans.lsp} is compiled as part of XGCL. The functions in this package use the convention that the coordinate @code{(0 0)} is the lower-left corner of a window, with positive @code{y} being upward. This is different from the convention used by X, which assumes that @code{(0 0)} is the upper left corner and that positive @code{y} is downward. In the descriptions below, some function arguments are shown with a type, e.g. @code{arg:type}, to indicate the expected type of the argument. The type @code{vector} is a list @code{(x y)} of integers. The argument @code{w} that is used with many functions is of type @code{window} (@code{window} is a Lisp data structure used by the @code{dwindow} functions). Both the Xlib and @code{dwindow} functions are in the package @code{xlib:}. In order to use these functions, the Lisp command @code{(use-package 'xlib)} should be used to import the @code{dwindow} symbols. @node Examples and Utilities @chapter Examples and Utilities @anchor{#examples-and-utilities} @menu * dwtest:: * pcalc:: * draw:: * editors:: @end menu @node dwtest @section @code{dwtest} @anchor{#dwtest} The file @code{dwtest.lsp} contains example functions that illustrate the use of the @code{dwindow} package. The function call @code{(wtesta)} creates a small window for testing. @code{(wtestb)} through @code{(wtestk)} perform drawing and mouse interaction tests using the window. These functions may be consulted as examples of the use of commonly used @code{dwindow} functions. @node pcalc @section @code{pcalc} @anchor{#pcalc} The file @code{pcalc.lsp} implements a pocket calculator as a @code{picmenu}; its entry is @code{(pcalc)}. @node draw @section @code{draw} @anchor{#draw} The file @code{drawtrans.lsp} contains an interactive drawing program; its entry is @code{(draw 'foo)} where @code{foo} is the name of the drawing. The file @code{ice-cream.lsp} can be loaded, followed by @code{(draw 'ice-cream)} to examine an example drawing. @code{draw} can produce a Lisp program or a set of LaTeX@ commands to recreate the drawing; use @code{origin to zero} before making a program. @code{(draw-out file names)} will write definitions of drawings in the list @code{names} to the file @code{file}. @node editors @section @code{editors} @anchor{#editors} The file @code{editorstrans.lsp} contains some interactive editing programs; it is a translation of the file @code{editors.lsp} . One useful editor is the color editor; after entering @code{(wtesta)} (in file @code{dwtest.lsp}), enter @code{(edit-color myw)} to edit a color. The result is an @code{rgb} list as used in @code{window-set-color}. A simple line editor and an Emacs-like text editor are described in sections @ref{#texted,6.2} and @ref{#emacsed,6.3} below. @node Menus @chapter Menus @anchor{#menus} The function @code{menu} provides an easy interface to make a pop-up menu, get a selection from it, and destroy it:@* @code{ (menu items &optional title)}@* Example: @code{(menu '(red white blue))} This simple call is all that is needed in most cases. More sophisticated menu features are described below. The @code{items} in a menu is a list; each item may be a symbol, a @code{cons} of a symbol or string and the corresponding value, or a @code{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 @code{(fn w x y)}, where @code{w} is the window and @code{x} and @code{y} are the lower-left corner of the drawing area. The property list of the function name should have the property @code{display-size}, which should be a list @code{(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 @emph{permanent} (left displayed after a selection is made) and may be @emph{flat} (drawn directly on the containing window, rather than having its own window). A menu can be created by @code{menu-create} :@* @code{ (menu-create items &optional title w:window x y perm flat font)}@* @code{title}, if specified, is displayed over the menu. @code{w} is an existing @code{window}; if specified, the menu is put within this window at the @code{x y} offsets specified (adjusted if necessary to keep the menu inside the window). If no @code{w} is specified, or if @code{x} is @code{nil}, the menu is put where the cursor is the first time the menu is displayed. @code{perm} is non-@code{nil} if the menu is to be permanent, @emph{i.e.}, is to be left displayed after a selection has been made. @code{flat} is non-@code{nil} if the menu is to be drawn directly on the containing window. @code{font} is a symbol or string that names the font to be used; the default is a @code{9x15} typewriter font. The menu is returned as the value of @code{menu-create}. Such a menu can be saved; selections can be made from a menu @code{m} as follows:@* @code{ (menu-select m &optional inside)} @ @ @ @ @ or @code{ (menu-select! m)}@* @code{menu-select} will return @code{nil} if the mouse is clicked outside the menu, or is moved outside after it has been inside (or if @code{inside} is not @code{nil}), provided that the menu is contained within a user-created window. @code{menu-select!} requires that a choice be made. In order to avoid wasting storage, unused menus should be destroyed: @code{(menu-destroy m)}. The simple @code{menu} function destroys its menu after it is used. @code{ (menu-size m)}@* @code{ (menu-moveto-xy m x y)}@* @code{ (menu-reposition m)} @ @code{menu-reposition} will reposition a @code{flat} menu within its parent window by allowing the user to position a ghost box using the mouse. @code{menu-size} returns the size of the menu as a vector, @code{(x y)}. @code{menu-moveto-xy} adjusts the offsets to move a @code{flat} menu to the specified position within its parent window. These functions and @code{menu-destroy} work for picmenus and barmenus as well. @code{ (menu-item-position m name &optional location)}@* @code{menu-item-position} returns a vector @code{(x y)} that gives the coordinates of the menu item whose name is @code{name}. @code{location} may be @code{center}, @code{left}, @code{right}, @code{top}, or @code{bottom}; the default is the lower-left corner of the menu item. @code{center} specifies the center of the box containing the menu item; the other @code{location} values are at the center of the specified edge of the box. @menu * Picmenus:: * Barmenus:: * Menu Sets and Menu Conns:: @end menu @node Picmenus @section Picmenus @anchor{#picmenus} A @code{picmenu} (picture menu) is analogous to a menu, but involves a user-defined picture containing sensitive spots or ``buttons''. The test function @code{(wteste)} shows an example of a @code{picmenu}. A @code{picmenu} is created by:@* @code{ (picmenu-create buttons width height drawfn}@* @code{&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 @code{picmenu-spec} and reused: @code{ (picmenu-create-spec buttons width height drawfn}@* @code{&optional dotflg font)}@* @code{ (picmenu-create-from-spec spec:picmenu-spec}@* @code{&optional title w:window x y perm flat boxflg)}@* @code{width} and @code{height} are the size of the area occupied by the picture. @code{(drawfn w x y)} should draw the picture at the offset @code{x y}. Note that the @code{draw} utility can be used to make the drawing function, including @code{picmenu} buttons. @code{dotflg} is non-@code{nil} if it is desired that small boxes be automatically added to the sensitive points when the picture is drawn. @code{boxflg} is non-@code{nil} if a box is to be drawn around the picmenu when the picture is drawn (this is only needed for flat picmenus). If @code{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 @code{picmenu}; this avoids the need to redraw a complex picture. The remaining arguments are as described for menus. Each of the @code{buttons} in a picmenu is a list:@* @code{ (buttonname offset size highlightfn unhighlightfn)}@* @code{buttonname} is the name of the button; it is the value returned when that button is selected. @code{offset} is a vector @code{(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. @code{size} is an optional list @code{(width height)} that gives the size of the sensitive area of the button; the default size is @code{(12@ 12)}. @code{(highlightfn w x y)} and @code{(unhighlightfn w x y)} (where @code{(x y)} is the center of the button in the coordinates of @code{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 @code{size}. @code{ (picmenu-select m &optional inside)}@* If the @code{picmenu} is not @code{flat}, its window should be destroyed following the selection using @code{menu-destroy}. @code{ (picmenu-item-position m name &optional location)}@* @code{ (picmenu-delete-named-button m name:symbol)}@* This deletes a button from a displayed @code{picmenu}. The set of deleted buttons is reset to @code{nil} when the picmenu is drawn. @node Barmenus @section Barmenus @anchor{#barmenus} A @code{barmenu} displays a bar graph whose size can be adjusted using the mouse. @code{ (barmenu-create maxval initval barwidth}@* @code{&optional title horizontal subtrackfn subtrackparms}@* @code{parentw x y perm flat color)} A value is selected by: @code{(barmenu-select m:barmenu &optional inside)}@* If the @code{barmenu} is not @code{flat}, its window should be destroyed following the selection using @code{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 @code{subtrackfn} is called with arguments of the size of the bar followed by the @code{subtrackparms}; this can be used, for example, to display a numeric value in addition to the bar size. @node Menu Sets and Menu Conns @section Menu Sets and Menu Conns @anchor{#menu-sets-and-menu-conns} A @code{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 @code{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 @code{menu-set.lsp}; this file is translated as part of the file @code{drawtrans.lsp} in plain Lisp. Examples of the use of menu sets are given at the top of the file @code{menu-set.lsp}. In the following descriptions, @code{ms} is a @code{menu-set} and @code{mc} is a @code{menu-conns}. @code{ (menu-set-create w)} creates a menu set to be displayed in the window @code{w}. @code{ (menu-set-name symbol)} makes a @code{gensym} name that begins with @code{symbol}. @code{ (menu-set-add-menu ms name:symbol sym title items}@* @code{&optional offset:vector)} This function adds a menu to a menu-set. @code{sym} is arbitrary information that is saved with the menu. @code{ (menu-set-add-picmenu ms name sym title spec:picmenu-spec}@* @code{&optional offset:vector nobox)} @code{ (menu-set-add-component ms name &optional offset:vector)} This adds a component that has a @code{picmenu-spec} defined on the property list of @code{name}. @code{ (menu-set-add-barmenu ms name sym barmenu title}@* @code{&optional offset:vector)} @code{ (menu-set-draw ms)} draws all the menus. @code{ (menu-set-select ms &optional redraw enabled)} @code{menu-set-select} gets a selection from a menu-set. If @code{redraw} is non-@code{nil}, the menu-set is drawn. @code{enabled} may be a list of names of menus that are enabled for selection. The result is @code{(selection menu-name)}, or @code{((x y) BACKGROUND button)} for a click outside any menu. @code{ (menu-conns-create ms)} creates a @code{menu-conns} from a @code{menu-set}. @code{ (menu-conns-add-conn mc)} This function allows the user to select two ports from menus of the @code{menu-conns}. It then draws a line between the ports and adds the connection to the @code{connections} of the @code{menu-conns}. @code{ (menu-conns-move mc)} This function allows the user to select a menu and move it. The @code{menu-set} and connections are redrawn afterwards. @code{ (menu-conns-find-conn mc pt:vector)}@* This finds the connection selected by the point @code{pt}, if any. This is useful to allow the user to delete a connection: @code{ (menu-conns-delete-conn mc conn)} @code{ (menu-conns-find-conns mc menuname port)}@* This returns all the connections from the specified @code{port} (selection) of the menu whose name is @code{menuname}. @node Windows @chapter Windows @anchor{#windows} @code{ (window-create width height &optional title parentw x y font)}@* @code{window-create} makes a new window of the specified @code{width} and @code{height}. @code{title}, if specified, becomes the displayed title of the window. If @code{parentw} is specified, it should be the @code{window-parent} property of an existing window, which becomes the parent window of the new window. @code{x} and @code{y} are the offset of the new window from the parent window. @code{font} is the font to be used for printing in the window; the default is given by @code{window-default-font-name*}, initially @code{courier-bold-12}. @code{ (window-open w)} causes a window to be displayed on the screen. @code{ (window-close w)} removes the window from the display; it can be re-opened. @code{ (window-destroy w)} @code{ (window-moveto-xy w x y)} @code{ (window-geometry w)} queries X for the window geometry. The result is a list, @code{(x y width height border-width)} . @code{ (window-size w)} returns a list @code{(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 @code{(window-reset-geometry@ w)} to reset the local parameters to their correct values. The following functions provide access to the parts of the @code{window} data structure; most applications will not need to use them.@* @code{ (window-gcontext w)}@* @code{ (window-parent w)}@* @code{ (window-drawable-height w)}@* @code{ (window-drawable-width w)}@* @code{ (window-label w)}@* @code{ (window-font w)}@* @code{ (window-screen-height)}@* @node Drawing Functions @chapter Drawing Functions @anchor{#drawing-functions} @code{ (window-clear w)} clears the window to the background color. @code{ (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. @code{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 @code{w} is not used. In all of the drawing functions, the @code{linewidth} argument is optional and defaults to @code{1}. @code{ (window-draw-line w from:vector to:vector linewidth)}@* @code{ (window-draw-line-xy w x1 y1 x2 y2 &optional linewidth op)}@* @code{op} may be @code{xor} or @code{erase}. @code{ (window-draw-arrow-xy w x1 y1 x2 y2 &optional linewidth size)}@* @code{ (window-draw-arrow2-xy w x1 y1 x2 y2 &optional linewidth size)}@* @code{ (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. @code{size} is the arrowhead size; the default is @code{(+ 20 (* linewidth 5))}. @code{ (window-draw-box-xy w x y width height linewidth)}@* @code{ (window-xor-box-xy w x y width height linewidth)}@* @code{ (window-draw-box w offset:vector size:vector linewidth)}@* @code{ (window-draw-box-corners w x1 y1 x2 y2 linewidth)}@* where @code{(x1 y1)} and @code{(x2 y2)} are opposite corners.@* @code{ (window-draw-rcbox-xy w x y width height radius linewidth)}@* draws a box with rounded corners. @code{ (window-draw-arc-xy w x y radiusx radiusy anglea angleb linewidth)} @code{anglea} is the angle, in degrees, at which the arc is started. @code{angleb} is the angle, in degrees, that specifies the amount of arc to be drawn, counterclockwise from the starting position. @code{ (window-draw-circle-xy w x y radius linewidth)}@* @code{ (window-draw-circle w center:vector radius linewidth)}@* @code{ (window-draw-ellipse-xy w x y radiusx radiusy linewidth)}@* @code{ (window-draw-dot-xy w x y)} @code{ (window-erase-area-xy w left bottom width height)}@* @code{ (window-erase-area w offset:vector size:vector)}@* @code{ (window-copy-area-xy w fromx fromy tox toy width height)}@* @code{ (window-invert-area w offset:vector size:vector)}@* @code{ (window-invert-area-xy w left bottom width height)} @code{ (window-printat-xy w s x y)}@* @code{ (window-printat w s at:vector)}@* @code{ (window-prettyprintat-xy w s x y)}@* @code{ (window-prettyprintat w s at:vector)}@* The argument @code{s} is printed at the specified position. @code{s} is stringified if necessary. Currently, the pretty-print versions are the same as the plain versions. @code{ (window-draw-border w)} draws a border just inside a window. @node Fonts Operations Colors @chapter Fonts, Operations, Colors @anchor{#fonts-operations-colors} @code{ (window-set-font w font)} The font symbols that are currently defined are @code{courier-bold-12}, @code{8x10}, and @code{9x15} . The global variable @code{window-fonts*} contains correspondences between font symbols and font strings. A font string may also be specified instead of a font symbol. @code{ (window-string-width w s)}@* @code{ (window-string-extents w s)}@* These give the width and the vertical size @code{(ascent descent)} in pixels of the specified string @code{s} using the font of the specified window. @code{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 @code{window-unset}. @code{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. @code{ (window-set-xor w)}@* @code{ (window-set-erase w)}@* @code{ (window-set-copy w)}@* @code{ (window-set-invert w)}@* @code{ (window-unset w)}@* @code{ (window-reset w)}@* @code{ (window-set-line-width w width)}@* @code{ (window-set-line-attr w width &optional line-style cap-style join-style)}@* @code{ (window-std-line-attr w)}@* @code{ (window-foreground w)}@* @code{ (window-set-foreground w fg-color)}@* @code{ (window-background w)}@* @code{ (window-set-background w bg-color)}@* @menu * Color:: * Character Input:: * Emacs-like Editing:: @end menu @node Color @section Color @anchor{#color} The color of the foreground (things that are drawn, such as lines or characters) is set by: @code{ (window-set-color w rgb &optional background)}@* @code{ (window-set-color-rgb w r g b &optional background)}@* @code{rgb} is a list @code{(red green blue)} of 16-bit unsigned integers in the range @code{0} to @code{65535}. @code{background} is non-@code{nil} to set the background color rather than the foreground color. @code{ (window-reset-color w)}@* @code{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. @code{window-set-color} will leave the global variable @code{window-xcolor*} set to an integer value that denotes an X color; this value should be saved and used as the argument to @code{window-free-color} to release the color after it is no longer needed. @code{ (window-free-color w &optional xcolor)}@* @code{window-free-color} frees either the last color used, as given by @code{window-xcolor*}, or the specified color. @node Character Input @section Character Input @anchor{#texted} Characters can be input within a window by the call: @code{ (window-input-string w str x y &optional size)}@* @code{window-input-string} will print the initial string @code{str}, if non-@code{nil}, at the specified position in the window; @code{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 @code{str}. An area of width @code{size} (default 100) is erased to the right of the initial caret. @node Emacs-like Editing @section Emacs-like Editing @anchor{#emacsed} @code{window-edit} allows editing of text using an Emacs-subset editor. Only a few simple Emacs commands are implemented. @verbatim (window-edit w x y width height &optional strings boxflg scroll endp) @end verbatim @code{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. @code{strings} is an initial list of strings; the return value is a list of strings. @code{scroll} is number of lines to scroll down before displaying text, or @code{T} to have one line only and terminate on return. @code{endp} is @code{T} to begin editing at the end of the first line. Example: @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 @node Mouse Interaction @chapter Mouse Interaction @anchor{#mouse-interaction} @code{ (window-get-point w)}@* @code{ (window-get-crosshairs w)}@* @code{ (window-get-cross w)}@* These functions get a point position by mouse click; they return @code{(x y)} . The following function gets a point position by mouse click. It returns @code{(button (x y))} where @code{button} is @code{1} for the left button, @code{2} for middle, @code{3} for right. @code{ (window-get-click w)}@* The following function gets a point position by mouse click within a specified region. It returns @code{(button (x y))} or @code{NIL} if the mouse leaves the region. If @code{boxflg} is @code{t}, a box will be drawn outside the region while the mouse is being tracked. @code{ (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 @code{(x y)} at the cursor position when a mouse button is clicked. The @code{latex} version restricts the slope of the line to be a slope that LaTeX@ can draw; if @code{flg} is non-@code{nil}, the slope is restricted to be a LaTeX@ @code{vector} slope. @code{ (window-get-line-position w orgx orgy)}@* @code{ (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 @code{fn}. This allows exact positioning of an object by the user. @code{ (window-get-icon-position w fn args &optional (dx 0) (dy 0))}@* The function @code{fn} has arguments @code{(fn w x y . args)} , where @code{x} and @code{y} are the offset within the window @code{w} at which the icon is to be drawn, and @code{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 @code{xor} mode, so it must be drawn using only ``plain'' drawing functions, without resetting window attributes. The returned value is @code{(x y)} at the cursor position when a button is clicked. @code{dx} and @code{dy}, if specified, are offsets of @code{x} and @code{y} from the cursor position. The following function gets a position by moving a ``ghost'' box icon. @code{ (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; @code{dx} and @code{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 @code{(x y)} at the cursor position when a button is clicked. The following function gets coordinates of a box of arbitrary size and position. @code{ (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 @code{((x y) (width height))}, where @code{(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. @code{offsety} should be at least @code{30} to leave room to display the size of the box. @code{ (window-get-box-size w offsetx offsety)}@* The following function adjusts one side of a box. @code{ (window-adjust-box-side w x y width height side)}@* @code{side} specifies the side of the box to be adjusted: @code{left}, @code{right}, @code{top}, or @code{bottom}. The result is @code{((x y) (width height))} for the resulting box. @code{ (window-get-circle w &optional center:vector)}@* @code{ (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. @code{window-get-circle} returns @code{((x y) radius)}. @code{window-get-ellipse} returns @code{((x y) (xradius yradius))}. @code{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. @code{ (window-track-mouse w fn &optional outflg)} Each time the mouse position changes or a mouse button is pressed, the function @code{fn} is called with arguments @code{(x y code)} where @code{x} and @code{y} are the cursor position, @code{code} is a button code (@code{0} if no button, @code{1} for the left button, @code{2} for the middle button, or @code{3} for the right button). @code{window-track-mouse} continues to track the mouse until @code{fn} returns a value other than @code{nil}, at which time @code{window-track-mouse} returns that value. Usually, it is a good idea for @code{fn} to return a value other than @code{nil} upon a mouse click. If the argument @code{outflg} is non-@code{nil}, the function @code{fn} will be called for button clicks outside the window @code{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 @code{w} is inside another Lisp user window. @node Miscellaneous Functions @chapter Miscellaneous Functions @anchor{#miscellaneous-functions} @code{ (stringify x)} makes its argument into a string. @code{ (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. @node Examples @chapter Examples @anchor{#examples} Several interactive programs using this software for their graphical interface can be found at @code{http://www.cs.utexas.edu/users/novak/} under the heading Software Demos. @node Web Interface @chapter Web Interface @anchor{#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: @code{http://www.cs.utexas.edu/users/novak/dwindow.html} @node Files @chapter Files @anchor{#files} @multitable {@code{lispservertrans.lsp}} {Drawing of an ice cream cone made with @code{draw}} @item @code{dec.copyright} @tab Copyright and license for DEC/MIT files @item @code{draw.lsp} @tab GLISP source code for interactive drawing utility @item @code{drawtrans.lsp} @tab @code{draw.lsp} translated into plain Lisp @item @code{draw-gates.lsp} @tab Code to draw @code{nand} gates etc. @item @code{dwdoc.tex} @tab LaTeX@ source for this document @item @code{dwexports.lsp} @tab exported symbols @item @code{dwimportsb.lsp} @tab imported symbols @item @code{dwindow.lsp} @tab GLISP source code for @code{dwindow} functions @item @code{dwtest.lsp} @tab Examples of use of @code{dwindow} functions @item @code{dwtrans.lsp} @tab @code{dwindow.lsp} translated into plain Lisp @item @code{editors.lsp} @tab Editors for colors etc. @item @code{editorstrans.lsp} @tab translation of @code{editors.lsp} @item @code{gnu.license} @tab GNU General Public License @item @code{ice-cream.lsp} @tab Drawing of an ice cream cone made with @code{draw} @item @code{lispserver.lsp} @tab Example web demo: a Lisp server @item @code{lispservertrans.lsp} @tab translation of @code{lispserver.lsp} @item @code{menu-set.lsp} @tab GLISP source code for menu-set functions @item @code{menu-settrans.lsp} @tab translation of @code{menu-set.lsp} @item @code{pcalc.lsp} @tab Pocket calculator implemented as a @code{picmenu} @end multitable @node Data Types @chapter Data Types @anchor{#data-types} @verbatim (window (listobject (parent drawable) (gcontext anything) (drawable-height integer) (drawable-width integer) (label string) (font anything) ) @end verbatim @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 @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 @verbatim (picmenu-spec (listobject (drawing-width integer) (drawing-height integer) (buttons (listof picmenu-button)) (dotflg boolean) (drawfn anything) (menu-font symbol) )) @end verbatim @verbatim (picmenu-button (list (buttonname symbol) (offset vector) (size vector) (highlightfn anything) (unhighlightfn anything)) @end verbatim @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 @node Copyright @chapter Copyright @anchor{#copyright} The following copyright notice applies to the portions of the software that were adapted from X Consortium software: @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 @bye gcl-2.7.1/info/PaxHeaders/chap-3.texi0000644000000000000000000000013214542551763014261 xustar0030 mtime=1703597043.248022815 30 atime=1744294999.969962233 30 ctime=1744351535.614908035 gcl-2.7.1/info/chap-3.texi0000644000175000017500000076454614542551763013705 0ustar00cammcamm @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.7.1/info/PaxHeaders/chap-16.texi0000644000000000000000000000013214542551763014345 xustar0030 mtime=1703597043.236022796 30 atime=1744294999.973962251 30 ctime=1744351535.606908106 gcl-2.7.1/info/chap-16.texi0000644000175000017500000005615014542551763013752 0ustar00cammcamm @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.7.1/info/PaxHeaders/gcl.info-70000644000000000000000000000013214776130461014076 xustar0030 mtime=1744351537.522890942 30 atime=1744351537.366892338 30 ctime=1744351538.794879562 gcl-2.7.1/info/gcl.info-70000644000175000017500000111345014776130461013501 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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 accommodate 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 accommodate at least the specified type, ;; but might accommodate other types. Further note that even if it does ;; accommodate 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 accommodate 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::  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 gcl-2.7.1/info/PaxHeaders/chap-19.texi0000644000000000000000000000013214763573237014355 xustar0030 mtime=1741616799.677591263 30 atime=1744294999.985962303 30 ctime=1744351535.606908106 gcl-2.7.1/info/chap-19.texi0000644000175000017500000026734514763573237013774 0ustar00cammcamm @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 accommodate 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.7.1/info/PaxHeaders/chap-4.texi0000644000000000000000000000013214770115542014254 xustar0030 mtime=1742773090.675428033 30 atime=1744294999.989962321 30 ctime=1744351535.614908035 gcl-2.7.1/info/chap-4.texi0000644000175000017500000031034414770115542013657 0ustar00cammcamm @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.7.1/info/PaxHeaders/gcl-tk.info-20000644000000000000000000000013114776130462014505 xustar0030 mtime=1744351538.774879741 29 atime=1744351538.75487992 30 ctime=1744351538.810879419 gcl-2.7.1/info/gcl-tk.info-20000644000175000017500000016356014776130462014117 0ustar00cammcammThis is gcl-tk.info, produced by makeinfo version 7.1 from gcl-tk.texi. This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-tk: (gcl-tk.info). GNU Common Lisp Tk Manual END-INFO-DIR-ENTRY  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.7.1/info/PaxHeaders/gcl.info-50000644000000000000000000000013114776130461014073 xustar0030 mtime=1744351537.174894057 29 atime=1744351536.98689574 30 ctime=1744351538.790879598 gcl-2.7.1/info/gcl.info-50000644000175000017500000111031214776130461013471 0ustar00cammcammThis is gcl.info, produced by makeinfo version 7.1 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: 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 accommodate 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 association 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)  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)) gcl-2.7.1/PaxHeaders/minvers0000644000000000000000000000013214776101325012760 xustar0030 mtime=1744339669.962517997 30 atime=1744339701.746712669 30 ctime=1744351535.730906995 gcl-2.7.1/minvers0000755000175000017500000000000414776101325012353 0ustar00cammcamm7.1 gcl-2.7.1/PaxHeaders/missing0000644000000000000000000000013214776130437012754 xustar0030 mtime=1744351519.791050933 30 atime=1744351519.979049222 30 ctime=1744351535.450909505 gcl-2.7.1/missing0000755000175000017500000001706014776130437012361 0ustar00cammcamm#! /bin/sh # Common wrapper for a few potentially missing GNU and other programs. scriptversion=2024-06-07.14; # UTC # shellcheck disable=SC2006,SC2268 # we must support pre-POSIX shells # Copyright (C) 1996-2024 Free Software Foundation, Inc. # Originally written by Fran,cois Pinard , 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, 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. if test $# -eq 0; then echo 1>&2 "Try '$0 --help' for more information" exit 1 fi case $1 in --is-lightweight) # Used by our autoconf macros to check whether the available missing # script is modern enough. exit 0 ;; --run) # Back-compat with the calling convention used by older automake. shift ;; -h|--h|--he|--hel|--help) echo "\ $0 [OPTION]... PROGRAM [ARGUMENT]... Run 'PROGRAM [ARGUMENT]...', returning a proper advice when this fails due to PROGRAM being missing or too old. Options: -h, --help display this help and exit -v, --version output version information and exit Supported PROGRAM values: aclocal autoconf autogen autoheader autom4te automake autoreconf bison flex help2man lex makeinfo perl yacc Version suffixes to PROGRAM as well as the prefixes 'gnu-', 'gnu', and 'g' are ignored when checking the name. Report bugs to . GNU Automake home page: . General help using GNU software: ." exit $? ;; -v|--v|--ve|--ver|--vers|--versi|--versio|--version) echo "missing (GNU Automake) $scriptversion" exit $? ;; -*) echo 1>&2 "$0: unknown '$1' option" echo 1>&2 "Try '$0 --help' for more information" exit 1 ;; esac # Run the given program, remember its exit status. "$@"; st=$? # If it succeeded, we are done. test $st -eq 0 && exit 0 # Also exit now if we it failed (or wasn't found), and '--version' was # passed; such an option is passed most likely to detect whether the # program is present and works. case $2 in --version|--help) exit $st;; esac # Exit code 63 means version mismatch. This often happens when the user # tries to use an ancient version of a tool on a file that requires a # minimum version. if test $st -eq 63; then msg="probably too old" elif test $st -eq 127; then # Program was missing. msg="missing on your system" else # Program was found and executed, but failed. Give up. exit $st fi perl_URL=https://www.perl.org/ flex_URL=https://github.com/westes/flex gnu_software_URL=https://www.gnu.org/software program_details () { case $1 in aclocal|automake|autoreconf) echo "The '$1' program is part of the GNU Automake package:" echo "<$gnu_software_URL/automake>" echo "It also requires GNU Autoconf, GNU m4 and Perl in order to run:" echo "<$gnu_software_URL/autoconf>" echo "<$gnu_software_URL/m4/>" echo "<$perl_URL>" ;; autoconf|autom4te|autoheader) echo "The '$1' program is part of the GNU Autoconf package:" echo "<$gnu_software_URL/autoconf/>" echo "It also requires GNU m4 and Perl in order to run:" echo "<$gnu_software_URL/m4/>" echo "<$perl_URL>" ;; *) : ;; esac } give_advice () { # Normalize program name to check for. normalized_program=`echo "$1" | sed ' s/^gnu-//; t s/^gnu//; t s/^g//; t'` printf '%s\n' "'$1' is $msg." configure_deps="'configure.ac' or m4 files included by 'configure.ac'" autoheader_deps="'acconfig.h'" automake_deps="'Makefile.am'" aclocal_deps="'acinclude.m4'" case $normalized_program in aclocal*) echo "You should only need it if you modified $aclocal_deps or" echo "$configure_deps." ;; autoconf*) echo "You should only need it if you modified $configure_deps." ;; autogen*) echo "You should only need it if you modified a '.def' or '.tpl' file." echo "You may want to install the GNU AutoGen package:" echo "<$gnu_software_URL/autogen/>" ;; autoheader*) echo "You should only need it if you modified $autoheader_deps or" echo "$configure_deps." ;; automake*) echo "You should only need it if you modified $automake_deps or" echo "$configure_deps." ;; autom4te*) echo "You might have modified some maintainer files that require" echo "the 'autom4te' program to be rebuilt." ;; autoreconf*) echo "You should only need it if you modified $aclocal_deps or" echo "$automake_deps or $autoheader_deps or $automake_deps or" echo "$configure_deps." ;; bison*|yacc*) echo "You should only need it if you modified a '.y' file." echo "You may want to install the GNU Bison package:" echo "<$gnu_software_URL/bison/>" ;; help2man*) echo "You should only need it if you modified a dependency" \ "of a man page." echo "You may want to install the GNU Help2man package:" echo "<$gnu_software_URL/help2man/>" ;; lex*|flex*) echo "You should only need it if you modified a '.l' file." echo "You may want to install the Fast Lexical Analyzer package:" echo "<$flex_URL>" ;; makeinfo*) echo "You should only need it if you modified a '.texi' file, or" echo "any other file indirectly affecting the aspect of the manual." echo "You might want to install the Texinfo package:" echo "<$gnu_software_URL/texinfo/>" echo "The spurious makeinfo call might also be the consequence of" echo "using a buggy 'make' (AIX, DU, IRIX), in which case you might" echo "want to install GNU make:" echo "<$gnu_software_URL/make/>" ;; perl*) echo "You should only need it to run GNU Autoconf, GNU Automake, " echo " assorted other tools, or if you modified a Perl source file." echo "You may want to install the Perl 5 language interpreter:" echo "<$perl_URL>" ;; *) echo "You might have modified some files without having the proper" echo "tools for further handling them. Check the 'README' file, it" echo "often tells you about the needed prerequisites for installing" echo "this package. You may also peek at any GNU archive site, in" echo "case some other package contains this missing '$1' program." ;; esac program_details "$normalized_program" } give_advice "$1" | sed -e '1s/^/WARNING: /' \ -e '2,$s/^/ /' >&2 # Propagate the correct exit status (expected to be 127 for a program # not found, 63 for a program that failed due to version mismatch). exit $st # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: gcl-2.7.1/PaxHeaders/unixport0000644000000000000000000000013214776130457013175 xustar0030 mtime=1744351535.598908178 30 atime=1744351538.814879383 30 ctime=1744351535.598908178 gcl-2.7.1/unixport/0000755000175000017500000000000014776130457012650 5ustar00cammcammgcl-2.7.1/unixport/PaxHeaders/sys_init.c0000644000000000000000000000013214776006046015253 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.314035136 30 ctime=1744351535.598908178 gcl-2.7.1/unixport/sys_init.c0000644000175000017500000001571014776006046014655 0ustar00cammcamm#include "sys.c" void gcl_init_init() { build_symbol_table(); #if defined(pre_gcl) || defined(ansi_gcl) { object features=find_symbol(make_simple_string("*FEATURES*"),system_package); #if defined(pre_gcl) { extern int in_pre_gcl; features->s.s_dbind=make_cons(make_keyword("PRE-GCL"),features->s.s_dbind); in_pre_gcl=1; } #else features->s.s_dbind=make_cons(make_keyword("ANSI-CL"),make_cons(make_keyword("COMMON-LISP"),features->s.s_dbind)); #endif } #endif lsp_init("lsp","gcl_export"); lsp_init("lsp","gcl_defmacro");/*Just for defvar in top*/ lsp_init("lsp","gcl_evalmacros"); lsp_init("lsp","gcl_top"); lsp_init("lsp","gcl_autoload"); } void gcl_init_system(object no_init) { if (type_of(no_init)!=t_symbol) error("Supplied no_init is not of type symbol\n"); check_init(lsp,gcl_s,no_init); check_init(lsp,gcl_sf,no_init); check_init(lsp,gcl_rm,no_init); check_init(lsp,gcl_dl,no_init); check_init(lsp,gcl_fle,no_init); check_init(lsp,gcl_defmacro,no_init); check_init(lsp,gcl_hash,no_init); check_init(lsp,gcl_evalmacros,no_init); check_init(lsp,gcl_module,no_init); check_init(lsp,gcl_predlib,no_init); check_init(lsp,gcl_deftype,no_init); check_init(lsp,gcl_typeof,no_init); check_init(lsp,gcl_subtypep,no_init); check_init(lsp,gcl_bit,no_init); #ifndef pre_gcl check_init(lsp,gcl_bnum,no_init); #endif #ifdef pre_gcl/*FIXME coerce in compiled funcall*/ check_init(lsp,gcl_type,no_init); check_init(lsp,gcl_typecase,no_init); #endif check_init(lsp,gcl_typep,no_init); #ifndef pre_gcl check_init(lsp,gcl_type,no_init); check_init(lsp,gcl_typecase,no_init); #endif #ifndef pre_gcl check_init(lsp,gcl_c,no_init); check_init(lsp,gcl_listlib,no_init); #else check_init(lsp,gcl_defseq,no_init); #endif check_init(lsp,gcl_top,no_init); lsp_init("lsp","gcl_module"); check_init(lsp,gcl_setf,no_init); check_init(lsp,gcl_arraylib,no_init); check_init(lsp,gcl_seq,no_init); check_init(lsp,gcl_seqlib,no_init); #ifndef pre_gcl check_init(lsp,gcl_sc,no_init); #endif check_init(lsp,gcl_assert,no_init); check_init(lsp,gcl_defstruct,no_init); check_init(lsp,gcl_restart,no_init); check_init(lsp,gcl_serror,no_init); check_init(lsp,gcl_sharp,no_init); check_init(lsp,gcl_logical_pathname_translations,no_init); check_init(lsp,gcl_make_pathname,no_init); check_init(lsp,gcl_parse_namestring,no_init); check_init(lsp,gcl_merge_pathnames,no_init); check_init(lsp,gcl_pathname_match_p,no_init); check_init(lsp,gcl_namestring,no_init); check_init(lsp,gcl_wild_pathname_p,no_init); check_init(lsp,gcl_translate_pathname,no_init); check_init(lsp,gcl_truename,no_init); check_init(lsp,gcl_directory,no_init); check_init(lsp,gcl_rename_file,no_init); check_init(lsp,gcl_callhash,no_init); check_init(lsp,gcl_describe,no_init); #ifdef pre_gcl check_init(lsp,gcl_bnum,no_init); #endif #ifndef pre_gcl check_init(lsp,gcl_mnum,no_init); #endif check_init(lsp,gcl_numlib,no_init); check_init(lsp,gcl_mislib,no_init); check_init(lsp,gcl_iolib,no_init); check_init(lsp,gcl_nr,no_init); #ifndef pre_gcl check_init(lsp,gcl_lr,no_init); check_init(lsp,gcl_sym,no_init); #endif check_init(lsp,gcl_trace,no_init); check_init(lsp,gcl_sloop,no_init); check_init(lsp,gcl_packlib,no_init); check_init(lsp,gcl_fpe,no_init); check_init(cmpnew,gcl_cmptype,no_init); check_init(cmpnew,gcl_cmpinline,no_init); check_init(cmpnew,gcl_cmputil,no_init); check_init(lsp,gcl_debug,no_init); check_init(lsp,gcl_info,no_init); check_init(cmpnew,gcl_cmpbind,no_init); check_init(cmpnew,gcl_cmpblock,no_init); check_init(cmpnew,gcl_cmptop,no_init); check_init(cmpnew,gcl_cmpvar,no_init); check_init(cmpnew,gcl_cmpeval,no_init); check_init(cmpnew,gcl_cmpcall,no_init); check_init(cmpnew,gcl_cmpcatch,no_init); check_init(cmpnew,gcl_cmpenv,no_init); check_init(cmpnew,gcl_cmpflet,no_init); check_init(cmpnew,gcl_cmpfun,no_init); check_init(cmpnew,gcl_cmptag,no_init); check_init(cmpnew,gcl_cmpif,no_init); check_init(cmpnew,gcl_cmplabel,no_init); check_init(cmpnew,gcl_cmploc,no_init); check_init(cmpnew,gcl_cmpmap,no_init); check_init(cmpnew,gcl_cmpmulti,no_init); check_init(cmpnew,gcl_cmpspecial,no_init); check_init(cmpnew,gcl_cmplam,no_init); check_init(cmpnew,gcl_cmplet,no_init); check_init(cmpnew,gcl_cmpvs,no_init); check_init(cmpnew,gcl_cmpwt,no_init); check_init(cmpnew,gcl_cmpmain,no_init); #ifndef pre_gcl #ifndef gcl #ifdef HAVE_XGCL lsp_init("xgcl-2","sysdef.lisp"); check_init(xgcl-2,gcl_Xlib,no_init); check_init(xgcl-2,gcl_Xutil,no_init); check_init(xgcl-2,gcl_X,no_init); check_init(xgcl-2,gcl_XAtom,no_init); check_init(xgcl-2,gcl_defentry_events,no_init); check_init(xgcl-2,gcl_Xstruct,no_init); check_init(xgcl-2,gcl_XStruct_l_3,no_init); check_init(xgcl-2,gcl_general,no_init); check_init(xgcl-2,gcl_keysymdef,no_init); check_init(xgcl-2,gcl_X10,no_init); check_init(xgcl-2,gcl_Xinit,no_init); check_init(xgcl-2,gcl_dwtrans,no_init); check_init(xgcl-2,gcl_tohtml,no_init); check_init(xgcl-2,gcl_index,no_init); #endif check_init(mod,gcl_ansi_io,no_init); check_init(mod,gcl_destructuring_bind,no_init); check_init(mod,gcl_loop,no_init); check_init(mod,gcl_defpackage,no_init); check_init(mod,gcl_make_defpackage,no_init); #ifndef mod_gcl lsp_init("pcl","package.lisp"); check_init(pcl,gcl_pcl_pkg,no_init); check_init(pcl,gcl_pcl_walk,no_init); check_init(pcl,gcl_pcl_iterate,no_init); check_init(pcl,gcl_pcl_macros,no_init); check_init(pcl,gcl_pcl_low,no_init); check_init(pcl,gcl_pcl_impl_low,no_init); check_init(pcl,gcl_pcl_fin,no_init); check_init(pcl,gcl_pcl_defclass,no_init); check_init(pcl,gcl_pcl_defs,no_init); check_init(pcl,gcl_pcl_fngen,no_init); check_init(pcl,gcl_pcl_cache,no_init); check_init(pcl,gcl_pcl_dlisp,no_init); check_init(pcl,gcl_pcl_dlisp2,no_init); check_init(pcl,gcl_pcl_boot,no_init); check_init(pcl,gcl_pcl_vector,no_init); check_init(pcl,gcl_pcl_slots_boot,no_init); check_init(pcl,gcl_pcl_combin,no_init); check_init(pcl,gcl_pcl_dfun,no_init); check_init(pcl,gcl_pcl_fast_init,no_init); check_init(pcl,gcl_pcl_precom1,no_init); check_init(pcl,gcl_pcl_precom2,no_init); check_init(pcl,gcl_pcl_braid,no_init); check_init(pcl,gcl_pcl_generic_functions,no_init); check_init(pcl,gcl_pcl_slots,no_init); check_init(pcl,gcl_pcl_init,no_init); check_init(pcl,gcl_pcl_std_class,no_init); check_init(pcl,gcl_pcl_cpl,no_init); check_init(pcl,gcl_pcl_fsc,no_init); check_init(pcl,gcl_pcl_methods,no_init); check_init(pcl,gcl_pcl_fixup,no_init); check_init(pcl,gcl_pcl_defcombin,no_init); check_init(pcl,gcl_pcl_ctypes,no_init); check_init(pcl,gcl_pcl_env,no_init); check_init(pcl,gcl_pcl_compat,no_init); #ifndef pcl_gcl lsp_init("clcs","package.lisp"); check_init(clcs,gcl_clcs_precom,no_init); check_init(clcs,gcl_clcs_conditions,no_init); check_init(clcs,gcl_clcs_condition_definitions,no_init); #endif #endif #endif #endif } gcl-2.7.1/unixport/PaxHeaders/sys.c0000644000000000000000000000013214776006046014230 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.314035136 30 ctime=1744351535.598908178 gcl-2.7.1/unixport/sys.c0000644000175000017500000000344014776006046013627 0ustar00cammcamm#include #include #include #include #include "../h/include.h" #if defined(pre_gcl) #define libname "libpre_gcl.a" #elif defined(gcl) #define libname "libgcl.a" #elif defined(mod_gcl) #define libname "libmod_gcl.a" #elif defined(pcl_gcl) #define libname "libpcl_gcl.a" #elif defined(ansi_gcl) #define libname "libansi_gcl.a" #else #define libname "" #error "No flavor defined" #endif #ifndef pre_gcl static void ar_init_fn(void (fn)(void),const char *s) { struct stat ss; if (stat(s,&ss)) { char *sysd=getenv("GCL_SYSDIR"); char *d=sysd ? sysd : kcl_self; int n=sysd ? strlen(sysd) : dir_name_length(d); assert(snprintf(FN1,sizeof(FN1),"ar x %-.*s%s %s",n,d,libname,s)>0); assert(!msystem(FN1)); } 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,const char *b) { char *d,*sysd=getenv("GCL_LSPSYSDIR"); int n; d=sysd ? sysd : kcl_self; n=sysd ? strlen(sysd) : dir_name_length(d); assert(snprintf(FN1,sizeof(FN1),"%-.*s../%s/%s%s",n,d,a,b,strchr(b,'.') ? "" : ".lsp")>0); printf("loading %s\n",FN1); fflush(stdout); load(FN1); } #ifdef pre_gcl #define init(a,b) lsp_init(a,b) #define check_init(a,b,c) lsp_init(#a,#b) #else #define init(a,b) ar_init(b) #define check_init(a,b,c) ar_check_init(b,c) #endif gcl-2.7.1/unixport/PaxHeaders/init_raw.lsp.in0000644000000000000000000000013214776006046016207 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.314035136 30 ctime=1744351535.438909613 gcl-2.7.1/unixport/init_raw.lsp.in0000644000175000017500000001070514776006046015610 0ustar00cammcamm;FIXME (defun make-package (name &key nicknames use) (si::make-package-int name nicknames use)) (make-package :cstruct :use '(:cl)) (make-package :compiler :use '(:cl :si :cstruct)) (make-package :sloop :use '(:cl)) (make-package :ansi-loop :use'(:cl)) (make-package :defpackage :use '(:cl)) (make-package :tk :use '(:cl :sloop)) (make-package :fpe :use '(:cl)) (make-package :cltl1-compat) (make-package "libm") (in-package :system) (use-package '(:fpe :cstruct :gmp)) (export 'si::(object double cnum system cmp-inline cmp-eval type-propagator c1no-side-effects defcfun clines defentry) :si);FIXME (setq *features* (cons :raw-image *features*)) (init-system) (setq *features* (remove :raw-image *features*)) (in-package :si) (gbc t) ;FIXME (progn (do-all-symbols (s) (when (or (coerce-to-standard-class s) (get s 's-data)) (remprop s 'deftype-definition) (remprop s 'deftype-form))) (let* ((p (find-package "PCL"))(x (when p (find-symbol "DO-SATISFIES-DEFTYPE" p)))) (when (and x (fboundp x)) (setf (symbol-function x) (lambda (x y) (declare (ignore x y)) nil))))) (do-symbols (s) (when (get s 'proclaimed-function) (unless (sig s) (let* ((fun (symbol-function s))) (c-set-function-plist fun (apply 'make-function-plist (list (mapcar 'cmp-norm-tp (get s 'proclaimed-arg-types)) (cmp-norm-tp (get s 'proclaimed-return-type))) (or (cdr (c-function-plist fun)) (list nil nil nil 1 s))))));FIXME props (dolist (l '(proclaimed-function proclaimed-arg-types proclaimed-return-type)) (remprop s l)))) (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 (getenv "GCL_LSPSYSDIR")) (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)) (let* ((x (merge-pathnames (make-pathname :name "gcl_cmpnopt" :type "lsp") *system-directory*))) (when (probe-file x) (load x))) (load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp)) (gbc t)) (terpri) (setq *inhibit-macro-special* t) (gbc t) (reset-gbc-count) (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)) (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" #+gprof "_gprof" " " *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) :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)))) (progn (setq si::*code-block-reserve* (make-array 30000000 :element-type 'character :static t :initial-element (code-char 0))) nil) (setq *optimize-maximum-pages* t) gcl-2.7.1/unixport/PaxHeaders/cinit.lisp0000644000000000000000000000013214776006046015245 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.262034885 30 ctime=1744351535.598908178 gcl-2.7.1/unixport/cinit.lisp0000644000175000017500000000522014776006046014642 0ustar00cammcamm(in-package :compiler) (cdebug) (setq *compile-print* nil si::*notify-gbc* t *annotate* nil *optimize-maximum-pages* nil) (multiple-value-bind (x ps) (si::heap-report) (si::allocate 'structure (max 1 (truncate (* 4096 200) ps)) t)) (room t) #+pre-gcl (progn (declaim (optimize (safety 3))) (unless (fboundp 'logandc2) (defun logandc2 (x y) (boole boole-andc2 x y))) (unless (fboundp 'lognot) (defun lognot (x) (boole boole-c1 x 0))) (unless (fboundp 'abs) (defun abs (x) (if (< x 0) (- x) x)))) (mapc 'compile (nconc #+pre-gcl '(listp si::real-simple-typep-fn si::array-simple-typep-fn) #+pre-gcl (progn 'si::(s-data-raw s-data-slot-position s-data-slot-descriptions)) #-pre-gcl '(sbit si::aset si::improper-consp mapcar mapcan mapc mapl) ;maplist member member-if member-if-not ;assoc assoc-if assoc-if-not ;rassoc rassoc-if rassoc-if-not '(info-p info-ref info-type info-flags info-ch info-ref-ccb info-ref-clb) '(var-p var-name var-flags var-kind var-ref var-ref-ccb var-loc var-dt var-type var-mt var-tag var-store) #-pre-gcl '(bit-andc2 bit-and bit-ior bit-xor bit-orc2 bit-not) #-pre-gcl (progn 'si::(copy-btp btp-equal one-bit-btp btp-count new-tp4 btp-type2 btp-bnds< btp-bnds> tp-and tp-or cmp-tp-not tp-not tp= tp-p)) #-pre-gcl '(naltp explode-nalt needs-explode ctp-and ctp<= type-and type-or1 type<= type>= type=) '(c-array-rank c-array-dim c-array-elttype c-array-self c-array-hasfillp c-array-eltsize) '(c-structure-def c-structure-self c-strstd-sself) '(array-dimension array-row-major-index row-major-aref si::row-major-aset si::row-major-aref-int aref array-rank array-total-size array-has-fill-pointer-p length) '(typep infer-tp check-type))) (in-package :compiler) #-pre-gcl (progn ;FIXME safety 2 (dolist (l '(sbit svref schar char));ensure in *inl-hash* (compile nil `(lambda (x y) (declare (optimize (safety 1))) (,l x y))) (compile nil `(lambda (x y z) (declare (optimize (safety 1))) (setf (,l x y) z)))) (dolist (l si::+array-types+) (compile nil `(lambda (x y) (declare (optimize (safety 1))((vector ,l) x)) (aref x y))) (compile nil `(lambda (x y z) (declare (optimize (safety 1))((vector ,l) x)(,l z)) (setf (aref x y) z))) (compile nil `(lambda (x y z) (declare (optimize (safety 1))((vector ,l) x)) (setf (aref x y) z)))) (compile nil `(lambda (x) (declare (optimize (safety 1))((or simple-vector simple-string simple-bit-vector) x)) (length x))) (compile nil `(lambda (x) (declare (optimize (safety 2))) (address x))) (compile nil `(lambda (x) (declare (optimize (safety 2))) (nani x)))) (setq *optimize-maximum-pages* t) gcl-2.7.1/PaxHeaders/pcl0000644000000000000000000000013214776006046012057 xustar0030 mtime=1744309286.190034537 30 atime=1744351538.814879383 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/0000755000175000017500000000000014776006046011532 5ustar00cammcammgcl-2.7.1/pcl/PaxHeaders/gcl_pcl_std_class.lisp0000644000000000000000000000013114733440601016456 xustar0030 mtime=1735278977.090650063 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_std_class.lisp0000644000175000017500000014242714733440601016067 0ustar00cammcamm;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 doc-type) (real-documentation object doc-type)) (defmethod (setf documentation) (new-value object doc-type) (si::set-documentation object doc-type new-value)) (defmethod documentation ((object documentation-mixin) doc-type) (declare (ignore doc-type)) (plist-value object 'documentation)) (defmethod (setf documentation) (new-value (object documentation-mixin) doc-type) (declare (ignore doc-type)) (setf (plist-value object 'documentation) new-value)) (defmethod documentation ((slotd standard-slot-definition) doc-type) (declare (ignore doc-type)) (slot-value slotd 'documentation)) (defmethod (setf documentation) (new-value (slotd standard-slot-definition) 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 (let ((class (find-class name nil))) (when (and class (eq name (class-name class))) ;; NAME is the proper name of CLASS, so redefine it class)) 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);*** (let ((class (apply #'make-instance meta :name name initargs))) (setf (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) (apply #'change-class class meta initargs)) (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))))))) ;; ;; CLHS: signal PROGRAM-ERROR, if ;; (a) there are any duplicate slot names ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or ;; :DOCUMENTATION appears more than one in a single slot description. (loop for (slot . more) on (getf initargs :direct-slots) for slot-name = (getf slot :name) if (some (lambda (s) (eq slot-name (getf s :name))) more) do (error 'program-error :format-control "More than one direct slot with name ~S." :format-arguments (list slot-name)) else do (loop for (option value . more) on slot by #'cddr when (and (member option '(:allocation :type :initform :documentation)) (progn value t) (not (eq unsupplied (getf more option unsupplied)))) do (error 'program-error :format-control "Duplicate slot option ~S for slot ~S." :format-arguments (list option slot-name)))) ;; ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name ;; appears more than once in :DEFAULT-INITARGS class option. (loop for (initarg . more) on (getf initargs :direct-default-initargs) for name = (car initarg) when (some (lambda (a) (eq (car a) name)) more) do (error 'program-error :format-control "Duplicate initialization argument ~ name ~S in :default-initargs of class ~A." :format-arguments (list name class))) ;; (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) (if (class-finalized-p class) ;; required by AMOP, "Reinitialization of Class Metaobjects" (finalize-inheritance class) (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 initargs) (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." ;; (loop for new-slot in new-layout and new-position from 0 for old-position = (posq new-slot old-layout) when old-position do (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." ;; (loop for (name . val) in old-class-slots for new-position = (posq name new-layout) when new-position do (setf (instance-ref new-slots new-position) 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) (apply #'update-instance-for-different-class copy instance initargs) instance)) (defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs) (change-class-internal instance new-class initargs)) ;; FIXME add class funcallable-standard-object ?? ;(defmethod change-class ((instance funcallable-standard-object) ; (new-class funcallable-standard-class) ; &rest initargs) ; (change-class-internal instance new-class initargs)) (defmethod change-class ((instance standard-object) (new-class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) (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)) ;(defmethod change-class ((instance funcallable-standard-object) ; (new-class standard-class) ; &rest initargs) ; (declare (ignore initargs)) ; (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)) (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) (apply #'change-class instance (find-class new-class-name) initargs)) ;;; ;;; 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.7.1/pcl/PaxHeaders/gcl_pcl_low.lisp0000644000000000000000000000013114555557372015320 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_low.lisp0000644000175000017500000004167014555557372014727 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 portable versions of low-level functions and macros ;;; which are ripe for implementation specific customization. None of the ;;; code in this file *has* to be customized for a particular Common Lisp ;;; implementation. Moreover, in some implementations it may not make any ;;; sense to customize some of this code. ;;; ;;; But, experience suggests that MOST Common Lisp implementors will want ;;; to customize some of the code in this file to make PCL run better in ;;; their implementation. The code in this file has been separated and ;;; heavily commented to make that easier. ;;; ;;; Implementation-specific version of this file already exist for: ;;; ;;; Symbolics Genera family genera-low.lisp ;;; Lucid Lisp lucid-low.lisp ;;; Xerox 1100 family xerox-low.lisp ;;; ExCL (Franz) excl-low.lisp ;;; Kyoto Common Lisp kcl-low.lisp ;;; Vaxlisp vaxl-low.lisp ;;; CMU Lisp cmu-low.lisp ;;; H.P. Common Lisp hp-low.lisp ;;; Golden Common Lisp gold-low.lisp ;;; Ti Explorer ti-low.lisp ;;; ;;; ;;; These implementation-specific files are loaded after this file. Because ;;; none of the macros defined by this file are used in functions defined by ;;; this file the implementation-specific files can just contain the parts of ;;; this file they want to change. They don't have to copy this whole file ;;; and then change the parts they want. ;;; ;;; If you make changes or improvements to these files, or if you need some ;;; low-level part of PCL re-modularized to make it more portable to your ;;; system please send mail to CommonLoops.pa@Xerox.com. ;;; ;;; Thanks. ;;; (in-package :pcl) (eval-when (compile load eval) (defvar *optimize-speed* '(optimize (speed 3) (safety 1))) ) (defmacro %svref (vector index) `(locally (declare #.*optimize-speed* (inline svref)) (svref (the simple-vector ,vector) (the fixnum ,index)))) (defsetf %svref %set-svref) (defmacro %set-svref (vector index new-value) `(locally (declare #.*optimize-speed* (inline svref)) (setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value))) ;;; ;;; without-interrupts ;;; ;;; OK, Common Lisp doesn't have this and for good reason. But For all of ;;; the Common Lisp's that PCL runs on today, there is a meaningful way to ;;; implement this. WHAT I MEAN IS: ;;; ;;; I want the body to be evaluated in such a way that no other code that is ;;; running PCL can be run during that evaluation. I agree that the body ;;; won't take *long* to evaluate. That is to say that I will only use ;;; without interrupts around relatively small computations. ;;; ;;; INTERRUPTS-ON should turn interrupts back on if they were on. ;;; INTERRUPTS-OFF should turn interrupts back off. ;;; These are only valid inside the body of WITHOUT-INTERRUPTS. ;;; ;;; OK? ;;; (defmacro without-interrupts (&body body) `(macrolet ((interrupts-on () ()) (interrupts-off () ())) (progn ,.body))) ;;; ;;; Very Low-Level representation of instances with meta-class standard-class. ;;; #-new-kcl-wrapper (progn ;(eval-when (compile load eval) ; (deftype std-instance nil `(or structure (and standard-object (not funcallable-standard-object))))) ;(si::putprop 'std-instance '(lambda nil `(or structure (and standard-object (not (funcallable-standard-object))))) 'si::deftype-definition) #-cmu17 (defstruct (std-instance (:predicate std-instance-p) (:conc-name %std-instance-) (:constructor nil);(:constructor %%allocate-instance--class ()) (:print-function print-std-instance)) (wrapper nil) (slots nil)) (defmacro %instance-ref (slots index) `(%svref ,slots ,index)) (defmacro instance-ref (slots index) `(svref ,slots ,index)) ;(defmacro std-instance-p (object) ; `(or (typep ,object 'si::instance) (structurep ,object))) ; `(or (typep ,object 'si::instance) (%std-instance-p ,object))) ) #+new-kcl-wrapper (progn (defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t :initial-element nil)) (defun get-init-list (i) (declare (fixnum i)(special *slot-unbound*)) (loop (when (< i (fill-pointer *init-vector*)) (return (aref *init-vector* i))) (vector-push-extend (cons *slot-unbound* (aref *init-vector* (1- (fill-pointer *init-vector*)))) *init-vector*))) (defmacro %std-instance-wrapper (instance) `(structure-def ,instance)) (defmacro %std-instance-slots (instance) instance) (defmacro std-instance-p (x) `(structurep ,x)) ) (defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x)) (defmacro std-instance-slots (x) `(%std-instance-slots ,x)) (defmacro get-wrapper (inst) `(etypecase ,inst (std-instance (std-instance-wrapper ,inst)) (funcallable-std-instance (fsc-instance-wrapper ,inst)))) (defmacro get-instance-wrapper-or-nil (inst) `(typecase ,inst (std-instance (std-instance-wrapper ,inst)) (funcallable-std-instance (fsc-instance-wrapper ,inst)))) (defmacro get-slots (inst) `(etypecase ,inst (std-instance (std-instance-slots ,inst)) (funcallable-std-instance (fsc-instance-slots ,inst)))) (defmacro get-slots-or-nil (inst) `(typecase ,inst (std-instance (std-instance-slots ,inst)) (funcallable-std-instance (fsc-instance-slots ,inst)))) ;; (defmacro get-wrapper (inst) ;; `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) ;; ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)) ;; (t (error "What kind of instance is this?")))) ;; (defmacro get-instance-wrapper-or-nil (inst) ;; `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) ;; ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)))) ;; (defmacro get-slots (inst) ;; `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) ;; ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) ;; (t (error "What kind of instance is this?")))) ;; (defmacro get-slots-or-nil (inst) ;; `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) ;; ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)))) (defun print-std-instance (instance stream depth) ;A temporary definition used (declare (ignore depth)) ;for debugging the bootstrap (printing-random-thing (instance stream) ;code of PCL (See high.lisp). (let ((class (class-of instance))) (if (or (eq class (find-class 'standard-class nil)) (eq class (find-class 'funcallable-standard-class nil)) (eq class (find-class 'built-in-class nil))) (format stream "~a ~a" (early-class-name class) (early-class-name instance)) (format stream "~a" (early-class-name class)))))) ;;; ;;; This is the value that we stick into a slot to tell us that it is unbound. ;;; It may seem gross, but for performance reasons, we make this an interned ;;; symbol. That means that the fast check to see if a slot is unbound is to ;;; say (EQ '..SLOT-UNBOUND..). That is considerably faster than looking ;;; at the value of a special variable. Be careful, there are places in the ;;; code which actually use ..slot-unbound.. rather than this variable. So ;;; much for modularity ;;; (defvar *slot-unbound* '..slot-unbound..) (defmacro %allocate-static-slot-storage--class (no-of-slots) #+new-kcl-wrapper (declare (ignore no-of-slots)) #-new-kcl-wrapper `(make-array ,no-of-slots :initial-element *slot-unbound*) #+new-kcl-wrapper (error "don't call this")) (defmacro std-instance-class (instance) `(wrapper-class* (std-instance-wrapper ,instance))) ;; ;;;;;; FUNCTION-ARGLIST ;; ;;; Given something which is functionp, function-arglist should return the ;;; argument list for it. PCL does not count on having this available, but ;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of ;;; function-arglist for each specific port of pcl should be put in the ;;; appropriate xxx-low file. This is what it should look like: ;(defun function-arglist (function) ; ( function)) (defun function-pretty-arglist (function) (declare (ignore function)) ()) (defsetf function-pretty-arglist set-function-pretty-arglist) (defun set-function-pretty-arglist (function new-value) (declare (ignore function)) new-value) ;;; ;;; set-function-name ;;; When given a function should give this function the name . ;;; Note that is sometimes a list. Some lisps get the upset ;;; in the tummy when they start thinking about functions which have ;;; lists as names. To deal with that there is set-function-name-intern ;;; which takes a list spec for a function name and turns it into a symbol ;;; if need be. ;;; ;;; When given a funcallable instance, set-function-name MUST side-effect ;;; that FIN to give it the name. When given any other kind of function ;;; set-function-name is allowed to return new function which is the 'same' ;;; except that it has the name. ;;; ;;; In all cases, set-function-name must return the new (or same) function. ;;; (defun set-function-name (function new-name) (declare (notinline set-function-name-1 intern-function-name)) (set-function-name-1 function (intern-function-name new-name) new-name)) (defun set-function-name-1 (function new-name uninterned-name) (declare (ignore new-name uninterned-name)) function) (defun intern-function-name (name) (cond ((symbolp name) name) ((listp name) (intern (let ((*package* *the-pcl-package*) (*print-case* :upcase) (*print-pretty* nil) (*print-gensym* 't)) (format nil "~S" name)) *the-pcl-package*)))) ;;; ;;; COMPILE-LAMBDA ;;; ;;; This is like the Common Lisp function COMPILE. In fact, that is what ;;; it ends up calling. The difference is that it deals with things like ;;; watching out for recursive calls to the compiler or not calling the ;;; compiler in certain cases or allowing the compiler not to be present. ;;; ;;; This starts out with several variables and support functions which ;;; should be conditionalized for any new port of PCL. Note that these ;;; default to reasonable values, many new ports won't need to look at ;;; these values at all. ;;; ;;; *COMPILER-PRESENT-P* NIL means the compiler is not loaded ;;; ;;; *COMPILER-SPEED* one of :FAST :MEDIUM or :SLOW ;;; ;;; *COMPILER-REENTRANT-P* T ==> OK to call compiler recursively ;;; NIL ==> not OK ;;; ;;; function IN-THE-COMPILER-P returns T if in the compiler, NIL otherwise ;;; This is not called if *compiler-reentrant-p* ;;; is T, so it only needs to be implemented for ;;; ports which have non-reentrant compilers. ;;; ;;; (defvar *compiler-present-p* t) (defvar *compiler-speed* #+(or KCL IBCL GCLisp CMU) :slow #-(or KCL IBCL GCLisp CMU) :fast) (defvar *compiler-reentrant-p* #+(and (not XKCL) (or KCL IBCL)) nil #-(and (not XKCL) (or KCL IBCL)) t) (defun in-the-compiler-p () #+(and (not xkcl) (or KCL IBCL))compiler::*compiler-in-use* #+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure) ) (defvar *compile-lambda-break-p* nil) (defun compile-lambda (lambda &optional (desirability :fast)) (when *compile-lambda-break-p* (break)) (cond ((null *compiler-present-p*) (compile-lambda-uncompiled lambda)) ((and (null *compiler-reentrant-p*) (in-the-compiler-p)) (compile-lambda-deferred lambda)) ((eq desirability :fast) (compile nil lambda)) ((and (eq desirability :medium) (member *compiler-speed* '(:fast :medium))) (compile nil lambda)) ((and (eq desirability :slow) (eq *compiler-speed* ':fast)) (compile nil lambda)) (t (compile-lambda-uncompiled lambda)))) (defun compile-lambda-uncompiled (uncompiled) #'(lambda (&rest args) (apply (coerce uncompiled 'function) args))) (defun compile-lambda-deferred (uncompiled) (let ((function (coerce uncompiled 'function)) (compiled nil)) (declare (type (or function null) compiled)) #'(lambda (&rest args) (if compiled (apply compiled args) (if (in-the-compiler-p) (apply function args) (progn (setq compiled (compile nil uncompiled)) (apply compiled args))))))) (defmacro precompile-random-code-segments (&optional system) `(progn (eval-when (compile) (update-dispatch-dfuns) (compile-iis-functions nil)) (precompile-function-generators ,system) (precompile-dfun-constructors ,system) (precompile-iis-functions ,system) (eval-when (load) (compile-iis-functions t)))) (defun record-definition (type spec &rest args) (declare (ignore type spec args)) ()) (defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) ;; From braid.lisp #-new-kcl-wrapper (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) `(typecase ,x (std-instance (std-instance-wrapper ,x)) (funcallable-std-instance (fsc-instance-wrapper ,x)) (structure (wrapper-for-structure ,x)) (symbol (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) (otherwise (built-in-wrapper-of ,x)))) ;; (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)) ;Low level functions for structures ;Functions on arbitrary objects ;(defvar *structure-table* (make-hash-table :test 'eq)) (defun declare-structure (name included-name slot-description-list) (setf (gethash name *structure-table*) (cons included-name slot-description-list))) #-gcl(unless (fboundp 'structure-functions-exist-p) (setf (symbol-function 'structure-functions-exist-p) #'(lambda () nil))) (defun default-structurep (x) (structure-type-p (type-of x))) (defun default-structure-instance-p (x) (let ((type (type-of x))) (and (not (eq type 'std-instance)) (structure-type-p type)))) (defun default-structure-type (x) (type-of x)) (unless (fboundp 'structurep) (setf (symbol-function 'structurep) #'default-structurep)) ; excludes std-instance (unless (fboundp 'structure-instance-p) (setf (symbol-function 'structure-instance-p) #'default-structure-instance-p)) ; returns a symbol (unless (fboundp 'structure-type) (setf (symbol-function 'structure-type) #'default-structure-type)) ;Functions on symbols naming structures ; Excludes structures types created with the :type option #-gcl(defun structure-type-p (symbol) (not (null (gethash symbol *structure-table*)))) (defun structure-type-included-type-name (symbol) (car (gethash symbol *structure-table*))) ; direct slots only ; The results of this function are used only by the functions below. (defun structure-type-slot-description-list (symbol) (cdr (gethash symbol *structure-table*))) ;Functions on slot-descriptions (returned by the function above) ;returns a symbol (defun structure-slotd-name (structure-slot-description) (first structure-slot-description)) ;returns a symbol (defun structure-slotd-accessor-symbol (structure-slot-description) (second structure-slot-description)) ;returns a symbol or a list or nil (defun structure-slotd-writer-function (structure-slot-description) (third structure-slot-description)) (defun structure-slotd-type (structure-slot-description) (fourth structure-slot-description)) (defun structure-slotd-init-form (structure-slot-description) (fifth structure-slot-description)) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_cache.lisp0000644000000000000000000000013114730567120015545 xustar0030 mtime=1734536784.932569545 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_cache.lisp0000644000175000017500000016434314730567120015157 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 basics of the PCL wrapper cache mechanism. ;;; (in-package :pcl) ;;; ;;; The caching algorithm implemented: ;;; ;;; << put a paper here >> ;;; ;;; For now, understand that as far as most of this code goes, a cache has ;;; two important properties. The first is the number of wrappers used as ;;; keys in each cache line. Throughout this code, this value is always ;;; called NKEYS. The second is whether or not the cache lines of a cache ;;; store a value. Throughout this code, this always called VALUEP. ;;; ;;; Depending on these values, there are three kinds of caches. ;;; ;;; NKEYS = 1, VALUEP = NIL ;;; ;;; In this kind of cache, each line is 1 word long. No cache locking is ;;; needed since all read's in the cache are a single value. Nevertheless ;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will ;;; not get a first probe hit. ;;; ;;; To keep the code simpler, a cache lock count does appear in location 0 ;;; of these caches, that count is incremented whenever data is written to ;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to ;;; do locking when reading the cache. ;;; ;;; ;;; NKEYS = 1, VALUEP = T ;;; ;;; In this kind of cache, each line is 2 words long. Cache locking must ;;; be done to ensure the synchronization of cache reads. Line 0 of the ;;; cache (location 0) is reserved for the cache lock count. Location 1 ;;; of the cache is unused (in effect wasted). ;;; ;;; NKEYS > 1 ;;; ;;; In this kind of cache, the 0 word of the cache holds the lock count. ;;; The 1 word of the cache is line 0. Line 0 of these caches is not ;;; reserved. ;;; ;;; This is done because in this sort of cache, the overhead of doing the ;;; cache probe is high enough that the 1+ required to offset the location ;;; is not a significant cost. In addition, because of the larger line ;;; sizes, the space that would be wasted by reserving line 0 to hold the ;;; lock count is more significant. ;;; ;;; ;;; Caches ;;; ;;; A cache is essentially just a vector. The use of the individual `words' ;;; in the vector depends on particular properties of the cache as described ;;; above. ;;; ;;; This defines an abstraction for caches in terms of their most obvious ;;; implementation as simple vectors. But, please notice that part of the ;;; implementation of this abstraction, is the function lap-out-cache-ref. ;;; This means that most port-specific modifications to the implementation ;;; of caches will require corresponding port-specific modifications to the ;;; lap code assembler. ;;; #+gcl(import 'si::non-negative-fixnum) (defmacro cache-vector-ref (cache-vector location) `(svref (the simple-vector ,cache-vector) (#-cmu the #+cmu ext:truly-the non-negative-fixnum ,location))) (defmacro cache-vector-size (cache-vector) `(array-dimension (the simple-vector ,cache-vector) 0)) (defun allocate-cache-vector (size) (make-array size :adjustable nil)) (defmacro cache-vector-lock-count (cache-vector) `(cache-vector-ref ,cache-vector 0)) (defun flush-cache-vector-internal (cache-vector) (without-interrupts (fill (the simple-vector cache-vector) nil) (setf (cache-vector-lock-count cache-vector) 0)) cache-vector) ;; FIXME 64 (defconstant rand-base (- (ash 1 31) 1)) (defmacro modify-cache (cache-vector &body body) `(without-interrupts (multiple-value-prog1 (progn ,@body) (let ((old-count (cache-vector-lock-count ,cache-vector))) (declare (type non-negative-fixnum old-count)) (setf (cache-vector-lock-count ,cache-vector) (if (= old-count rand-base) 1 (the non-negative-fixnum (1+ old-count)))))))) (deftype field-type () '(integer 0 ;#.(position 'number wrapper-layout) 7)) ;#.(position 'number wrapper-layout :from-end t) (eval-when (compile load eval) (defun power-of-two-ceiling (x) (declare (type (and fixnum (integer 1 *)) x)) ;;(expt 2 (ceiling (log x 2))) (the non-negative-fixnum (ash 1 (integer-length (1- x))))) (defconstant *nkeys-limit* 255) ) (defstruct (cache (:print-function print-cache) (:constructor make-cache ()) (:copier copy-cache-internal)) (owner nil) (nkeys 1 :type (integer 1 #.*nkeys-limit*)) (valuep nil :type boolean) (nlines 0 :type non-negative-fixnum) (field 0 :type field-type) (limit-fn #'default-limit-fn :type function) (mask 0 :type non-negative-fixnum) (size 0 :type non-negative-fixnum) (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*)))) (max-location 0 :type non-negative-fixnum) (vector #() :type simple-vector) (overflow nil :type list)) #+cmu (declaim (ext:freeze-type cache)) (defun print-cache (cache stream depth) (declare (ignore depth)) (printing-random-thing (cache stream) (format stream "cache ~D ~S ~D" (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache)))) #+akcl (si::freeze-defstruct 'cache) (defmacro cache-lock-count (cache) `(cache-vector-lock-count (cache-vector ,cache))) ;;; ;;; Some facilities for allocation and freeing caches as they are needed. ;;; This is done on the assumption that a better port of PCL will arrange ;;; to cons these all the same static area. Given that, the fact that ;;; PCL tries to reuse them should be a win. ;;; (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql)) ;;; ;;; Return a cache that has had flush-cache-vector-internal called on it. This ;;; returns a cache of exactly the size requested, it won't ever return a ;;; larger cache. ;;; (defun get-cache-vector (size) (let ((entry (gethash size *free-cache-vectors*))) (without-interrupts (cond ((null entry) (setf (gethash size *free-cache-vectors*) (cons 0 nil)) (get-cache-vector size)) ((null (cdr entry)) (incf (car entry)) (flush-cache-vector-internal (allocate-cache-vector size))) (t (let ((cache (cdr entry))) (setf (cdr entry) (cache-vector-ref cache 0)) (flush-cache-vector-internal cache))))))) (defun free-cache-vector (cache-vector) (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) (without-interrupts (if (null entry) (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.") (let ((thread (cdr entry))) (loop (unless thread (return)) (when (eq thread cache-vector) (error "Freeing a cache twice.")) (setq thread (cache-vector-ref thread 0))) (flush-cache-vector-internal cache-vector) ;Help the GC (setf (cache-vector-ref cache-vector 0) (cdr entry)) (setf (cdr entry) cache-vector) nil))))) ;;; ;;; This is just for debugging and analysis. It shows the state of the free ;;; cache resource. ;;; (defun show-free-cache-vectors () (let ((elements ())) (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) (setq elements (sort elements #'< :key #'car)) (dolist (e elements) (let* ((size (car e)) (entry (cadr e)) (allocated (car entry)) (head (cdr entry)) (free 0)) (loop (when (null head) (return t)) (setq head (cache-vector-ref head 0)) (incf free)) (format t "~&There ~4D are caches of size ~4D. (~D free ~3D%)" allocated size free (floor (* 100 (/ free (float allocated))))))))) ;;; ;;; Wrapper cache numbers ;;; ;;; ;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero ;;; bits wrapper cache numbers will have. ;;; ;;; The value of this constant is the number of wrapper cache numbers which ;;; can be added and still be certain the result will be a fixnum. This is ;;; used by all the code that computes primary cache locations from multiple ;;; wrappers. ;;; ;;; The value of this constant is used to derive the next two which are the ;;; forms of this constant which it is more convenient for the runtime code ;;; to use. ;;; #-cmu17 (eval-when (compile load eval) (defconstant wrapper-cache-number-adds-ok 4) ;;; Incorrect. This actually allows 15 or 16 adds, depending on whether ;;; most-positive-fixnum is all-ones. -- Ram ;;; (defconstant wrapper-cache-number-length (- (integer-length rand-base) 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 (type non-negative-fixnum n)) (loop (setq n (logand wrapper-cache-number-mask (random rand-base *get-wrapper-cache-number*))) (unless (zerop n) (return n))))) (unless (> wrapper-cache-number-length 8) (error "In this implementation of Common Lisp, fixnums are so small that~@ wrapper cache numbers end up being only ~D bits long. This does~@ not actually keep PCL from running, but it may degrade cache~@ performance.~@ You may want to consider changing the value of the constant~@ WRAPPER-CACHE-NUMBER-ADDS-OK."))) #+cmu17 (progn (defconstant wrapper-cache-number-length (integer-length kernel:layout-hash-max)) (defconstant wrapper-cache-number-mask kernel:layout-hash-max) (defconstant wrapper-cache-number-adds-ok (truncate most-positive-fixnum kernel:layout-hash-max))) ;;; ;;; wrappers themselves ;;; ;;; This caching algorithm requires that wrappers have more than one wrapper ;;; cache number. You should think of these multiple numbers as being in ;;; columns. That is, for a given cache, the same column of wrapper cache ;;; numbers will be used. ;;; ;;; If at some point the cache distribution of a cache gets bad, the cache ;;; can be rehashed by switching to a different column. ;;; ;;; The columns are referred to by field number which is that number which, ;;; when used as a second argument to wrapper-ref, will return that column ;;; of wrapper cache number. ;;; ;;; This code is written to allow flexibility as to how many wrapper cache ;;; numbers will be in each wrapper, and where they will be located. It is ;;; also set up to allow port specific modifications to `pack' the wrapper ;;; cache numbers on machines where the addressing modes make that a good ;;; idea. ;;; #-structure-wrapper (progn (eval-when (compile load eval) (defconstant wrapper-layout '(number number number number number number number number state instance-slots-layout class-slots class no-of-instance-slots)) ) (eval-when (compile load eval) (defun wrapper-field (type) (posq type wrapper-layout)) (defun next-wrapper-field (field-number) (position (nth field-number wrapper-layout) wrapper-layout :start (1+ field-number))) (defmacro first-wrapper-cache-number-index () `(wrapper-field 'number)) (defmacro next-wrapper-cache-number-index (field-number) `(next-wrapper-field ,field-number)) );eval-when (defmacro wrapper-cache-number-vector (wrapper) wrapper) (defmacro cache-number-vector-ref (cnv n) `(svref ,cnv ,n)) (defmacro wrapper-ref (wrapper n) `(svref ,wrapper ,n)) (defmacro wrapper-state (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'state))) (defmacro wrapper-instance-slots-layout (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) (defmacro wrapper-class-slots (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) (defmacro wrapper-class (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'class))) (defmacro wrapper-no-of-instance-slots (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots))) (defmacro make-wrapper-internal () `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) ,@(gathering1 (collecting) (iterate ((i (interval :from 0)) (desc (list-elements wrapper-layout))) (ecase desc (number (gather1 `(setf (wrapper-ref wrapper ,i) (get-wrapper-cache-number)))) ((state instance-slots-layout class-slots class no-of-instance-slots))))) (setf (wrapper-state wrapper) 't) wrapper)) (defun make-wrapper (no-of-instance-slots &optional class) (let ((wrapper (make-wrapper-internal))) (setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots) (setf (wrapper-class wrapper) class) wrapper)) ) ; In CMUCL we want to do type checking as early as possible; structures help this. #+structure-wrapper (eval-when (compile load eval) (defconstant wrapper-cache-number-vector-length #+cmu17 kernel:layout-hash-length #-cmu17 8) #-cmu17 (deftype cache-number-vector () `(simple-array fixnum (,wrapper-cache-number-vector-length))) (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length :initial-element 'number)) ) #+structure-wrapper (progn #-(or new-kcl-wrapper cmu17) (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)) #-cmu17 (defstruct (wrapper #+new-kcl-wrapper (:include si::basic-wrapper) (:print-function print-wrapper) #-new-kcl-wrapper (:constructor make-wrapper (no-of-instance-slots &optional class)) #+new-kcl-wrapper (:constructor make-wrapper-internal)) #-new-kcl-wrapper (cache-number-vector (make-wrapper-cache-number-vector) :type cache-number-vector) #-new-kcl-wrapper (state t :type (or (member t) cons)) ;; either t or a list (state-sym new-wrapper) ;; where state-sym is either :flush or :obsolete (instance-slots-layout nil :type list) (class-slots nil :type list) #-new-kcl-wrapper (no-of-instance-slots 0 :type fixnum) #-new-kcl-wrapper (class *the-class-t* :type class)) (unless (boundp '*the-class-t*) (setq *the-class-t* nil)) #+new-kcl-wrapper (defmacro wrapper-no-of-instance-slots (wrapper) `(si::s-data-length ,wrapper)) ;;; Note that for CMU, the WRAPPER of a built-in or structure class will be ;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only ;;; two slots that WRAPPER adds are meaningless in those cases. ;;; #+cmu17 (progn (defstruct (wrapper (:include kernel:layout) (:conc-name %wrapper-) (:print-function print-wrapper) (:constructor make-wrapper-internal)) (instance-slots-layout nil :type list) (class-slots nil :type list)) (declaim (ext:freeze-type wrapper)) (defmacro wrapper-class (wrapper) `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) (defmacro wrapper-no-of-instance-slots (wrapper) `(kernel:layout-length ,wrapper)) (declaim (inline wrapper-state (setf wrapper-state))) (defun wrapper-state (wrapper) (let ((invalid (kernel:layout-invalid wrapper))) (cond ((null invalid) t) ((atom invalid) ;; Some non-pcl object. invalid is probably :INVALID ;; We should compute the new wrapper here instead ;; of returning nil, but why bother, since ;; obsolete-instance-trap can't use it. '(:obsolete nil)) (t invalid)))) (defun (setf wrapper-state) (new-value wrapper) (setf (kernel:layout-invalid wrapper) (if (eq new-value 't) nil new-value))) (defmacro wrapper-instance-slots-layout (wrapper) `(%wrapper-instance-slots-layout ,wrapper)) (defmacro wrapper-class-slots (wrapper) `(%wrapper-class-slots ,wrapper)) (defmacro wrapper-cache-number-vector (x) x)) #+new-kcl-wrapper (defun make-wrapper (size &optional class) (multiple-value-bind (raw slot-positions) (if (< size 50) (values si::*all-t-s-type* si::*standard-slot-positions*) (values (make-array size :element-type 'unsigned-char) (let ((array (make-array size :element-type 'unsigned-short))) (dotimes (i size) (declare (fixnum i)) (setf (aref array i) (* #.(si::size-of t) i)))))) (make-wrapper-internal :length size :raw raw :print-function 'print-std-instance :slot-position slot-positions :size (* size #.(si::size-of t)) :class class))) #+cmu17 ;;; BOOT-MAKE-WRAPPER -- Interface ;;; ;;; Called in BRAID when we are making wrappers for classes whose slots are ;;; not initialized yet, and which may be built-in classes. We pass in the ;;; class name in addition to the class. ;;; (defun boot-make-wrapper (length name &optional class) (let ((found (lisp:find-class name nil))) (cond (found (unless (kernel:class-pcl-class found) (setf (kernel:class-pcl-class found) class)) (assert (eq (kernel:class-pcl-class found) class)) (let ((layout (kernel:class-layout found))) (assert layout) layout)) (t (kernel:initialize-layout-hash (make-wrapper-internal :length length :class (kernel:make-standard-class :name name :pcl-class class))))))) #+cmu17 ;;; MAKE-WRAPPER -- Interface ;;; ;;; In CMU CL, the layouts (a.k.a wrappers) for built-in and structure ;;; classes already exist when PCL is initialized, so we don't necessarily ;;; always make a wrapper. Also, we help maintain the mapping between ;;; lisp:class and pcl::class objects. ;;; (defun make-wrapper (length class) (cond ((typep class 'std-class) (kernel:initialize-layout-hash (make-wrapper-internal :length length :class (let ((owrap (class-wrapper class))) (cond (owrap (kernel:layout-class owrap)) ((*subtypep (class-of class) *the-class-standard-class*) (kernel:make-standard-class :pcl-class class)) (t (kernel:make-random-pcl-class :pcl-class class))))))) (t (let* ((found (lisp:find-class (slot-value class 'name))) (layout (kernel:class-layout found))) (unless (kernel:class-pcl-class found) (setf (kernel:class-pcl-class found) class)) (assert (eq (kernel:class-pcl-class found) class)) (assert layout) layout)))) (defun print-wrapper (wrapper stream depth) (declare (ignore depth)) (printing-random-thing (wrapper stream) (format stream "Wrapper ~S" (wrapper-class wrapper)))) (defmacro first-wrapper-cache-number-index () 0) (defmacro next-wrapper-cache-number-index (field-number) `(and (< (the field-type ,field-number) #.(1- wrapper-cache-number-vector-length)) (the field-type (1+ (the field-type ,field-number))))) #-cmu17 (defmacro cache-number-vector-ref (cnv n) `(#-kcl svref #+kcl aref ,cnv ,n)) #+cmu17 (defmacro cache-number-vector-ref (cnv n) `(wrapper-cache-number-vector-ref ,cnv ,n)) ) #-cmu17 (defmacro wrapper-cache-number-vector-ref (wrapper n) `(the fixnum (#-structure-wrapper svref #+structure-wrapper aref (wrapper-cache-number-vector ,wrapper) ,n))) #+cmu17 (defmacro wrapper-cache-number-vector-ref (wrapper n) `(kernel:layout-hash ,wrapper ,n)) (defmacro class-no-of-instance-slots (class) `(wrapper-no-of-instance-slots (class-wrapper ,class))) (defmacro wrapper-class* (wrapper) #-(or new-kcl-wrapper cmu17) `(wrapper-class ,wrapper) #+(or new-kcl-wrapper cmu17) `(let ((wrapper ,wrapper)) (or (wrapper-class wrapper) (find-structure-class #+new-kcl-wrapper (si::s-data-name wrapper) #+cmu17 (lisp:class-name (kernel:layout-class wrapper)))))) ;;; ;;; The wrapper cache machinery provides general mechanism for trapping on ;;; the next access to any instance of a given class. This mechanism is ;;; used to implement the updating of instances when the class is redefined ;;; (make-instances-obsolete). The same mechanism is also used to update ;;; generic function caches when there is a change to the supers of a class. ;;; ;;; Basically, a given wrapper can be valid or invalid. If it is invalid, ;;; it means that any attempt to do a wrapper cache lookup using the wrapper ;;; should trap. Also, methods on slot-value-using-class check the wrapper ;;; validity as well. This is done by calling check-wrapper-validity. ;;; (defmacro invalid-wrapper-p (wrapper) `(neq (wrapper-state ,wrapper) 't)) (defvar *previous-nwrappers* (make-hash-table)) (defun invalidate-wrapper (owrapper state nwrapper) (ecase state ((:flush :obsolete) (let ((new-previous ())) ;; ;; First off, a previous call to invalidate-wrapper may have recorded ;; owrapper as an nwrapper to update to. Since owrapper is about to ;; be invalid, it no longer makes sense to update to it. ;; ;; We go back and change the previously invalidated wrappers so that ;; they will now update directly to nwrapper. This corresponds to a ;; kind of transitivity of wrapper updates. ;; (dolist (previous (gethash owrapper *previous-nwrappers*)) (when (eq state ':obsolete) (setf (car previous) ':obsolete)) (setf (cadr previous) nwrapper) (push previous new-previous)) (let ((ocnv (wrapper-cache-number-vector owrapper))) (iterate ((type (list-elements wrapper-layout)) (i (interval :from 0))) (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0)))) (push (setf (wrapper-state owrapper) (list state nwrapper)) new-previous) (setf (gethash owrapper *previous-nwrappers*) () (gethash nwrapper *previous-nwrappers*) new-previous))))) (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) (state (wrapper-state owrapper))) (if (eq state 't) owrapper (let ((nwrapper (ecase (car state) (:flush (flush-cache-trap owrapper (cadr state) instance)) (:obsolete (obsolete-instance-trap owrapper (cadr state) instance))))) ;; ;; This little bit of error checking is superfluous. It only ;; checks to see whether the person who implemented the trap ;; handling screwed up. Since that person is hacking internal ;; PCL code, and is not a user, this should be needless. Also, ;; since this directly slows down instance update and generic ;; function cache refilling, feel free to take it out sometime ;; soon. ;; (cond ((neq nwrapper (wrapper-of instance)) (error "Wrapper returned from trap not wrapper of instance.")) ((invalid-wrapper-p nwrapper) (error "Wrapper returned from trap invalid."))) nwrapper)))) #-cmu17 (defmacro check-wrapper-validity1 (object) (let ((owrapper (gensym))) `(let ((,owrapper (cond ((std-instance-p ,object) (std-instance-wrapper ,object)) ((fsc-instance-p ,object) (fsc-instance-wrapper ,object)) #+new-kcl-wrapper (t (built-in-wrapper-of ,object)) #-new-kcl-wrapper (t (wrapper-of ,object))))) (if (eq 't (wrapper-state ,owrapper)) ,owrapper (check-wrapper-validity ,object))))) #+cmu17 ;;; semantically equivalent, but faster. ;;; (defmacro check-wrapper-validity1 (object) (let ((owrapper (gensym))) `(let ((,owrapper (kernel:layout-of object))) (if (kernel:layout-invalid ,owrapper) (check-wrapper-validity ,object) ,owrapper)))) (defvar *free-caches* nil) (defun get-cache (nkeys valuep limit-fn nlines) (declare (type non-negative-fixnum nlines)) (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (compute-cache-parameters nkeys valuep nlines) (declare (type non-negative-fixnum cache-mask actual-size line-size nlines)) (setf (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines (cache-field cache) (first-wrapper-cache-number-index) (cache-limit-fn cache) limit-fn (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size (cache-max-location cache) (let ((line (1- nlines))) (declare (type non-negative-fixnum line)) (if (= nkeys 1) (the fixnum (* line line-size)) (the fixnum (1+ (the fixnum (* line line-size)))))) (cache-vector cache) (get-cache-vector actual-size) (cache-overflow cache) nil) cache))) (defun get-cache-from-cache (old-cache new-nlines &optional (new-field (first-wrapper-cache-number-index))) (declare (type non-negative-fixnum new-nlines)) (let ((nkeys (cache-nkeys old-cache)) (valuep (cache-valuep old-cache)) (cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (if (= new-nlines (cache-nlines old-cache)) (values (cache-mask old-cache) (cache-size old-cache) (cache-line-size old-cache) (cache-nlines old-cache)) (compute-cache-parameters nkeys valuep new-nlines)) (declare (type non-negative-fixnum cache-mask actual-size line-size nlines)) (setf (cache-owner cache) (cache-owner old-cache) (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines (cache-field cache) new-field (cache-limit-fn cache) (cache-limit-fn old-cache) (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size (cache-max-location cache) (let ((line (1- nlines))) (declare (type non-negative-fixnum line)) (if (= nkeys 1) (the fixnum (* line line-size)) (the fixnum (1+ (the fixnum (* line line-size)))))) (cache-vector cache) (get-cache-vector actual-size) (cache-overflow cache) nil) cache))) (defun copy-cache (old-cache) (let* ((new-cache (copy-cache-internal old-cache)) (size (cache-size old-cache)) (old-vector (cache-vector old-cache)) (new-vector (get-cache-vector size))) (declare (simple-vector old-vector new-vector)) (dotimes (i size) (setf (svref new-vector i) (svref old-vector i))) (setf (cache-vector new-cache) new-vector) new-cache)) (defun free-cache (cache) (free-cache-vector (cache-vector cache)) (setf (cache-vector cache) #()) (setf (cache-owner cache) nil) (push cache *free-caches*) nil) (defun compute-line-size (x) (power-of-two-ceiling x)) (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector) ;;(declare (values cache-mask actual-size line-size nlines)) (declare (type non-negative-fixnum nkeys)) (if (= nkeys 1) (let* ((line-size (if valuep 2 1)) (cache-size (if (typep nlines-or-cache-vector 'fixnum) (the non-negative-fixnum (* line-size (the non-negative-fixnum (power-of-two-ceiling nlines-or-cache-vector)))) (cache-vector-size nlines-or-cache-vector)))) (declare (type non-negative-fixnum line-size cache-size)) (values (logxor (the non-negative-fixnum (1- cache-size)) (the non-negative-fixnum (1- line-size))) cache-size line-size (the non-negative-fixnum (floor cache-size line-size)))) (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) (cache-size (if (typep nlines-or-cache-vector 'fixnum) (the non-negative-fixnum (* line-size (the non-negative-fixnum (power-of-two-ceiling nlines-or-cache-vector)))) (1- (cache-vector-size nlines-or-cache-vector))))) (declare (type non-negative-fixnum line-size cache-size)) (values (logxor (the non-negative-fixnum (1- cache-size)) (the non-negative-fixnum (1- line-size))) (the non-negative-fixnum (1+ cache-size)) line-size (the non-negative-fixnum (floor cache-size line-size)))))) ;;; ;;; The various implementations of computing a primary cache location from ;;; wrappers. Because some implementations of this must run fast there are ;;; several implementations of the same algorithm. ;;; ;;; The algorithm is: ;;; ;;; SUM over the wrapper cache numbers, ;;; ENSURING that the result is a fixnum ;;; MASK the result against the mask argument. ;;; ;;; ;;; ;;; COMPUTE-PRIMARY-CACHE-LOCATION ;;; ;;; The basic functional version. This is used by the cache miss code to ;;; compute the primary location of an entry. ;;; (defun compute-primary-cache-location (field mask wrappers) (declare (type field-type field) (type non-negative-fixnum mask)) (if (not (listp wrappers)) (logand mask (the non-negative-fixnum (wrapper-cache-number-vector-ref wrappers field))) (let ((location 0) (i 0)) (declare (type non-negative-fixnum location i)) (dolist (wrapper wrappers) ;; ;; First add the cache number of this wrapper to location. ;; (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper field))) (declare (type non-negative-fixnum wrapper-cache-number)) (if (zerop wrapper-cache-number) (return-from compute-primary-cache-location 0) (setq location (the non-negative-fixnum (+ location wrapper-cache-number))))) ;; ;; Then, if we are working with lots of wrappers, deal with ;; the wrapper-cache-number-mask stuff. ;; (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) (setq location (logand location wrapper-cache-number-mask))) (incf i)) (the non-negative-fixnum (1+ (logand mask location)))))) ;;; ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION ;;; ;;; This version is called on a cache line. It fetches the wrappers from ;;; the cache line and determines the primary location. Various parts of ;;; the cache filling code call this to determine whether it is appropriate ;;; to displace a given cache entry. ;;; ;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol ;;; invalid to suggest to its caller that it would be provident to blow away ;;; the cache line in question. ;;; (defun compute-primary-cache-location-from-location (to-cache from-location &optional (from-cache to-cache)) (declare (type cache to-cache from-cache) (type non-negative-fixnum from-location)) (let ((result 0) (cache-vector (cache-vector from-cache)) (field (cache-field to-cache)) (mask (cache-mask to-cache)) (nkeys (cache-nkeys to-cache))) (declare (type field-type field) (type non-negative-fixnum result mask nkeys) (simple-vector cache-vector)) (dotimes (i nkeys) (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) (wcn (wrapper-cache-number-vector-ref wrapper field))) (declare (type non-negative-fixnum wcn)) (setq result (+ result wcn))) (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) (setq result (logand result wrapper-cache-number-mask)))) (if (= nkeys 1) (logand mask result) (the non-negative-fixnum (1+ (logand mask result)))))) ;;; ;;; NIL means nothing so far, no actual arg info has NILs ;;; in the metatype ;;; CLASS seen all sorts of metaclasses ;;; (specifically, more than one of the next 4 values) ;;; T means everything so far is the class T ;;; STANDARD-CLASS seen only standard classes ;;; BUILT-IN-CLASS seen only built in classes ;;; STRUCTURE-CLASS seen only structure classes ;;; (defun raise-metatype (metatype new-specializer) (let ((slot (find-class 'slot-class)) (standard (find-class 'standard-class)) (fsc (find-class 'funcallable-standard-class)) (structure (find-class 'structure-class)) (built-in (find-class 'built-in-class))) (flet ((specializer->metatype (x) (let ((meta-specializer (if (eq *boot-state* 'complete) (class-of (specializer-class x)) (class-of x)))) (cond ((eq x *the-class-t*) t) ((*subtypep meta-specializer standard) 'standard-instance) ((*subtypep meta-specializer fsc) 'standard-instance) ((*subtypep meta-specializer structure) 'structure-instance) ((*subtypep meta-specializer built-in) 'built-in-instance) ((*subtypep meta-specializer slot) 'slot-instance) (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)." new-specializer meta-specializer)))))) ;; ;; We implement the following table. The notation is ;; that X and Y are distinct meta specializer names. ;; ;; NIL ===> ;; X X ===> X ;; X Y ===> CLASS ;; (let ((new-metatype (specializer->metatype new-specializer))) (cond ((eq new-metatype 'slot-instance) 'class) ((null metatype) new-metatype) ((eq metatype new-metatype) new-metatype) (t 'class)))))) (defmacro with-dfun-wrappers ((args metatypes) (dfun-wrappers invalid-wrapper-p &optional wrappers classes types) invalid-arguments-form &body body) `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil) (,dfun-wrappers nil) (dfun-wrappers-tail nil) ,@(when wrappers `((wrappers-rev nil) (types-rev nil) (classes-rev nil)))) (dolist (mt ,metatypes) (unless args-tail (setq invalid-arguments-p t) (return nil)) (let* ((arg (pop args-tail)) (wrapper nil) ,@(when wrappers `((class *the-class-t*) (type 't)))) (unless (eq mt 't) (setq wrapper (wrapper-of arg)) (when (invalid-wrapper-p wrapper) (setq ,invalid-wrapper-p t) (setq wrapper (check-wrapper-validity arg))) (cond ((null ,dfun-wrappers) (setq ,dfun-wrappers wrapper)) ((not (consp ,dfun-wrappers)) (setq dfun-wrappers-tail (list wrapper)) (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail))) (t (let ((new-dfun-wrappers-tail (list wrapper))) (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) (setf dfun-wrappers-tail new-dfun-wrappers-tail)))) ,@(when wrappers `((setq class (wrapper-class* wrapper)) (setq type `(class-eq ,class))))) ,@(when wrappers `((push wrapper wrappers-rev) (push class classes-rev) (push type types-rev))))) (if invalid-arguments-p ,invalid-arguments-form (let* (,@(when wrappers `((,wrappers (nreverse wrappers-rev)) (,classes (nreverse classes-rev)) (,types (mapcar #'(lambda (class) `(class-eq ,class)) ,classes))))) ,@body)))) ;;; ;;; Some support stuff for getting a hold of symbols that we need when ;;; building the discriminator codes. Its ok for these to be interned ;;; symbols because we don't capture any user code in the scope in which ;;; these symbols are bound. ;;; (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) (defun dfun-arg-symbol (arg-number) (or (nth arg-number (the list *dfun-arg-symbols*)) (intern (format nil ".ARG~A." arg-number) *the-pcl-package*))) (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) (defun slot-vector-symbol (arg-number) (or (nth arg-number (the list *slot-vector-symbols*)) (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))) (defun make-dfun-lambda-list (metatypes applyp) (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i))) (when applyp (gather1 '&rest) (gather1 '.dfun-rest-arg.)))) (defun make-dlap-lambda-list (metatypes applyp) (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i))) (when applyp (gather1 '&rest)))) (defun make-emf-call (metatypes applyp fn-variable &optional emf-type) (let ((required (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i)))))) `(,(if (eq emf-type 'fast-method-call) 'invoke-effective-method-function-fast 'invoke-effective-method-function) ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) (defun make-dfun-call (metatypes applyp fn-variable) (let ((required (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i)))))) (if applyp `(function-apply ,fn-variable ,@required .dfun-rest-arg.) `(function-funcall ,fn-variable ,@required)))) (defun make-dfun-arg-list (metatypes applyp) (let ((required (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i)))))) (if applyp `(list* ,@required .dfun-rest-arg.) `(list ,@required)))) (defun make-fast-method-call-lambda-list (metatypes applyp) (gathering1 (collecting) (gather1 '.pv-cell.) (gather1 '.next-method-call.) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i))) (when applyp (gather1 '.dfun-rest-arg.)))) (defmacro fin-lambda-fn (arglist &body body) `#'(#+cmu kernel:instance-lambda #-cmu lambda ,arglist ,@body)) (defun make-dispatch-lambda (function-p metatypes applyp body) `(#+cmu ,(if function-p 'kernel:instance-lambda 'lambda) #-cmu lambda ,(if function-p (make-dfun-lambda-list metatypes applyp) (make-fast-method-call-lambda-list metatypes applyp)) ,@(unless function-p `((declare (ignore .pv-cell. .next-method-call.)))) #+cmu (declare (ignorable ,@(cddr (make-fast-method-call-lambda-list metatypes applyp)))) #+copy-&rest-arg ,@(when (and applyp function-p) `((setq .dfun-rest-arg. (copy-list .dfun-rest-arg.)))) ,@body)) ;;; ;;; Its too bad Common Lisp compilers freak out when you have a defun with ;;; a lot of LABELS in it. If I could do that I could make this code much ;;; easier to read and work with. ;;; ;;; Ahh Scheme... ;;; ;;; In the absence of that, the following little macro makes the code that ;;; follows a little bit more reasonable. I would like to add that having ;;; to practically write my own compiler in order to get just this simple ;;; thing is something of a drag. ;;; (eval-when (compile load eval) (defvar *cache* nil) (defconstant *local-cache-functions* '((cache () .cache.) (nkeys () (cache-nkeys .cache.)) (line-size () (cache-line-size .cache.)) (vector () (cache-vector .cache.)) (valuep () (cache-valuep .cache.)) (nlines () (cache-nlines .cache.)) (max-location () (cache-max-location .cache.)) (limit-fn () (cache-limit-fn .cache.)) (size () (cache-size .cache.)) (mask () (cache-mask .cache.)) (field () (cache-field .cache.)) (overflow () (cache-overflow .cache.)) ;; ;; Return T IFF this cache location is reserved. The only time ;; this is true is for line number 0 of an nkeys=1 cache. ;; (line-reserved-p (line) (declare (type non-negative-fixnum line)) (and (= (nkeys) 1) (= line 0))) ;; (location-reserved-p (location) (declare (type non-negative-fixnum location)) (and (= (nkeys) 1) (= location 0))) ;; ;; Given a line number, return the cache location. This is the ;; value that is the second argument to cache-vector-ref. Basically, ;; this deals with the offset of nkeys>1 caches and multiplies ;; by line size. ;; (line-location (line) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "line is reserved")) (if (= (nkeys) 1) (the non-negative-fixnum (* line (line-size))) (the non-negative-fixnum (1+ (the non-negative-fixnum (* line (line-size))))))) ;; ;; Given a cache location, return the line. This is the inverse ;; of LINE-LOCATION. ;; (location-line (location) (declare (type non-negative-fixnum location)) (if (= (nkeys) 1) (floor location (line-size)) (floor (the non-negative-fixnum (1- location)) (line-size)))) ;; ;; Given a line number, return the wrappers stored at that line. ;; As usual, if nkeys=1, this returns a single value. Only when ;; nkeys>1 does it return a list. An error is signalled if the ;; line is reserved. ;; (line-wrappers (line) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-wrappers (line-location line))) ;; (location-wrappers (location) ; avoid multiplies caused by line-location (declare (type non-negative-fixnum location)) (if (= (nkeys) 1) (cache-vector-ref (vector) location) (let ((list (make-list (nkeys))) (vector (vector))) (declare (simple-vector vector)) (dotimes (i (nkeys) list) (setf (nth i list) (cache-vector-ref vector (+ location i))))))) ;; ;; Given a line number, return true IFF the line's ;; wrappers are the same as wrappers. ;; (line-matches-wrappers-p (line wrappers) (declare (type non-negative-fixnum line)) (and (not (line-reserved-p line)) (location-matches-wrappers-p (line-location line) wrappers))) ;; (location-matches-wrappers-p (loc wrappers) ; must not be reserved (declare (type non-negative-fixnum loc)) (let ((cache-vector (vector))) (declare (simple-vector cache-vector)) (if (= (nkeys) 1) (eq wrappers (cache-vector-ref cache-vector loc)) (dotimes (i (nkeys) t) (unless (eq (pop wrappers) (cache-vector-ref cache-vector (+ loc i))) (return nil)))))) ;; ;; Given a line number, return the value stored at that line. ;; If valuep is NIL, this returns NIL. As with line-wrappers, ;; an error is signalled if the line is reserved. ;; (line-value (line) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-value (line-location line))) ;; (location-value (loc) (declare (type non-negative-fixnum loc)) (and (valuep) (cache-vector-ref (vector) (+ loc (nkeys))))) ;; ;; Given a line number, return true IFF that line has data in ;; it. The state of the wrappers stored in the line is not ;; checked. An error is signalled if line is reserved. (line-full-p (line) (when (line-reserved-p line) (error "Line is reserved.")) (not (null (cache-vector-ref (vector) (line-location line))))) ;; ;; Given a line number, return true IFF the line is full and ;; there are no invalid wrappers in the line, and the line's ;; wrappers are different from wrappers. ;; An error is signalled if the line is reserved. ;; (line-valid-p (line wrappers) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-valid-p (line-location line) wrappers)) ;; (location-valid-p (loc wrappers) (declare (type non-negative-fixnum loc)) (let ((cache-vector (vector)) (wrappers-mismatch-p (null wrappers))) (declare (simple-vector cache-vector)) (dotimes (i (nkeys) wrappers-mismatch-p) (let ((wrapper (cache-vector-ref cache-vector (+ loc i)))) (when (or (null wrapper) (invalid-wrapper-p wrapper)) (return nil)) (unless (and wrappers (eq wrapper (if (consp wrappers) (pop wrappers) wrappers))) (setq wrappers-mismatch-p t)))))) ;; ;; How many unreserved lines separate line-1 and line-2. ;; (line-separation (line-1 line-2) (declare (type non-negative-fixnum line-1 line-2)) (let ((diff (the fixnum (- line-2 line-1)))) (declare (fixnum diff)) (when (minusp diff) (setq diff (+ diff (nlines))) (when (line-reserved-p 0) (setq diff (1- diff)))) diff)) ;; ;; Given a cache line, get the next cache line. This will not ;; return a reserved line. ;; (next-line (line) (declare (type non-negative-fixnum line)) (if (= line (the fixnum (1- (nlines)))) (if (line-reserved-p 0) 1 0) (the non-negative-fixnum (1+ line)))) ;; (next-location (loc) (declare (type non-negative-fixnum loc)) (if (= loc (max-location)) (if (= (nkeys) 1) (line-size) 1) (the non-negative-fixnum (+ loc (line-size))))) ;; ;; Given a line which has a valid entry in it, this will return ;; the primary cache line of the wrappers in that line. We just ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an ;; easier packaging up of the call to it. ;; (line-primary (line) (declare (type non-negative-fixnum line)) (location-line (line-primary-location line))) ;; (line-primary-location (line) (declare (type non-negative-fixnum line)) (compute-primary-cache-location-from-location (cache) (line-location line))) )) (defmacro with-local-cache-functions ((cache) &body body) `(let ((.cache. ,cache)) (declare (type cache .cache.)) (macrolet ,(mapcar #'(lambda (fn) `(,(car fn) ,(cadr fn) `(let (,,@(mapcar #'(lambda (var) ``(,',var ,,var)) (cadr fn))) ,@',(cddr fn)))) *local-cache-functions*) ,@body))) ) ;;; ;;; Here is where we actually fill, recache and expand caches. ;;; ;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external ;;; entrypoints into this code. ;;; ;;; FILL-CACHE returns 1 value: a new cache ;;; ;;; a wrapper field number ;;; a cache ;;; a mask ;;; an absolute cache size (the size of the actual vector) ;;; It tries to re-adjust the cache every time it makes a new fill. The ;;; intuition here is that we want uniformity in the number of probes needed to ;;; find an entry. Furthermore, adjusting has the nice property of throwing out ;;; any entries that are invalid. ;;; (defvar *cache-expand-threshold* 1.25) (defun fill-cache (cache wrappers value &optional free-cache-p) ;;(declare (values cache)) (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check. (error "fill-cache: wrappers arg is NIL!")) (or (fill-cache-p nil cache wrappers value) (and (< (ceiling (* (cache-count cache) 1.25)) (if (= (cache-nkeys cache) 1) (1- (cache-nlines cache)) (cache-nlines cache))) (adjust-cache cache wrappers value free-cache-p)) (expand-cache cache wrappers value free-cache-p))) (defvar *check-cache-p* nil) (defmacro maybe-check-cache (cache) `(progn (when *check-cache-p* (check-cache ,cache)) ,cache)) (defun check-cache (cache) (with-local-cache-functions (cache) (let ((location (if (= (nkeys) 1) 0 1)) (limit (funcall (limit-fn) (nlines)))) (dotimes (i (nlines) cache) (when (and (not (location-reserved-p location)) (line-full-p i)) (let* ((home-loc (compute-primary-cache-location-from-location cache location)) (home (location-line (if (location-reserved-p home-loc) (next-location home-loc) home-loc))) (sep (when home (line-separation home i)))) (when (and sep (> sep limit)) (error "bad cache ~S ~@ value at location ~D is ~D lines from its home. limit is ~D." cache location sep limit)))) (setq location (next-location location)))))) (defun probe-cache (cache wrappers &optional default limit-fn) ;;(declare (values value)) (unless wrappers (error "probe-cache: wrappers arg is NIL!")) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) (limit (funcall (or limit-fn (limit-fn)) (nlines)))) (declare (type non-negative-fixnum location limit)) (when (location-reserved-p location) (setq location (next-location location))) (dotimes (i (the non-negative-fixnum (1+ limit))) (when (location-matches-wrappers-p location wrappers) (return-from probe-cache (or (not (valuep)) (location-value location)))) (setq location (next-location location))) (dolist (entry (overflow)) (when (equal (car entry) wrappers) (return-from probe-cache (or (not (valuep)) (cdr entry))))) default))) (defun map-cache (function cache &optional set-p) (with-local-cache-functions (cache) (let ((set-p (and set-p (valuep)))) (dotimes (i (nlines) cache) (unless (or (line-reserved-p i) (not (line-valid-p i nil))) (let ((value (funcall function (line-wrappers i) (line-value i)))) (when set-p (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys))) value))))) (dolist (entry (overflow)) (let ((value (funcall function (car entry) (cdr entry)))) (when set-p (setf (cdr entry) value)))))) cache) (defun cache-count (cache) (with-local-cache-functions (cache) (let ((count 0)) (declare (type non-negative-fixnum count)) (dotimes (i (nlines) count) (unless (line-reserved-p i) (when (line-full-p i) (incf count))))))) (defun entry-in-cache-p (cache wrappers value) (declare (ignore value)) (with-local-cache-functions (cache) (dotimes (i (nlines)) (unless (line-reserved-p i) (when (equal (line-wrappers i) wrappers) (return t)))))) ;;; ;;; returns T or NIL ;;; (defun fill-cache-p (forcep cache wrappers value) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) (primary (location-line location))) (declare (type non-negative-fixnum location primary)) (multiple-value-bind (free emptyp) (find-free-cache-line primary cache wrappers) (when (or forcep emptyp) (when (not emptyp) (push (cons (line-wrappers free) (line-value free)) (cache-overflow cache))) ;;(fill-line free wrappers value) (let ((line free)) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Attempt to fill a reserved line.")) (let ((loc (line-location line)) (cache-vector (vector))) (declare (type non-negative-fixnum loc) (simple-vector cache-vector)) (cond ((= (nkeys) 1) (setf (cache-vector-ref cache-vector loc) wrappers) (when (valuep) (setf (cache-vector-ref cache-vector (1+ loc)) value))) (t (let ((i 0)) (declare (type non-negative-fixnum i)) (dolist (w wrappers) (setf (cache-vector-ref cache-vector (+ loc i)) w) (setq i (the non-negative-fixnum (1+ i))))) (when (valuep) (setf (cache-vector-ref cache-vector (+ loc (nkeys))) value)))) (maybe-check-cache cache)))))))) (defun fill-cache-from-cache-p (forcep cache from-cache from-line) (declare (type non-negative-fixnum from-line)) (with-local-cache-functions (cache) (let ((primary (location-line (compute-primary-cache-location-from-location cache (line-location from-line) from-cache)))) (declare (type non-negative-fixnum primary)) (multiple-value-bind (free emptyp) (find-free-cache-line primary cache) (when (or forcep emptyp) (when (not emptyp) (push (cons (line-wrappers free) (line-value free)) (cache-overflow cache))) ;;(transfer-line from-cache-vector from-line cache-vector free) (let ((from-cache-vector (cache-vector from-cache)) (to-cache-vector (vector)) (to-line free)) (declare (type non-negative-fixnum to-line)) (if (line-reserved-p to-line) (error "transfering something into a reserved cache line.") (let ((from-loc (line-location from-line)) (to-loc (line-location to-line))) (declare (type non-negative-fixnum from-loc to-loc)) (modify-cache to-cache-vector (dotimes (i (line-size)) (setf (cache-vector-ref to-cache-vector (+ to-loc i)) (cache-vector-ref from-cache-vector (+ from-loc i))))))) (maybe-check-cache cache))))))) ;;; ;;; Returns NIL or (values ) ;;; ;;; This is only called when it isn't possible to put the entry in the cache ;;; the easy way. That is, this function assumes that FILL-CACHE-P has been ;;; called as returned NIL. ;;; ;;; If this returns NIL, it means that it wasn't possible to find a wrapper ;;; field for which all of the entries could be put in the cache (within the ;;; limit). ;;; (defun adjust-cache (cache wrappers value free-old-cache-p) (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (nlines) (field)))) (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield))) ((null nfield) (free-cache ncache) nil) (let ((nfield nfield)) (declare (type field-type nfield)) (setf (cache-field ncache) nfield) (labels ((try-one-fill-from-line (line) (fill-cache-from-cache-p nil ncache cache line)) (try-one-fill (wrappers value) (fill-cache-p nil ncache wrappers value))) (if (and (dotimes (i (nlines) t) (when (and (null (line-reserved-p i)) (line-valid-p i wrappers)) (unless (try-one-fill-from-line i) (return nil)))) (dolist (wrappers+value (cache-overflow cache) t) (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) (return nil))) (try-one-fill wrappers value)) (progn (when free-old-cache-p (free-cache cache)) (return (maybe-check-cache ncache))) (flush-cache-vector-internal (cache-vector ncache))))))))) ;;; ;;; returns: (values ) ;;; (defun expand-cache (cache wrappers value free-old-cache-p) ;;(declare (values cache)) (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (* (nlines) 2)))) (labels ((do-one-fill-from-line (line) (unless (fill-cache-from-cache-p nil ncache cache line) (do-one-fill (line-wrappers line) (line-value line)))) (do-one-fill (wrappers value) (setq ncache (or (adjust-cache ncache wrappers value t) (fill-cache-p t ncache wrappers value)))) (try-one-fill (wrappers value) (fill-cache-p nil ncache wrappers value))) (dotimes (i (nlines)) (when (and (null (line-reserved-p i)) (line-valid-p i wrappers)) (do-one-fill-from-line i))) (dolist (wrappers+value (cache-overflow cache)) (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) (do-one-fill (car wrappers+value) (cdr wrappers+value)))) (unless (try-one-fill wrappers value) (do-one-fill wrappers value)) (when free-old-cache-p (free-cache cache)) (maybe-check-cache ncache))))) ;;; ;;; This is the heart of the cache filling mechanism. It implements the decisions ;;; about where entries are placed. ;;; ;;; Find a line in the cache at which a new entry can be inserted. ;;; ;;; ;;; is in fact empty? ;;; (defun find-free-cache-line (primary cache &optional wrappers) ;;(declare (values line empty?)) (declare (type non-negative-fixnum primary)) (with-local-cache-functions (cache) (when (line-reserved-p primary) (setq primary (next-line primary))) (let ((limit (funcall (limit-fn) (nlines))) (wrappedp nil) (lines nil) (p primary) (s primary)) (declare (type non-negative-fixnum p s limit)) (block find-free (loop ;; Try to find a free line starting at .

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 (dotimes (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.7.1/pcl/PaxHeaders/gcl_pcl_vector.lisp0000644000000000000000000000013114733564552016015 xustar0030 mtime=1735321962.631572278 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_vector.lisp0000644000175000017500000012074514733564552015425 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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)) (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 '#()) (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) (declare (optimize (safety 1))) (check-type pv-size si::seqbnd) (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 (destructuring-bind (ignore ignore slot-name-form) form (declare (ignore ignore)) (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 (destructuring-bind (ignore ignore slot-name-form &optional new-value) form (declare (ignore ignore)) (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 (destructuring-bind (ignore ignore slot-name-form &optional new-value) form (declare (ignore ignore)) (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 (destructuring-bind (ignore ignore &optional new-value) form (declare (ignore ignore)) (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 ignorable 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 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*)) (if (eq (car dname) 'class) (if (member (car form) args) (push `(declare (,@dname ,@form)) outer-decls) (push `(declare (,@dname ,@form)) inner-decls)) (progn (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)) ; (print (list 'baz lambda-list nreq restp)) (break) (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) (defun split-declarations-moving-ignores (body req-args &aux r) (multiple-value-bind (outer-decls inner-decls body) (split-declarations body req-args) (values (mapcar (lambda (x) (cons 'declare (remove-if (lambda (y) (when (and (consp y) (member (car y) '(ignore ignorable))) (push y r))) (cdr x)))) outer-decls) (cons (cons 'declare r) inner-decls) body))) (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) (multiple-value-bind (outer-decls inner-decls body) (split-declarations-moving-ignores 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 (declare (ignorable .pv-cell. .next-method-call. ,@(when rest-arg (list rest-arg)))) (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)) (declare (ignorable ,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.7.1/pcl/PaxHeaders/gcl_pcl_walk.lisp0000644000000000000000000000013114542551763015447 xustar0030 mtime=1703597043.376023016 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_walk.lisp0000644000175000017500000022037614542551763015060 0ustar00cammcamm;;;-*- 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) #+gcl(import 'si::macro) ;;; ;;; 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 #+gcl macro 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) . (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) '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 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.7.1/pcl/PaxHeaders/gcl_pcl_init.lisp0000644000000000000000000000013114733440601015442 xustar0030 mtime=1735278977.090650063 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_init.lisp0000644000175000017500000002476214733440601015054 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 'program-error :format-control "Invalid initialization argument ~S for class ~S" :format-arguments (list (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 'program-error :format-control "Invalid initialization argument ~S for class ~S" :format-arguments (list (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) ;; FIXME this should be in the -t- and -nil- functions eventually ;; loop through initargs looking for errors (doplist (initarg val) initargs (declare (ignore val))) (return-from shared-initialize (progn (call-initialize-function (initialize-info-shared-initialize-t-function (initialize-info (class-of instance) initargs)) instance initargs) instance))) (when (eq slot-names 'nil) ;; FIXME this should be in the -t- and -nil- functions eventually ;; loop through initargs looking for errors (doplist (initarg val) initargs (declare (ignore val))) (return-from shared-initialize (progn (call-initialize-function (initialize-info-shared-initialize-nil-function (initialize-info (class-of instance) initargs)) instance initargs) instance))) ;; ;; 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 (when (evenp (length initargs)) (getf initargs :allow-other-keys)) ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (push :allow-other-keys legal) (doplist (key val) initargs (declare (ignore val)) (unless (memq key legal) (if error-p (error 'program-error :format-control "Invalid initialization argument ~S for class ~S" :format-arguments (list 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 'program-error :format-control "Invalid initialization argument ~S for class ~S" :format-arguments (list key (class-name class))) (return-from check-initargs-2-list nil))))) t) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_precom1.lisp0000644000000000000000000000013114542551763016057 xustar0030 mtime=1703597043.376023016 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_precom1.lisp0000644000175000017500000000355714542551763015470 0ustar00cammcamm;;;-*-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) ;;; ;;; 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 need. Some ports may want to preallocate some more of these. ;;; (eval-when (load) (flet ((allocate (n size) (mapcar #'free-cache-vector (mapcar #'get-cache-vector (make-list n :initial-element size))))) (allocate 128 4) (allocate 64 8) (allocate 64 9) (allocate 32 16) (allocate 16 17) (allocate 16 32) (allocate 1 64))) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_defs.lisp0000644000000000000000000000013114555557372015440 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_defs.lisp0000644000175000017500000010615314555557372015045 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 ) (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 (when (symbolp symbol) (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))) ;; FIXME add setf expander for fdefinition -- right now we go through ;; the following code which expands to a call to si::fset #+(and setf (not cmu) (not kcl)) (setf (fdefinition name) new-definition) #+kcl (setf (symbol-function (or (si::traced-sym name) 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)))) (eval-when (compile load eval) (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 gcl) (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) (declare (ignorable predicate)) (unless (get name 'si::deftype-definition) ; (print `(deftype ,name nil `(si::std-instance ,(si::coerce-to-standard-class ',name)))) ; (print (si::coerce-to-standard-class name)) (eval `(deftype ,name nil t)) (remprop name 'si::simple-typep-fn))) ;; #+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. ;; (unless (get name 'si::deftype-definition) (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 (or (symbol-package name) *package*)) 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 float rational) (t)) (complex (number) () (number t) #c(1 1)) (float (real) () (real number t) 1.0) (real (number) (rational float) (number t)) (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)) (pathname (t) (logical-pathname) (t) #p"foo") (logical-pathname (pathname t) () (pathname t) ) (readtable (t) () (t) ,*readtable*) (package (t) () (t) ,*package*) (hash-table (t) () (t) ) (function (t) () (t) ,#'cons) ; (function (t) (interpreted-function ; compiled-function) (t) ) ; (interpreted-function ; (function t) ; () (function t) ,(eval `(function (lambda nil nil)))) ; (compiled-function ; (function t) ; () (function t) ,#'cons) (synonym-stream (stream t) () (stream t) ,*standard-output*) (echo-stream (stream t) () (stream t) ) (two-way-stream (stream t) () (stream t) ) (string-stream (stream t) () (stream t) ) (concatenated-stream (stream t) () (stream t) ) (broadcast-stream (stream t) () (stream t) ) (file-stream (stream t) () (stream t) ) (stream (t) (synonym-stream string-stream two-way-stream echo-stream file-stream concatenated-stream broadcast-stream) (t)) (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) (random-state (t) (null) (t) #$0) (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))) (push (make-early-class-definition 'function nil 'built-in-class '(t) nil nil) *early-class-definitions*) (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 funcallable-standard-object (standard-object function) () (:metaclass funcallable-standard-class)) (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 funcallable-standard-object) ((initial-methods :initform () :accessor generic-function-initial-methods)) (: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) (declarations :initform () :initarg :declare :reader generic-function-declarations) ) (: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))) (defclass long-method-combination (standard-method-combination) ((function :initarg :function :reader long-method-combination-function) (arguments-lambda-list :initarg :arguments-lambda-list :reader long-method-combination-arguments-lambda-list))) (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) (long-method-combination long-method-combination-p))) (defun early-find-class-symbol (x &optional errorp environment) (declare (ignore errorp environment)) (when (or (member x *early-class-definitions* :key 'cadr) (gethash x *find-class*)) x)) (defun mk-early-cpl (sym) (let ((l (nth 4 (car (member sym *early-class-definitions* :key 'cadr))))) (append l (reduce (lambda (&rest r) (when r (apply 'union r))) (mapcar 'mk-early-cpl l))))) (defun early-class-precedence-list-symbol (x &aux tem) (cond ((mk-early-cpl x)) ((setq tem (gethash x *find-class*)) (early-class-precedence-list (car tem))))) (setf (get 'si::si-find-class 'si::early) 'early-find-class-symbol) (setf (get 'si::si-class-precedence-list 'si::early) 'early-class-precedence-list-symbol) (setf (get 'si::si-class-of 'si::early) 'early-class-name-of) ;(setf (symbol-function 'si::find-class) (symbol-function 'early-find-class-symbol)) ;(setf (symbol-function 'si::class-precedence-list) (symbol-function 'early-class-precedence-list-symbol)) ;(setf (symbol-function 'si::class-of) (symbol-function 'early-class-name-of)) ;(setf (symbol-function 'si::class-direct-subclasses) (symbol-function 'early-class-direct-subclasses)) ;FIXME need class-name here gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_dlisp.lisp0000644000000000000000000000013114735762334015626 xustar0030 mtime=1735910620.504230215 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_dlisp.lisp0000644000175000017500000003745314735762334015241 0ustar00cammcamm;;;-*-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 (t) nil) 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))))) (values (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*) (values (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) `(values (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.7.1/pcl/PaxHeaders/gcl_pcl_env.lisp0000644000000000000000000000013114733440601015267 xustar0030 mtime=1735278977.090650063 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_env.lisp0000644000175000017500000003545114733440601014676 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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))) (defun pcl-describe (object &optional stream) (let ((stream (cond ((eq stream t) *terminal-io*) ((not stream) *standard-output*) (stream)))) (describe-object object stream) (values))) (defmethod describe-object (object stream) #-cmu (cond ((or #+kcl (packagep object)) (describe-package object stream)) ((funcall (original-definition 'describe) object stream))) #+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-used-by-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)) (defgeneric make-load-form (object &optional environment)) (macrolet ((define-default-method (class) `(defmethod make-load-form ((object ,class) &optional env) (declare (ignore env)) (error "~@" 'make-load-form object)))) ; (define-default-method condition) (define-default-method standard-object) (define-default-method structure-object)) (defmethod make-load-form ((class class) &optional env) (declare (ignore env)) (let ((name (class-name class))) (unless (and name (eq (find-class name nil) class)) (error "~@" class)) `(find-class ',name))) (defun make-load-form-saving-slots (object &key slot-names environment) (declare (ignore environment)) (let (inits (class (class-of object))) (dolist (slot (class-slots class)) (let ((slot-name (slot-definition-name slot))) (when (or (memq slot-name slot-names) (and (null slot-names) (eq :instance (slot-definition-allocation slot)))) (if (slot-boundp-using-class class object slot) (let ((value (slot-value-using-class class object slot))) (push `(setf (slot-value ,object ',slot-name) ',value) inits)) (push `(slot-makunbound ,object ',slot-name) inits))))) (values `(allocate-instance (find-class ',(class-name class))) `(progn .,(nreverse inits))))) ;;; 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.7.1/pcl/PaxHeaders/gcl_pcl_precom2.lisp0000644000000000000000000000013114542551763016060 xustar0030 mtime=1703597043.376023016 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_precom2.lisp0000644000175000017500000000226014542551763015457 0ustar00cammcamm;;;-*-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.7.1/pcl/PaxHeaders/gcl_pcl_generic_functions.lisp0000644000000000000000000000013114555557372020223 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_generic_functions.lisp0000644000175000017500000006040514555557372017627 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;;;-*-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 long-method-combination-p (object)) ; (long-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-declarations (standard-generic-function)) ; (standard-generic-function) (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 generic-function-argument-precedence-order (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 generic-function-initial-methods (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-declarations) (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 generic-function-initial-methods) (new-value 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) ;; FIXME make sure this is right ;(defgeneric change-class (instance new-class-name &rest initargs)) (defgeneric change-class (instance new-class-name &key &allow-other-keys)) ; (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 no-next-method (generic-function method &rest args)) ;(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) ;; FIXME synch with cmucl to use these defs ;;; 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 get-method (generic-function qualifiers specializers &optional errorp)) ; (standard-generic-function t t) (defgeneric find-method (generic-function qualifiers specializers &optional errorp)) (defgeneric (setf documentation) (new-value slotd doc-type)) ; (t t) ; (t documentation-mixin) ; (t standard-slot-definition) (defgeneric documentation (slotd 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 no-primary-method (generic-function &rest args)) (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.7.1/pcl/PaxHeaders/gcl_pcl_iterate.lisp0000644000000000000000000000013114555557372016154 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_iterate.lisp0000644000175000017500000016577714555557372015602 0ustar00cammcamm;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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) (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 (ignorable 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) `((*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 (when 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 (if (null (cdddr realizer)) (third realizer) (cons 'let (cdr realizer))) finish-forms) ; Simple (LAMBDA () expr) => expr ; There could be declarations ; or something, so leave as a ; LET ; Declarations about the LET ; variables also has to ; percolate up (unless (null localdecls) (setq top-decls (nconc top-decls (sublis renamed-vars localdecls)))) (return)) (maybe-warn :definition (concatenate 'string "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 (if leftover-body (prog1 `(progn ,@leftover-body ,expansion) (setq leftover-body nil)) expansion))))))))) (setq body (walk-gathering-body body gathering-env acc-info)) (unless (eq body :abort) `(let* ,top-bindings ,@(when top-decls `((declare ,@top-decls))) ,body ,(if (null (cdr finish-forms)) ; just a single value (car finish-forms) `(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.7.1/pcl/PaxHeaders/gcl_pcl_slots_boot.lisp0000644000000000000000000000013114555557372016706 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_slots_boot.lisp0000644000175000017500000003656314555557372016322 0ustar00cammcamm;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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)) ;(defun conditions::error (&rest r) nil) (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))) (declare (ignorable sym)) ;FIXME (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*) (values (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*) (values (slot-unbound (class-of instance) instance slot-name)) value))))) (cons #'(lambda (instance) (let ((value (cdr index))) (if (eq value *slot-unbound*) (values (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*) (values (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*) (values (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*) (values (slot-unbound class instance slot-name)) value))))) (cons #'(lambda (class instance slotd) (declare (ignore slotd)) (let ((value (cdr index))) (if (eq value *slot-unbound*) (values (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*) (values (slot-unbound (class-of instance) instance slot-name)) value))) (cons (let ((value (cdr index))) (if (eq value *slot-unbound*) (values (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.7.1/pcl/PaxHeaders/gcl_pcl_combin.lisp0000644000000000000000000000013114555557372015766 xustar0030 mtime=1706483450.808392729 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_combin.lisp0000644000175000017500000004507014555557372015373 0ustar00cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 get-method-function (method &optional method-alist wrappers) (let ((fn (cadr (assoc method method-alist)))) (if fn (values fn nil nil nil) (multiple-value-bind (mf fmf) (if (listp method) (early-method-function method) (values nil (method-fast-function method))) (let* ((pv-table (and fmf (method-function-pv-table fmf)))) (if (and fmf (or (null pv-table) wrappers)) (let* ((pv-wrappers (when pv-table (pv-wrappers-from-all-wrappers pv-table wrappers))) (pv-cell (when (and pv-table pv-wrappers) (pv-table-lookup pv-table pv-wrappers)))) (values mf t fmf pv-cell)) (values (or mf (if (listp method) (setf (cadr method) (method-function-from-fast-function fmf)) (method-function method))) t nil nil))))))) (defun make-effective-method-function (generic-function form &optional method-alist wrappers) (funcall (the function (make-effective-method-function1 generic-function form (not (null method-alist)) (not (null wrappers)))) method-alist wrappers)) (defun make-effective-method-function1 (generic-function form method-alist-p wrappers-p) (if (and (listp form) (eq (car form) 'call-method)) (make-effective-method-function-simple generic-function form) ;; ;; We have some sort of `real' effective method. Go off and get a ;; compiled function for it. Most of the real hair here is done by ;; the GET-FUNCTION mechanism. ;; (make-effective-method-function-internal generic-function form method-alist-p wrappers-p))) (defun make-effective-method-function-type (generic-function form method-alist-p wrappers-p) (if (and (listp form) (eq (car form) 'call-method)) (let* ((cm-args (cdr form)) (method (car cm-args))) (when method (if (if (listp method) (eq (car method) ':early-method) (method-p method)) (if method-alist-p 't (multiple-value-bind (mf fmf) (if (listp method) (early-method-function method) (values nil (method-fast-function method))) (declare (ignore mf)) (let* ((pv-table (and fmf (method-function-pv-table fmf)))) (if (and fmf (or (null pv-table) wrappers-p)) 'fast-method-call 'method-call)))) (if (and (consp method) (eq (car method) 'make-method)) (make-effective-method-function-type generic-function (cadr method) method-alist-p wrappers-p) (type-of method))))) 'fast-method-call)) (defun make-effective-method-function-simple (generic-function form &optional no-fmf-p) ;; ;; The effective method is just a call to call-method. This opens up ;; the possibility of just using the method function of the method as ;; the effective method function. ;; ;; But we have to be careful. If that method function will ask for ;; the next methods we have to provide them. We do not look to see ;; if there are next methods, we look at whether the method function ;; asks about them. If it does, we must tell it whether there are ;; or aren't to prevent the leaky next methods bug. ;; (let* ((cm-args (cdr form)) (fmf-p (and (null no-fmf-p) (or (not (eq *boot-state* 'complete)) (gf-fast-method-function-p generic-function)) (null (cddr cm-args)))) (method (car cm-args)) (cm-args1 (cdr cm-args))) #'(lambda (method-alist wrappers) (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p method-alist wrappers)))) (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) (multiple-value-bind (mf real-mf-p fmf pv-cell) (get-method-function method method-alist wrappers) (if fmf (let* ((next-methods (car cm-args)) (next (make-effective-method-function-simple1 gf (car next-methods) (list* (cdr next-methods) (cdr cm-args)) fmf-p method-alist wrappers)) (arg-info (method-function-get fmf ':arg-info))) (make-fast-method-call :function fmf :pv-cell pv-cell :next-method-call next :arg-info arg-info)) (if real-mf-p (make-method-call :function mf :call-method-args cm-args) mf)))) (defun make-effective-method-function-simple1 (gf method cm-args fmf-p &optional method-alist wrappers) (when method (if (if (listp method) (eq (car method) ':early-method) (method-p method)) (make-emf-from-method method cm-args gf fmf-p method-alist wrappers) (if (and (consp method) (eq (car method) 'make-method)) (make-effective-method-function gf (cadr method) method-alist wrappers) method)))) (defvar *global-effective-method-gensyms* ()) (defvar *rebound-effective-method-gensyms*) (defun get-effective-method-gensym () (or (pop *rebound-effective-method-gensyms*) (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" (length *global-effective-method-gensyms*)) "PCL"))) (setq *global-effective-method-gensyms* (append *global-effective-method-gensyms* (list new))) new))) (let ((*rebound-effective-method-gensyms* ())) (dotimes (i 10) (get-effective-method-gensym))) (defun expand-effective-method-function (gf effective-method &optional env) (declare (ignore env)) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info gf) (declare (ignore nreq nkeys arg-info)) (let ((ll (make-fast-method-call-lambda-list metatypes applyp))) (cond ;; When there are no primary methods and a next-method call ;; occurs effective-method is (%no-primary-method ), ;; which we define here to collect all gf arguments, to pass ;; those together with the GF to no-primary-method: ((eq (first effective-method) '%no-primary-method) `(lambda (.pv-cell. .next-method-call. &rest .args.) (declare (ignore .pv-cell. .next-method-call.)) (flet ((%no-primary-method (gf) (apply #'no-primary-method gf .args.))) ,effective-method))) ;; When the method combination uses the :arguments option ((and (eq *boot-state* 'complete) ;; Otherwise the METHOD-COMBINATION slot is not bound. (let ((combin (generic-function-method-combination gf))) (and (long-method-combination-p combin) (long-method-combination-arguments-lambda-list combin)))) (let* ((required (dfun-arg-symbol-list metatypes)) (gf-args (if applyp `(list* ,@required .dfun-rest-arg.) `(list ,@required)))) `(lambda ,ll (declare (ignore .pv-cell. .next-method-call.)) (let ((.gf-args. ,gf-args)) (declare (ignorable .gf-args.)) ,effective-method)))) (t `(lambda ,ll (declare (ignore .pv-cell. .next-method-call.)) ,effective-method)))))) (defun expand-emf-call-method (gf form metatypes applyp env) (declare (ignore gf metatypes applyp env)) `(call-method ,(cdr form))) (defmacro call-method (&rest args) (declare (ignore args)) `(error "~S outside of an effective method form" 'call-method)) (defun check-applicable-keywords (valid-keys rest-arg &aux aok invalid) (do ((r rest-arg (cddr r))) ((endp r) (when invalid (unless (car aok) (error 'program-error "Invalid keys ~S: valid keys are ~S" invalid valid-keys)))) (unless (typep r '(cons symbol cons)) (error 'program-error "Bad keyword arguments" r)) (let ((key (car r))) (if (eq key :allow-other-keys) (unless aok (setq aok (cdr r))) (unless (or (eq valid-keys t) (memq key valid-keys)) (push key invalid)))))) (defun memf-test-converter (form generic-function method-alist-p wrappers-p) (case (when (consp form) (car form)) (call-method (case (make-effective-method-function-type generic-function form method-alist-p wrappers-p) (fast-method-call '.fast-call-method.) (t '.call-method.))) (call-method-list (case (if (every #'(lambda (form) (eq 'fast-method-call (make-effective-method-function-type generic-function form method-alist-p wrappers-p))) (cdr form)) 'fast-method-call 't) (fast-method-call '.fast-call-method-list.) (t '.call-method-list.))) (check-applicable-keywords 'check-applicable-keywords) (otherwise (default-test-converter form)))) (defun memf-code-converter (form generic-function metatypes applyp method-alist-p wrappers-p) (case (when (consp form) (car form)) (call-method (let ((gensym (get-effective-method-gensym))) (values (make-emf-call metatypes applyp gensym (make-effective-method-function-type generic-function form method-alist-p wrappers-p)) (list gensym)))) (call-method-list (let ((gensym (get-effective-method-gensym)) (type (if (every #'(lambda (form) (eq 'fast-method-call (make-effective-method-function-type generic-function form method-alist-p wrappers-p))) (cdr form)) 'fast-method-call 't))) (values `(dolist (emf ,gensym nil) ,(make-emf-call metatypes applyp 'emf type)) (list gensym)))) (check-applicable-keywords (values `(check-applicable-keywords ;.keyargs-start. .valid-keys. ; .dfun-more-context. ; .dfun-more-count. .dfun-rest-arg.) '())) (otherwise (default-code-converter form)))) (defun memf-constant-converter (form generic-function) (case (when (consp form) (car form)) (call-method (list (cons '.meth. (make-effective-method-function-simple generic-function form)))) (call-method-list (list (cons '.meth-list. (mapcar #'(lambda (form) (make-effective-method-function-simple generic-function form)) (cdr form))))) (check-applicable-keywords '()) (otherwise (default-constant-converter form)))) (defun make-effective-method-function-internal (generic-function effective-method method-alist-p wrappers-p) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info generic-function) (declare (ignore nkeys arg-info)) (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) (name (if (early-gf-p generic-function) (early-gf-name generic-function) (generic-function-name generic-function))) (arg-info (cons nreq applyp)) (effective-method-lambda (expand-effective-method-function generic-function effective-method))) (multiple-value-bind (cfunction constants) (get-function1 effective-method-lambda #'(lambda (form) (memf-test-converter form generic-function method-alist-p wrappers-p)) #'(lambda (form) (memf-code-converter form generic-function metatypes applyp method-alist-p wrappers-p)) #'(lambda (form) (memf-constant-converter form generic-function))) #'(lambda (method-alist wrappers) (let* ((constants (mapcar #'(lambda (constant) (if (consp constant) (case (car constant) (.meth. (funcall (the function (cdr constant)) method-alist wrappers)) (.meth-list. (mapcar #'(lambda (fn) (funcall (the function fn) method-alist wrappers)) (cdr constant))) (t constant)) constant)) constants)) (function (set-function-name (apply cfunction constants) `(combined-method ,name)))) (make-fast-method-call :function function :arg-info arg-info))))))) (defmacro call-method-list (&rest calls) `(progn ,@calls)) (defun make-call-methods (methods) `(call-method-list ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods))) (defun key-names (lambda-list &aux (k (member '&key lambda-list)) (aok (member '&allow-other-keys k)) (aux (or aok (member '&aux k))) (k (if aux (ldiff k aux) k))) (if aok t (mapcar (lambda (x) (typecase x (keyword x) (symbol (intern (string x) :keyword)) ((cons keyword cons) (car x)) ((cons symbol cons) (intern (string (car x)) :keyword)) ((cons cons cons) (caar x)))) (cdr k)))) (defun compute-applicable-keywords (gf methods) (reduce (lambda (y x) (or (eq y t) (let ((knx (key-names x))) (or (eq knx t) (union knx y))))) (mapcar (lambda (x) (if (consp x) (early-method-lambda-list x) (method-lambda-list x))) methods) :initial-value (key-names (generic-function-lambda-list gf)))) (defun gf-ll-nopt (gf-ll &aux (x (member '&optional gf-ll))) (length (ldiff (cdr x) (member-if (lambda (x) (member x '(&rest &key &allow-other-keys &aux))) x)))) (defun standard-compute-effective-method (generic-function combin applicable-methods) (declare (ignore combin)) (let ((before ()) (primary ()) (after ()) (around ())) (dolist (m applicable-methods) (let ((qualifiers (if (listp m) (early-method-qualifiers m) (method-qualifiers m)))) (cond ((member ':before qualifiers) (push m before)) ((member ':after qualifiers) (push m after)) ((member ':around qualifiers) (push m around)) (t (push m primary))))) (setq before (reverse before) after (reverse after) primary (reverse primary) around (reverse around)) ; (when (eq generic-function (symbol-function 'shared-initialize)) ; (break "here3 ~a ~a ~a~%" generic-function combin applicable-methods)) ; (when (eq generic-function (symbol-function 'compute-effective-method)) ; (break "here2 ~a ~a ~a~%" generic-function combin applicable-methods)) (cond ((null primary) ; (break "here we are ~a ~a ~a~%" generic-function combin applicable-methods) `(error "No primary method for the generic function ~S." ',generic-function)) ((and (null before) (null after) (null around)) ;; ;; By returning a single call-method `form' here we enable an important ;; implementation-specific optimization. ;; (let ((call-method `(call-method ,(first primary) ,(rest primary))) (gf-ll (gf-lambda-list generic-function))) (if (member '&key gf-ll) `(progn (let* ((.valid-keys. ',(compute-applicable-keywords generic-function applicable-methods)) (.dfun-rest-arg. (nthcdr ,(gf-ll-nopt gf-ll) .dfun-rest-arg.))) (check-applicable-keywords)) ,call-method) call-method))) (t (let ((main-effective-method (if (or before after) `(multiple-value-prog1 (progn ,(make-call-methods before) (call-method ,(first primary) ,(rest primary))) ,(make-call-methods (reverse after))) `(call-method ,(first primary) ,(rest primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,main-effective-method))) main-effective-method)))))) ;;; ;;; The STANDARD method combination type. This is coded by hand (rather than ;;; with define-method-combination) for bootstrapping and efficiency reasons. ;;; Note that the definition of the find-method-combination-method appears in ;;; the file defcombin.lisp, this is because EQL methods can't appear in the ;;; bootstrap. ;;; ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION ;;; classes has to appear here for this reason. This code must conform to ;;; the code in the file defcombin, look there for more details. ;;; (defun compute-effective-method (generic-function combin applicable-methods) (standard-compute-effective-method generic-function combin applicable-methods)) (defvar *invalid-method-error* #'(lambda (&rest args) (declare (ignore args)) (error "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ of a method combination function (inside the body of~%~ DEFINE-METHOD-COMBINATION or a method on the generic~%~ function COMPUTE-EFFECTIVE-METHOD)."))) (defvar *method-combination-error* #'(lambda (&rest args) (declare (ignore args)) (error "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ of a method combination function (inside the body of~%~ DEFINE-METHOD-COMBINATION or a method on the generic~%~ function COMPUTE-EFFECTIVE-METHOD)."))) ;(defmethod compute-effective-method :around ;issue with magic ; ((generic-function generic-function) ;generic functions ; (method-combination method-combination) ; applicable-methods) ; (declare (ignore applicable-methods)) ; (flet ((real-invalid-method-error (method format-string &rest args) ; (declare (ignore method)) ; (apply #'error format-string args)) ; (real-method-combination-error (format-string &rest args) ; (apply #'error format-string args))) ; (let ((*invalid-method-error* #'real-invalid-method-error) ; (*method-combination-error* #'real-method-combination-error)) ; (call-next-method)))) (defun invalid-method-error (&rest args) (declare (arglist method format-string &rest format-arguments)) (apply *invalid-method-error* args)) (defun method-combination-error (&rest args) (declare (arglist format-string &rest format-arguments)) (apply *method-combination-error* args)) ;This definition appears in defcombin.lisp. ; ;(defmethod find-method-combination ((generic-function generic-function) ; (type (eql 'standard)) ; options) ; (when options ; (method-combination-error ; "The method combination type STANDARD accepts no options.")) ; *standard-method-combination*) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_fin.lisp0000644000000000000000000000013114555557372015273 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_fin.lisp0000644000175000017500000021123214555557372014673 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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-2 () ;; (let (dummy) ;; (lambda (&rest args) ;; (declare (ignore args)) ;; (called-fin-without-function) ;; (values-list (make-dummy-list (setq dummy (make-dummy-var))))))) ;; (defun allocate-funcallable-instance-1 () ;; (let ((fin (allocate-funcallable-instance-2)) ;; (env (make-list funcallable-instance-closure-size :initial-element nil))) ;; (si::set-function-environment fin env) ;; (c::set-d-tt 1 fin) ;; 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) ;; ;; (typecase x (generic-function t))) ;; (defun tpf (x) (si::lit :fixnum "fto(" (:object x) ")")) ;; (declaim (inline tpf)) ;; (defun funcallable-instance-p (x) ;; (let ((y (load-time-value (tpf (allocate-funcallable-instance-1))))) ;; (= (tpf x) y))) ;; (declaim (inline funcallable-instance-p)) ;; ;; (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)) ((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)))) (defun make-trampoline (function) (declare (optimize (speed 3) (safety 0))) (lambda (&rest args) (declare (:dynamic-extent args)) (apply function args))) ;; #+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_new(make_turbo_trampoline_internal,Cnil,vs_head,Cnil); ;; return vs_pop;} ;; #endif ;; vs_head=make_cclosure_new(make_trampoline_internal,Cnil,vs_head,Cnil); ;; return vs_pop; ;; } ;; static void ;; make_trampoline_internal(base0) ;; object *base0; ;; {super_funcall_no_event(base0[0]->c.c_car);} ;; static void ;; make_turbo_trampoline_internal(base0) ;; object *base0; ;; { object function=base0[0]->c.c_car; ;; (*function->cc.cc_self)(function->cc.cc_turbo); ;; } ;; ") ;; (defentry make-trampoline (object) (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))) ;; (si::set-function-environment 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.7.1/pcl/PaxHeaders/gcl_pcl_compat.lisp0000644000000000000000000000013114542551763015774 xustar0030 mtime=1703597043.364022997 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_compat.lisp0000644000175000017500000000220314542551763015370 0ustar00cammcamm;;;-*-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.7.1/pcl/PaxHeaders/gcl_pcl_slots.lisp0000644000000000000000000000013114735634413015653 xustar0030 mtime=1735866635.768285238 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_slots.lisp0000644000175000017500000003407514735634413015263 0ustar00cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 wrapper-fetcher ((class standard-class)) 'std-instance-wrapper) (defmethod slots-fetcher ((class standard-class)) 'std-instance-slots) (defmethod raw-instance-allocator ((class standard-class)) 'allocate-standard-instance) ;;; ;;; These four functions work on std-instances and fsc-instances. These are ;;; instances for which it is possible to change the wrapper and the slots. ;;; ;;; For these kinds of instances, most specified methods from the instance ;;; structure protocol are promoted to the implementation-specific class ;;; std-class. Many of these methods call these four functions. ;;; (defun set-wrapper (inst new) (cond ((std-instance-p inst) #+new-kcl-wrapper (set-structure-def inst new) #-new-kcl-wrapper (setf (std-instance-wrapper inst) new)) ((fsc-instance-p inst) (setf (fsc-instance-wrapper inst) new)) (t (error "What kind of instance is this?")))) #+ignore ; can't do this when using #+new-kcl-wrapper (defun set-slots (inst new) (cond ((std-instance-p inst) (setf (std-instance-slots inst) new)) ((fsc-instance-p inst) (setf (fsc-instance-slots inst) new)) (t (error "What kind of instance is this?")))) (defun swap-wrappers-and-slots (i1 i2) (without-interrupts (cond ((std-instance-p i1) #+new-kcl-wrapper (swap-structure-contents i1 i2) #-new-kcl-wrapper (let ((w1 (std-instance-wrapper i1)) (s1 (std-instance-slots i1))) (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) (setf (std-instance-slots i1) (std-instance-slots i2)) (setf (std-instance-wrapper i2) w1) (setf (std-instance-slots i2) s1))) ((fsc-instance-p i1) (let ((w1 (fsc-instance-wrapper i1)) (s1 (fsc-instance-slots i1))) (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) (setf (fsc-instance-wrapper i2) w1) (setf (fsc-instance-slots i2) s1))) (t (error "What kind of instance is this?"))))) (defun get-class-slot-value-1 (object wrapper slot-name) (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) (if (null entry) (slot-missing (wrapper-class wrapper) object slot-name 'slot-value) (if (eq (cdr entry) *slot-unbound*) (values (slot-unbound (wrapper-class wrapper) object slot-name)) (cdr entry))))) (defun set-class-slot-value-1 (new-value object wrapper slot-name) (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) (if (null entry) (slot-missing (wrapper-class wrapper) object slot-name 'setf new-value) (setf (cdr entry) new-value)))) (defmethod class-slot-value ((class std-class) slot-name) (let ((wrapper (class-wrapper class)) (prototype (class-prototype class))) (get-class-slot-value-1 prototype wrapper slot-name))) (defmethod (setf class-slot-value) (nv (class std-class) slot-name) (let ((wrapper (class-wrapper class)) (prototype (class-prototype class))) (set-class-slot-value-1 nv prototype wrapper slot-name))) (defun find-slot-definition (class slot-name) (dolist (slot (class-slots class) nil) (when (eql slot-name (slot-definition-name slot)) (return slot)))) (defun slot-value (object slot-name) (let* ((class (class-of object)) (slot-definition (find-slot-definition class slot-name))) (values (if (null slot-definition) (slot-missing class object slot-name 'slot-value) (slot-value-using-class class object slot-definition))))) (setf (gdefinition 'slot-value-normal) #'slot-value) (define-compiler-macro slot-value (object-form slot-name-form) (if (and (constantp slot-name-form) (let ((slot-name (eval slot-name-form))) (and (symbolp slot-name) (symbol-package slot-name)))) `(values (accessor-slot-value ,object-form ,slot-name-form)) `(slot-value-normal ,object-form ,slot-name-form))) (defun set-slot-value (object slot-name new-value) (let* ((class (class-of object)) (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) (slot-missing class object slot-name 'setf new-value) (setf (slot-value-using-class class object slot-definition) new-value)) new-value)) (setf (gdefinition 'set-slot-value-normal) #'set-slot-value) (define-compiler-macro set-slot-value (object-form slot-name-form new-value-form) (if (and (constantp slot-name-form) (let ((slot-name (eval slot-name-form))) (and (symbolp slot-name) (symbol-package slot-name)))) `(values (accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form)) `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form))) ;(defconstant *optimize-slot-boundp* nil) (defun slot-boundp (object slot-name) (let* ((class (class-of object)) (slot-definition (find-slot-definition class slot-name))) (values (if (null slot-definition) (slot-missing class object slot-name 'slot-boundp) (slot-boundp-using-class class object slot-definition))))) (setf (gdefinition 'slot-boundp-normal) #'slot-boundp) (define-compiler-macro slot-boundp (object-form slot-name-form) (if (and (constantp slot-name-form) (let ((slot-name (eval slot-name-form))) (and (symbolp slot-name) (symbol-package slot-name)))) `(values (accessor-slot-boundp ,object-form ,slot-name-form)) `(slot-boundp-normal ,object-form ,slot-name-form))) (defun slot-makunbound (object slot-name) (let* ((class (class-of object)) (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) (slot-missing class object slot-name 'slot-makunbound) (slot-makunbound-using-class class object slot-definition)) object)) (defun slot-exists-p (object slot-name) (let ((class (class-of object))) (not (null (find-slot-definition class slot-name))))) ;;; ;;; This isn't documented, but is used within PCL in a number of print ;;; object methods (see named-object-print-function). ;;; (defun slot-value-or-default (object slot-name &optional (default "unbound")) (if (slot-boundp object slot-name) (slot-value object slot-name) default)) ;;; ;;; ;;; (defun standard-instance-access (instance location) (check-type instance (satisfies std-instance-p)) (%instance-ref (std-instance-slots instance) location)) (defun funcallable-standard-instance-access (instance location) (%instance-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) (object standard-object) (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (cond ((std-instance-p object) (unless (eq 't (wrapper-state (std-instance-wrapper object))) (check-wrapper-validity object)) (%instance-ref (std-instance-slots object) location)) ((fsc-instance-p object) (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) (check-wrapper-validity object)) (%instance-ref (fsc-instance-slots object) location)) (t (error "What kind of instance is this?")))) (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*) (values (slot-unbound class object (slot-definition-name slotd))) value))) (defmethod (setf slot-value-using-class) (new-value (class std-class) (object standard-object) (slotd standard-effective-slot-definition)) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) (unless (eq 't (wrapper-state (std-instance-wrapper object))) (check-wrapper-validity object)) (setf (%instance-ref (std-instance-slots object) location) new-value)) ((fsc-instance-p object) (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) (check-wrapper-validity object)) (setf (%instance-ref (fsc-instance-slots object) location) new-value)) (t (error "What kind of instance is this?")))) (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 std-class) (object standard-object) (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (cond ((std-instance-p object) (unless (eq 't (wrapper-state (std-instance-wrapper object))) (check-wrapper-validity object)) (%instance-ref (std-instance-slots object) location)) ((fsc-instance-p object) (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) (check-wrapper-validity object)) (%instance-ref (fsc-instance-slots object) location)) (t (error "What kind of instance is this?")))) (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 slot-makunbound-using-class ((class std-class) (object standard-object) (slotd standard-effective-slot-definition)) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) (unless (eq 't (wrapper-state (std-instance-wrapper object))) (check-wrapper-validity object)) (setf (%instance-ref (std-instance-slots object) location) *slot-unbound*)) ((fsc-instance-p object) (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) (check-wrapper-validity object)) (setf (%instance-ref (fsc-instance-slots object) location) *slot-unbound*)) (t (error "What kind of instance is this?")))) (cons (setf (cdr location) *slot-unbound*)) (t (error "The slot ~s has neither :instance nor :class allocation, ~@ so it can't be written by the default ~s method." slotd 'slot-makunbound-using-class)))) nil) (defmethod slot-value-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) (let* ((function (slot-definition-internal-reader-function slotd)) (value (funcall function object))) #+cmu (declare (type function function)) (if (eq value *slot-unbound*) (values (slot-unbound class object (slot-definition-name slotd))) value))) (defmethod (setf slot-value-using-class) (new-value (class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) (let ((function (slot-definition-internal-writer-function slotd))) #+cmu (declare (type function function)) (funcall function new-value object))) (defmethod slot-boundp-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) #-new-kcl-wrapper t #+new-kcl-wrapper (let* ((function (slot-definition-internal-reader-function slotd)) (value (funcall function object))) #+cmu (declare (type function function)) (not (eq value *slot-unbound*)))) (defmethod slot-makunbound-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) (error "Structure slots can't be unbound")) (defmethod slot-missing ((class t) instance slot-name operation &optional new-value) (error "When attempting to ~A,~%the slot ~S is missing from the object ~S." (ecase operation (slot-value "read the slot's value (slot-value)") (setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value)) (slot-boundp "test to see if slot is bound (slot-boundp)") (slot-makunbound "make the slot unbound (slot-makunbound)")) slot-name instance)) (defmethod slot-unbound ((class t) instance slot-name) (error 'unbound-slot :name slot-name :instance instance)) (defun slot-unbound-internal (instance position) (values (slot-unbound (class-of instance) instance (etypecase position (fixnum (nth position (wrapper-instance-slots-layout (wrapper-of instance)))) (cons (car position)))))) (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-standard-instance (class-wrapper class))) (defmethod allocate-instance ((class structure-class) &rest initargs) (declare (ignore initargs)) #-new-kcl-wrapper (let ((constructor (class-defstruct-constructor class))) (if constructor (funcall constructor) (error "Can't allocate an instance of class ~S" (class-name class)))) #+new-kcl-wrapper (allocate-standard-instance (class-wrapper class))) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_pkg.lisp0000644000000000000000000000013114720126436015263 xustar0030 mtime=1732291870.806088031 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_pkg.lisp0000644000175000017500000003042214720126436014663 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 :user) ;;; From defsys.lisp (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 :cstruct) ':pcl) (make-package ':pcl :use '(:walker :iterate :lisp))) (import 'si::(clines defentry defcfun object void int double non-negative-fixnum macro memq seqind structurep structure-def structure-ref std-instance funcallable-std-instance) :pcl) (import 'si::(macro) :walker) (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 :walker) (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 )) (in-package :iterate) (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*)) (in-package :pcl) (defvar *the-pcl-package* (find-package :pcl)) (defun load-truename (&optional errorp) (declare (ignore errorp)) *load-pathname*) ;;; ;;; Some CommonLisps have more symbols in the Lisp package than the ones that ;;; are explicitly specified in CLtL. This causes trouble. Any Lisp that has ;;; extra symbols in the Lisp package should shadow those symbols in the PCL ;;; package. ;;; #+TI (shadow '(string-append once-only destructuring-bind memq assq delq neq true false without-interrupts defmethod) *the-pcl-package*) #+CMU (shadow '(destructuring-bind) *the-pcl-package*) #+cmu17 (shadow '(find-class class-name class-of class built-in-class structure-class standard-class) *the-pcl-package*) #+GCLisp (shadow '(string-append memq assq delq neq make-instance) *the-pcl-package*) (defun use-package-pcl (&optional (*package* *package*)) (shadowing-import (let ((*package* *the-pcl-package*)) (mapcar #'intern #+cmu17 '("FIND-CLASS" "CLASS-NAME" "CLASS-OF" "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS" "STANDARD-CLASS") #+TI '("DEFMETHOD") #+GCLisp '("MAKE-INSTANCE") #-(or cmu17 TI GCLisp) '()))) (use-package *the-pcl-package*)) #+Genera (shadowing-import '(zl:arglist zwei:indentation) *the-pcl-package*) #+Lucid (import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist system:structurep system:structure-type system:structure-length) *the-pcl-package*) #+lucid (#-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)) #+kcl (progn (import '(si:structurep si:structure-def si:structure-ref si::real-documentation)) ;(shadow 'lisp:dotimes) ) #+kcl (in-package "SI") #+kcl (export '(%structure-name %compiled-function-name %set-compiled-function-name %instance-ref %set-instance-ref)) #+kcl (in-package :pcl) #+cmu (shadow 'lisp:dotimes) #+cmu (import '(kernel:funcallable-instance-p) *the-pcl-package*) #-gcl(shadow 'documentation) ;;; ;;; These come from the index pages of 88-002R. ;;; ;;; (eval-when (compile load eval) (defvar *exports* '(add-method built-in-class call-method call-next-method change-class class-name class-of compute-applicable-methods defclass defgeneric define-method-combination defmethod ensure-generic-function find-class find-method function-keywords generic-flet generic-labels initialize-instance invalid-method-error make-instance make-load-form make-load-form-saving-slots describe-object make-instances-obsolete method-combination-error method-qualifiers next-method-p no-applicable-method no-next-method print-object reinitialize-instance remove-method shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound slot-value standard standard-class standard-generic-function standard-method standard-object structure-class #-cmu17 symbol-macrolet update-instance-for-different-class update-instance-for-redefined-class with-accessors with-added-methods with-slots )) );eval-when #-(or KCL IBCL CMU) (export *exports* *the-pcl-package*) #+CMU (export '#.*exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *exports*) (list *the-pcl-package*)) (eval-when (compile load eval) (defvar *class-exports* '(standard-instance funcallable-standard-instance generic-function standard-generic-function method standard-method standard-accessor-method standard-reader-method standard-writer-method method-combination slot-definition direct-slot-definition effective-slot-definition standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition specializer eql-specializer built-in-class forward-referenced-class standard-class funcallable-standard-class)) (defvar *chapter-6-exports* '(add-dependent add-direct-method add-direct-subclass add-method allocate-instance class-default-initargs class-direct-default-initargs class-direct-slots class-direct-subclasses class-direct-superclasses class-finalized-p class-precedence-list class-prototype class-slots compute-applicable-methods compute-applicable-methods-using-classes compute-class-precedence-list compute-discriminating-function compute-effective-method compute-effective-slot-definition compute-slots direct-slot-definition-class effective-slot-definition-class ensure-class ensure-class-using-class ensure-generic-function ensure-generic-function-using-class eql-specializer-instance extract-lambda-list extract-specializer-names finalize-inheritance find-method-combination funcallable-standard-instance-access generic-function-argument-precedence-order generic-function-declarations generic-function-lambda-list generic-function-method-class generic-function-method-combination generic-function-methods generic-function-name intern-eql-specializer make-instance make-method-lambda map-dependents method-function method-generic-function method-lambda-list method-specializers method-qualifiers accessor-method-slot-definition reader-method-class remove-dependent remove-direct-method remove-direct-subclass remove-method set-funcallable-instance-function slot-boundp-using-class slot-definition-allocation slot-definition-initargs slot-definition-initform slot-definition-initfunction slot-definition-location slot-definition-name slot-definition-readers slot-definition-writers slot-definition-type slot-makunbound-using-class slot-value-using-class specializer-direct-generic-function specializer-direct-methods standard-instance-access update-dependent validate-superclass writer-method-class )) );eval-when #-(or KCL IBCL) (export *class-exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *class-exports*) (list *the-pcl-package*)) #-(or KCL IBCL) (export *chapter-6-exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *chapter-6-exports*) (list *the-pcl-package*)) (defvar *slot-accessor-name-package* (or (find-package :slot-accessor-name) (make-package :slot-accessor-name :use '() :nicknames '(:s-a-n)))) #+kcl (when (get 'si::basic-wrapper 'si::s-data) (import (mapcar #'(lambda (s) (intern (symbol-name s) "SI")) '(:copy-structure-header :swap-structure-contents :set-structure-def :%instance-ref :%set-instance-ref :cache-number-vector :cache-number-vector-length :wrapper-cache-number-adds-ok :wrapper-cache-number-length :wrapper-cache-number-mask :wrapper-cache-number-vector-length :wrapper-layout :wrapper-cache-number-vector :wrapper-state :wrapper-class :wrapper-length)))) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_fsc.lisp0000644000000000000000000000013014542551763015263 xustar0029 mtime=1703597043.37202301 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_fsc.lisp0000644000175000017500000000667114542551763014675 0ustar00cammcamm;;;-*-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.7.1/pcl/PaxHeaders/gcl_pcl_fngen.lisp0000644000000000000000000000013114576354762015615 xustar0030 mtime=1710873074.790292859 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_fngen.lisp0000644000175000017500000001657514576354762015232 0ustar00cammcamm;;;-*-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) ;;; ;;; GET-FUNCTION is the main user interface to this code. It is like ;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by ;;; reducing the number of times that the compiler needs to be called. ;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants ;;; can use the same piece of compiled code. (For example, dispatch dfuns and ;;; combined method functions can often be shared, if they differ only ;;; by referring to different methods.) ;;; ;;; If GET-FUNCTION is called with a lambda expression only, it will return ;;; a corresponding function. The optional constant-converter argument ;;; can be a function which will be called to convert each constant appearing ;;; in the lambda to whatever value should appear in the function. ;;; ;;; There are three internal functions which operate on the lambda argument ;;; to GET-FUNCTION: ;;; compute-test converts the lambda into a key to be used for lookup, ;;; compute-code is used by get-new-function-generator-internal to ;;; generate the actual lambda to be compiled, and ;;; compute-constants is used to generate the argument list that is ;;; to be passed to the compiled function. ;;; ;;; Whether the returned function is actually compiled depends on whether ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of ;;; code was precompiled. ;;; (defun get-function (lambda &optional (test-converter #'default-test-converter) (code-converter #'default-code-converter) (constant-converter #'default-constant-converter)) (function-apply (get-function-generator lambda test-converter code-converter) (compute-constants lambda constant-converter))) (defun get-function1 (lambda &optional (test-converter #'default-test-converter) (code-converter #'default-code-converter) (constant-converter #'default-constant-converter)) (values (the function (get-function-generator lambda test-converter code-converter)) (compute-constants lambda constant-converter))) (defun default-constantp (form) (and (constantp form) (not (typep (eval form) '(or symbol fixnum))))) (defun default-test-converter (form) (if (default-constantp form) '.constant. form)) (defun default-code-converter (form) (if (default-constantp form) (let ((gensym (gensym))) (values gensym (list gensym))) form)) (defun default-constant-converter (form) (if (default-constantp form) (list (eval form)) nil)) ;;; ;;; *fgens* is a list of all the function generators we have so far. Each ;;; element is a FGEN structure as implemented below. Don't ever touch this ;;; list by hand, use STORE-FGEN. ;;; (defvar *fgens* ()) (defun store-fgen (fgen) (let ((old (lookup-fgen (fgen-test fgen)))) (if old (setf (svref old 2) (fgen-generator fgen) (svref old 4) (or (svref old 4) (fgen-system fgen))) (setq *fgens* (nconc *fgens* (list fgen)))))) (defun lookup-fgen (test) (find test (the list *fgens*) :key #'fgen-test :test #'equal)) (defun make-fgen (test gensyms generator generator-lambda system) (let ((new (make-array 6))) (setf (svref new 0) test (svref new 1) gensyms (svref new 2) generator (svref new 3) generator-lambda (svref new 4) system) new)) (defun fgen-test (fgen) (svref fgen 0)) (defun fgen-gensyms (fgen) (svref fgen 1)) (defun fgen-generator (fgen) (svref fgen 2)) (defun fgen-generator-lambda (fgen) (svref fgen 3)) (defun fgen-system (fgen) (svref fgen 4)) (defun get-function-generator (lambda test-converter code-converter) (let* ((test (compute-test lambda test-converter)) (fgen (lookup-fgen test))) (if fgen (fgen-generator fgen) (get-new-function-generator lambda test code-converter)))) (defun get-new-function-generator (lambda test code-converter) (multiple-value-bind (gensyms generator-lambda) (get-new-function-generator-internal lambda code-converter) (let* ((generator (compile-lambda generator-lambda)) (fgen (make-fgen test gensyms generator generator-lambda nil))) (store-fgen fgen) generator))) (defun get-new-function-generator-internal (lambda code-converter) (multiple-value-bind (code gensyms) (compute-code lambda code-converter) (values gensyms `(lambda ,gensyms (function ,code))))) (defun compute-test (lambda test-converter) (let ((walk-form-expand-macros-p t)) (walk-form lambda nil (lambda (f c e) (declare (ignore e)) (if (neq c :eval) f (let ((converted (funcall test-converter f))) (values converted (neq converted f)))))))) (defun compute-code (lambda code-converter) (let ((walk-form-expand-macros-p t) (gensyms ())) (values (walk-form lambda nil (lambda (f c e) (declare (ignore e)) (if (neq c :eval) f (multiple-value-bind (converted gens) (funcall code-converter f) (when gens (setq gensyms (append gensyms gens))) (values converted (neq converted f)))))) gensyms))) (defun compute-constants (lambda constant-converter) (let ((walk-form-expand-macros-p t) ; doesn't matter here. (collected ())) (walk-form lambda nil (lambda (f c e) (declare (ignore e)) (if (eq c :eval) (let ((consts (funcall constant-converter f))) (if consts (progn (setq collected (append collected consts)) (values f t)) f)) f))) collected)) ;;; ;;; ;;; (defmacro precompile-function-generators (&optional system) (let ((index -1)) `(progn ,@(let ((collected ())) (dolist (fgen *fgens* (nreverse collected)) (when (or (null (fgen-system fgen)) (eq (fgen-system fgen) system)) (when system (setf (svref fgen 4) system)) (push (make-top-level-form `(precompile-function-generators ,system ,(incf index)) '(load) `(load-function-generator ',(fgen-test fgen) ',(fgen-gensyms fgen) (function ,(fgen-generator-lambda fgen)) ',(fgen-generator-lambda fgen) ',system)) collected))))))) (defun load-function-generator (test gensyms generator generator-lambda system) (store-fgen (make-fgen test gensyms generator generator-lambda system))) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_fast_init.lisp0000644000000000000000000000013114741742560016467 xustar0030 mtime=1736951152.697218614 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_fast_init.lisp0000644000175000017500000011741514741742560016077 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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) allow-other-keys-p (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 ;; leftmost occurrence only ;; FIXME check that this is correct (if (and (not allow-other-keys-p) (eq keyword :allow-other-keys)) (progn (setq allow-other-keys-arg (pop initargs-tail)) (setq allow-other-keys-p t)) (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 (or (member key legal) (eq key :allow-other-keys)) (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-1 class initargs) initialize-instance-methods shared-initialize-methods)))) (defun default-initargs-1 (class initargs &aux (sym (si::sgen))) (append initargs (mapcan (lambda (x) (destructuring-bind (key form fun) x (when (eq (getf initargs key sym) sym) `(,key ,(if (constantp form) form `(funcall ,fun)))))) (class-default-initargs class)))) (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)) (reverse (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)))) (dolist (default default-initargs) (let* ((key (car default)) (function (cadr default))) (unless (member key nkeys) (add-forms `((funcall ,function)) initargs-form-list) (push key nkeys)))) (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) (it 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))))) (append it (do ((i (ldiff initargs it) (cddr i)) j)((not i) j) (push (cadr i) j) (push (car i) j))))) (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.7.1/pcl/PaxHeaders/gcl_pcl_defclass.lisp0000644000000000000000000000013114555557372016303 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_defclass.lisp0000644000175000017500000004110114555557372015677 0ustar00cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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)))))) (:documentation (unless (stringp (second option)) (error "~S is not a legal :documentation value" (second option))) `(:documentation ,(second option))) (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 (or (eq metaclass 'standard-class) (eq metaclass 'funcallable-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.7.1/pcl/PaxHeaders/gcl_pcl_braid.lisp0000644000000000000000000000013114555557372015600 xustar0030 mtime=1706483450.808392729 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_braid.lisp0000644000175000017500000007161214555557372015206 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 name 'function) #'cons ;;FIXME -- not necessary (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*) (unless (find-class (car e) nil) (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 (destructuring-bind (name supers subs cpl &optional 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 nil)))) (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) (unless (eq symbol 'std-instance) (if (structure-type-p symbol) (unless (eq find-structure-class symbol) (let ((find-structure-class symbol)) (when (fboundp 'ensure-class) (let ((res (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))))) (setf (class-defstruct-constructor res) (car (si::s-data-constructors (get symbol 'si::s-data)))) res)))) (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" "No matching method for the generic-function ~S,~@ when called with arguments ~S." generic-function args) (apply generic-function args)) (defmethod no-next-method ((generic-function standard-generic-function) (method standard-method) &rest args) (cerror "Try again." "No next method to ~S when calling generic function ~S with arguments ~S~%" method generic-function args) (apply generic-function args)) (defmethod no-primary-method ((generic-function standard-generic-function) &rest args) (cerror "Try again." "No primary method when calling generic function ~S with arguments ~S~%" generic-function args) (apply generic-function args)) (defmethod invalid-qualifiers ((gf generic-function) combin args methods) (if (null (cdr methods)) (error "~@" gf args (car methods) combin) (error "~@" gf args methods combin))) (defun %no-primary-method (gf args) (apply #'no-primary-method gf args)) (defun %invalid-qualifiers (gf combin args methods) (invalid-qualifiers gf combin args methods)) gcl-2.7.1/pcl/PaxHeaders/defsys.lisp0000644000000000000000000000013214776006046014322 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.306035098 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/defsys.lisp0000644000175000017500000011352614776006046013730 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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) (unless (find-package :walker) (make-package :walker :use '(:lisp))) (unless (find-package :iterate) (make-package :iterate :use '(:lisp :walker))) (unless (find-package :pcl) (make-package :pcl :use '(:lisp :walker :iterate))) (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))) (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. ;;; #-gcl(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 #+kcl 0 #-kcl 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 #+KCL KCL #+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") #+KCL ("lsp" . "o") #+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 (car system))) ;(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 (car system))) ; (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 nil) ; (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)) ; (port-directory (if port-dname ; (append ldir (list "impl" port-dname)) ; ldir)) (port-directory ldir) (port-device (if (null port-directory) nil (pathname-device port-directory))) (port-directory (pathname-directory directory)) (pathname (make-pathname :name (string-downcase (string name)) :type extension :device port-device :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 (car system))) ;(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 (car system))) ;(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. ;;; ;;; *** *** #-gcl(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)) #+gcl *load-pathname* #+(and akcl (not gcl)) si:*load-pathname* #+cmu17 *load-truename* #-(or Lispm excl Xerox (and dec vax common) LUCID akcl gcl cmu17) nil)) #-(or cmu Symbolics) (defvar *pcl-directory* (concatenate 'string si::*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.7.1/pcl/PaxHeaders/gcl_pcl_dfun.lisp0000644000000000000000000000013114733413552015440 xustar0030 mtime=1735268202.365570378 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_dfun.lisp0000644000175000017500000016303114733413552015043 0ustar00cammcamm;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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" (cons (car generator-entry) (caar args-entry)) (caddr args-entry))))) (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 ,@(let ((collected ())) (dolist (generator-entry *dfun-constructors* (nreverse collected)) (dolist (args-entry (cdr generator-entry)) (when (or (null (caddr args-entry)) (eq (caddr args-entry) system)) (when system (setf (caddr args-entry) system)) (push (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)))) collected)))))))) ;;; ;;; 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-caching-dfun (gf) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info gf) (declare (ignore nreq nkeys)) (when (and metatypes (not (null (car metatypes))) (dolist (mt metatypes nil) (unless (eq mt t) (return t)))) (get-dfun-constructor 'emit-caching 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)) (and (compute-applicable-methods-emf-std-p gf) (eq (generic-function-method-combination gf) *standard-method-combination*))) (notany #'(lambda (method) (or (and (eq *boot-state* 'complete) (or (some #'eql-specializer-p (method-specializers method)) (method-qualifiers 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))) (or (eq value default) (when boolean-values-p (not (member value '(t nil)))))))) 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 ((cdc (caching-dfun-cost gf))) (> cdc (dispatch-dfun-cost gf cdc)))))) ;; 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 (when caching-p (insure-caching-dfun gf)) (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) (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 'program-error :format-control "The function ~S requires at least ~D arguments" :format-arguments (list 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) (declare (fixnum i)) (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)) #+cmu(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)))) (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.7.1/pcl/PaxHeaders/gcl_pcl_methods.lisp0000644000000000000000000000013114555557372016162 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_methods.lisp0000644000175000017500000016674514555557372015604 0ustar00cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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) 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)) (when (generic-function-methods generic-function) (unless (eql (length specializers) (length (arg-info-metatypes (gf-arg-info generic-function)))) (error 'program-error :format-control "Specializer list ~S does not match generic function ~S" :format-arguments (list specializers generic-function)))) (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))))) (defmethod find-method ((generic-function standard-generic-function) qualifiers specializers &optional (errorp t)) (real-get-method generic-function qualifiers (parse-specializers specializers) errorp)) ;;; ;;; 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)) generic-function))) (defun real-remove-method (generic-function method) (if (neq generic-function (method-generic-function method)) generic-function ;; (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 float rational) ; direct subclasses of number (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 'program-error :format-control "The function ~S requires at least ~D arguments" :format-arguments (list (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) (declare (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 nil known-types))) (funcall methods-function contenders (let ((k-t (make-list nreq))) (dolist (index+type known-types k-t) (setf (nth (car index+type) k-t) (cdr index+type))))))) (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 nil)))) #+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)) (arglist (if function-p (make-dfun-lambda-list metatypes applyp) (make-fast-method-call-lambda-list metatypes applyp)))) (multiple-value-bind (cfunction constants) (get-function1 `(lambda ,arglist ,@(unless function-p `((declare (ignore .pv-cell. .next-method-call.)))) (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.7.1/pcl/PaxHeaders/package.lisp0000644000000000000000000000013114555557372014427 xustar0030 mtime=1706483450.816392726 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/package.lisp0000644000175000017500000000126414555557372014031 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (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 :s) :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) (defstruct slot-object) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_defcombin.lisp0000644000000000000000000000013114555557372016445 xustar0030 mtime=1706483450.812392727 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_defcombin.lisp0000644000175000017500000004615114555557372016053 0ustar00cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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) ;;; ;;; DEFINE-METHOD-COMBINATION ;;; (defmacro define-method-combination (&whole form &rest args) (declare (ignore args)) (if (and (cddr form) (listp (caddr form))) (expand-long-defcombin form) (expand-short-defcombin form))) ;;; ;;; Implementation of INVALID-METHOD-ERROR and METHOD-COMBINATION-ERROR ;;; ;;; See combin.lisp for rest of the implementation. This method is ;;; defined here because compute-effective-method is still a function ;;; in combin.lisp. ;;; (defmethod compute-effective-method :around ((generic-function generic-function) (method-combination method-combination) applicable-methods) (declare (ignorable applicable-methods)) (flet ((real-invalid-method-error (method format-string &rest args) (declare (ignore method)) (apply #'error format-string args)) (real-method-combination-error (format-string &rest args) (apply #'error format-string args))) (let ((*invalid-method-error* #'real-invalid-method-error) (*method-combination-error* #'real-method-combination-error)) (call-next-method)))) ;;; ;;; STANDARD method combination ;;; ;;; The STANDARD method combination type is implemented directly by the class ;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does ;;; standard method combination directly and is defined by hand in the file ;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this ;;; file for bootstrapping reasons. ;;; ;;; A commented out copy of this definition appears in combin.lisp. ;;; If you change this definition here, be sure to change it there ;;; also. ;;; (defmethod find-method-combination ((generic-function generic-function) (type (eql 'standard)) options) (when options (method-combination-error "The method combination type STANDARD accepts no options.")) *standard-method-combination*) ;;; ;;; short method combinations ;;; ;;; Short method combinations all follow the same rule for computing the ;;; effective method. So, we just implement that rule once. Each short ;;; method combination object just reads the parameters out of the object ;;; and runs the same rule. ;;; ;;; (defclass short-method-combination (standard-method-combination) ((operator :reader short-combination-operator :initarg :operator) (identity-with-one-argument :reader short-combination-identity-with-one-argument :initarg :identity-with-one-argument)) (:predicate-name short-method-combination-p)) (defun expand-short-defcombin (whole) (let* ((type (cadr whole)) (documentation (getf (cddr whole) :documentation "")) (identity-with-one-arg (getf (cddr whole) :identity-with-one-argument nil)) (operator (getf (cddr whole) :operator type))) (make-top-level-form `(define-method-combination ,type) '(load eval) `(load-short-defcombin ',type ',operator ',identity-with-one-arg ',documentation)))) (defun load-short-defcombin (type operator ioa doc) (let* ((truename (load-truename)) (specializers (list (find-class 'generic-function) (intern-eql-specializer type) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) (new-method nil)) (setq new-method (make-instance 'standard-method :qualifiers () :specializers specializers :lambda-list '(generic-function type options) :function (lambda (args nms &rest cm-args) (declare (ignore nms cm-args)) (apply (lambda (gf type options) (declare (ignore gf)) (make-short-method-combination type options operator ioa new-method doc)) args)) :definition-source `((define-method-combination ,type) ,truename))) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) type)) (defun make-short-method-combination (type options operator ioa method doc) (cond ((null options) (setq options '(:most-specific-first))) ((equal options '(:most-specific-first))) ((equal options '(:most-specific-last))) (t (method-combination-error "Illegal options to a short method combination type.~%~ The method combination type ~S accepts one option which~%~ must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." type))) (make-instance 'short-method-combination :type type :options options :operator operator :identity-with-one-argument ioa :definition-source method :documentation doc)) (defmethod compute-effective-method ((generic-function generic-function) (combin short-method-combination) applicable-methods) (let ((type (method-combination-type combin)) (operator (short-combination-operator combin)) (ioa (short-combination-identity-with-one-argument combin)) (order (car (method-combination-options combin))) (around ()) (primary ()) (invalid ())) (dolist (m applicable-methods) (let ((qualifiers (method-qualifiers m))) (labels ((lose (method why) (invalid-method-error method "The method ~S ~A.~%~ The method combination type ~S was defined with the~%~ short form of DEFINE-METHOD-COMBINATION and so requires~%~ all methods have either the single qualifier ~S or the~%~ single qualifier :AROUND." method why type type)) (invalid-method (method why) (if *in-precompute-effective-methods-p* (push method invalid) (lose method why)))) (cond ((null qualifiers) (invalid-method m "has no qualifiers")) ((cdr qualifiers) (invalid-method m "has more than one qualifier")) ((eq (car qualifiers) :around) (push m around)) ((eq (car qualifiers) type) (push m primary)) (t (invalid-method m "has an illegal qualifier")))))) (setq around (nreverse around)) (unless (eq order :most-specific-last) (setq primary (nreverse primary))) (let ((main-method (if (and (null (cdr primary)) (not (null ioa))) `(call-method ,(car primary) ()) `(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) primary))))) (cond (invalid `(%invalid-qualifiers ',generic-function ',combin .args. ',invalid)) ((null primary) `(%no-primary-method ',generic-function .args.)) ((null around) main-method) (t `(call-method ,(car around) (,@(cdr around) (make-method ,main-method)))))))) ;;; ;;; long method combinations ;;; ;;; (defun expand-long-defcombin (form) (let ((type (cadr form)) (lambda-list (caddr form)) (method-group-specifiers (cadddr form)) (body (cddddr form)) (arguments-option ()) (gf-var nil)) (when (and (consp (car body)) (eq (caar body) :arguments)) (setq arguments-option (cdr (pop body)))) (when (and (consp (car body)) (eq (caar body) :generic-function)) (setq gf-var (cadr (pop body)))) (multiple-value-bind (documentation function) (make-long-method-combination-function type lambda-list method-group-specifiers arguments-option gf-var body) (make-top-level-form `(define-method-combination ,type) '(load eval) `(load-long-defcombin ',type ',documentation #',function ',arguments-option))))) (defvar *long-method-combination-functions* (make-hash-table :test #'eq)) (defun load-long-defcombin (type doc function arguments-lambda-list) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) (new-method (make-instance 'standard-method :qualifiers () :specializers specializers :lambda-list '(generic-function type options) :function (lambda (args nms &rest cm-args) (declare (ignore nms cm-args)) (apply (lambda (generic-function type options) (declare (ignore generic-function)) (make-instance 'long-method-combination :type type :options options :function function :arguments-lambda-list arguments-lambda-list :documentation doc)) args)) :definition-source `((define-method-combination ,type) ,(load-truename))))) (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) type)) (defmethod compute-effective-method ((generic-function generic-function) (combin long-method-combination) applicable-methods) (funcall (gethash (method-combination-type combin) *long-method-combination-functions*) generic-function combin applicable-methods)) ;;; ;;; ;;; (defun make-long-method-combination-function (type ll method-group-specifiers arguments-option gf-var body) (declare (ignore type)) (multiple-value-bind (documentation declarations real-body) (extract-declarations body) (let ((wrapped-body (wrap-method-group-specifier-bindings method-group-specifiers declarations real-body))) (when gf-var (push `(,gf-var .generic-function.) (cadr wrapped-body))) (when arguments-option (setq wrapped-body (deal-with-arguments-option wrapped-body arguments-option))) (when ll (setq wrapped-body `(apply (lambda ,ll ,wrapped-body) (method-combination-options .method-combination.)))) (values documentation `(lambda (.generic-function. .method-combination. .applicable-methods.) (declare (ignorable .generic-function. .method-combination. .applicable-methods.)) (block .long-method-combination-function. ,wrapped-body)))))) ;; ;; parse-method-group-specifiers parse the method-group-specifiers ;; (defun wrap-method-group-specifier-bindings (method-group-specifiers declarations real-body) (let ((names ()) (specializer-caches ()) (cond-clauses ()) (required-checks ()) (order-cleanups ())) (dolist (method-group-specifier method-group-specifiers) (multiple-value-bind (name tests description order required) (parse-method-group-specifier method-group-specifier) (declare (ignore description)) (let ((specializer-cache (gensym))) (push name names) (push specializer-cache specializer-caches) (push `((or ,@tests) (if (and (equal ,specializer-cache .specializers.) (not (null .specializers.))) (return-from .long-method-combination-function. '(error "More than one method of type ~S ~ with the same specializers." ',name)) (setq ,specializer-cache .specializers.)) (push .method. ,name)) cond-clauses) (when required (push `(when (null ,name) (return-from .long-method-combination-function. '(error "No ~S methods." ',name))) required-checks)) (loop (unless (and (constantp order) (neq order (setq order (eval order)))) (return t))) (push (cond ((eq order :most-specific-first) `(setq ,name (nreverse ,name))) ((eq order :most-specific-last) ()) (t `(ecase ,order (:most-specific-first (setq ,name (nreverse ,name))) (:most-specific-last)))) order-cleanups)))) `(let (,@(nreverse names) ,@(nreverse specializer-caches)) ,@declarations (dolist (.method. .applicable-methods.) (let ((.qualifiers. (method-qualifiers .method.)) (.specializers. (method-specializers .method.))) (declare (ignorable .qualifiers. .specializers.)) (cond ,@(nreverse cond-clauses)))) ,@(nreverse required-checks) ,@(nreverse order-cleanups) ,@real-body))) (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) (loop with name = (pop method-group-specifier) for rest on method-group-specifier for pattern = (car rest) until (memq pattern '(:description :order :required)) collect pattern into patterns collect (parse-qualifier-pattern name pattern) into tests finally (return (values name tests (getf rest :description (make-default-method-group-description (nreverse patterns))) (getf rest :order :most-specific-first) (getf rest :required nil))))) (defun parse-qualifier-pattern (name pattern) (cond ((eq pattern '()) `(null .qualifiers.)) ((eq pattern '*) t) ((symbolp pattern) `(,pattern .qualifiers.)) ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) (t (error "In the method group specifier ~S,~%~ ~S isn't a valid qualifier pattern." name pattern)))) (defun qualifier-check-runtime (pattern qualifiers) (loop (cond ((and (null pattern) (null qualifiers)) (return t)) ((eq pattern '*) (return t)) ((and pattern qualifiers (let ((element (car pattern))) (or (eq element (car qualifiers)) (eq element '*)))) (pop pattern) (pop qualifiers)) (t (return nil))))) (defun make-default-method-group-description (patterns) (if (cdr patterns) (format nil "methods matching one of the patterns: ~{~S, ~} ~S" (butlast patterns) (car (last patterns))) (format nil "methods matching the pattern: ~S" (car patterns)))) ;;; ;;; Return a form that deals with the :ARGUMENTS lambda-list of a long ;;; method combination. WRAPPED-BODY is the body of the method ;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments ;;; lambda-list of the method combination. ;;; (defun deal-with-arguments-option (wrapped-body arguments-lambda-list) (let ((intercept-rebindings (loop for arg in arguments-lambda-list unless (memq arg lambda-list-keywords) collect `(,arg ',arg))) (nreq 0) (nopt 0) whole) ;; ;; Count the number of required and optional parameters in ;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the ;; name of a &WHOLE parameter, if any. (loop with state = 'required for arg in arguments-lambda-list do (if (memq arg lambda-list-keywords) (setq state arg) (case state (required (incf nreq)) (&optional (incf nopt)) (&whole (setq whole arg state 'required))))) ;; ;; This assumes that the WRAPPED-BODY is a let/let* form, and it ;; injects let-bindings of the form (ARG 'SYM) for all variables ;; of the argument-lambda-list; SYM is a gensym. ; (assert (memq (first wrapped-body) '(let let*))) (unless (memq (first wrapped-body) '(let let*)) (error 'type-error :datum (first wrapped-body) :expected-type '(member let let*))) (setf (second wrapped-body) (append intercept-rebindings (second wrapped-body))) ;; ;; Be sure to fill out the args lambda list so that it can be too ;; short if it wants to. (unless (or (memq '&rest arguments-lambda-list) (memq '&allow-other-keys arguments-lambda-list)) (let ((aux (memq '&aux arguments-lambda-list))) (setq arguments-lambda-list (append (ldiff arguments-lambda-list aux) (if (memq '&key arguments-lambda-list) '(&allow-other-keys) '(&rest .ignore.)) aux)))) ;; ;; .GENERIC-FUNCTION. is bound to the generic function in the ;; method combination function, and .GF-ARGS* is bound to the ;; generic function arguments in effective method functions ;; created for generic functions having a method combination that ;; uses :ARGUMENTS. ;; ;; The DESTRUCTURING-BIND binds the parameters of the ;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments. ;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the ;; generic function's lambda list, which is only known at run time, ;; this destructuring has to be done on a slighly modified list of ;; actual arguments, from which values might be stripped or added. ;; ;; Using one of the variable names in the body inserts a symbol ;; into the effective method, and running the effective method ;; produces the value of actual argument that is bound to the ;; symbol. `(let ((inner-result. ,wrapped-body) (gf-lambda-list (generic-function-lambda-list .generic-function.))) `(destructuring-bind ,',arguments-lambda-list (frob-combined-method-args .gf-args. ',gf-lambda-list ,',nreq ,',nopt) ,,(when (memq '.ignore. arguments-lambda-list) ''(declare (ignore .ignore.))) ;; If there is a &WHOLE in the arguments-lambda-list, let ;; it result in the actual arguments of the generic-function ;; not the frobbed list. ,,(when whole ``(setq ,',whole .gf-args.)) ,inner-result.)))) ;;; ;;; Partition VALUES into three sections required, optional, and the ;;; rest, according to required, optional, and other parameters in ;;; LAMBDA-LIST. Make the required and optional sections NREQ and ;;; NOPT elements long by discarding values or adding NILs. Value is ;;; the concatenated list of required and optional sections, and what ;;; is left as rest from VALUES. ;;; (defun frob-combined-method-args (values lambda-list nreq nopt) (loop with section = 'required for arg in lambda-list if (memq arg lambda-list-keywords) do (setq section arg) (unless (eq section '&optional) (loop-finish)) else if (eq section 'required) count t into nr and collect (pop values) into required else if (eq section '&optional) count t into no and collect (pop values) into optional finally (flet ((frob (list n m) (cond ((> n m) (butlast list (- n m))) ((< n m) (nconc list (make-list (- m n)))) (t list)))) (return (nconc (frob required nr nreq) (frob optional no nopt) values))))) (dolist (l '(find-class classp class-precedence-list class-name class-of class-direct-subclasses)) (setf (symbol-function (find-symbol (symbol-name l) 'si)) (symbol-function l))) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_ctypes.lisp0000644000000000000000000000013114542551763016020 xustar0030 mtime=1703597043.364022997 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_ctypes.lisp0000644000175000017500000000360614542551763015424 0ustar00cammcamm;;;-*-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 built-in method combination types as taken from page 1-31 of 88-002R. ;;; Note that the STANDARD method combination type is defined by hand in the ;;; file combin.lisp. ;;; (define-method-combination + :identity-with-one-argument t) (define-method-combination and :identity-with-one-argument t) (define-method-combination append :identity-with-one-argument nil) (define-method-combination list :identity-with-one-argument nil) (define-method-combination max :identity-with-one-argument t) (define-method-combination min :identity-with-one-argument t) (define-method-combination nconc :identity-with-one-argument t) (define-method-combination or :identity-with-one-argument t) (define-method-combination progn :identity-with-one-argument t) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_boot.lisp0000644000000000000000000000013114733564552015456 xustar0030 mtime=1735321962.631572278 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_boot.lisp0000644000175000017500000024753514733564552015075 0ustar00cammcamm;;;-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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 CommonLoops evaluator is meta-circular. Most of the code in PCL is methods on generic functions, including most of the code that actually implements generic functions and method lookup. So, we have a classic bootstrapping problem. The solution to this is to first get a cheap implementation of generic functions running, these are called early generic functions. These early generic functions and the corresponding early methods and early method lookup are used to get enough of the system running that it is possible to create real generic functions and methods and implement real method lookup. At that point (done in the file FIXUP) the function fix-early-generic-functions is called to convert all the early generic functions to real generic functions. The cheap generic functions are built using the same funcallable-instance objects real generic-functions are made out of. This means that as PCL is being bootstrapped, the cheap generic function objects which are being created are the same objects which will later be real generic functions. This is good because: - we don't cons garbage structure - we can keep pointers to the cheap generic function objects during booting because those pointers will still point to the right object after the generic functions are all fixed up This file defines the defmethod macro and the mechanism used to expand it. This includes the mechanism for processing the body of a method. defmethod basically expands into a call to load-defmethod, which basically calls add-method to add the method to the generic-function. These expansions can be loaded either during bootstrapping or when PCL is fully up and running. An important effect of this structure is it means we can compile files with defmethod forms in them in a completely running PCL, but then load those files back in during bootstrapping. This makes development easier. It also means there is only one set of code for processing defmethod. Bootstrapping works by being sure to have load-method be careful to call only primitives which work during bootstrapping. |# (proclaim '(notinline make-a-method add-named-method ensure-generic-function-using-class add-method remove-method )) (defvar *early-functions* '((make-a-method early-make-a-method real-make-a-method) (add-named-method early-add-named-method real-add-named-method) )) ;;; ;;; For each of the early functions, arrange to have it point to its early ;;; definition. Do this in a way that makes sure that if we redefine one ;;; of the early definitions the redefinition will take effect. This makes ;;; development easier. ;;; ;;; The function which generates the redirection closure is pulled out into ;;; a separate piece of code because of a bug in ExCL which causes this not ;;; to work if it is inlined. ;;; (eval-when (load eval) (defun redirect-early-function-internal (real early);(print (list 'baz real early)) (setf (gdefinition real) (set-function-name (lambda (&rest args) (apply (the function (symbol-function early)) args)) real))) (dolist (fns *early-functions*) (let ((name (car fns)) (early-name (cadr fns))) (redirect-early-function-internal name early-name))) ) ;;; ;;; *generic-function-fixups* is used by fix-early-generic-functions to ;;; convert the few functions in the bootstrap which are supposed to be ;;; generic functions but can't be early on. ;;; (defvar *generic-function-fixups* '((add-method ((generic-function method) ;lambda-list (standard-generic-function method) ;specializers real-add-method)) ;method-function (remove-method ((generic-function method) (standard-generic-function method) real-remove-method)) (get-method ((generic-function qualifiers specializers &optional (errorp t)) (standard-generic-function t t) real-get-method)) (ensure-generic-function-using-class ((generic-function function-specifier &key generic-function-class environment &allow-other-keys) (generic-function t) real-ensure-gf-using-class--generic-function) ((generic-function function-specifier &key generic-function-class environment &allow-other-keys) (null t) real-ensure-gf-using-class--null)) (make-method-lambda ((proto-generic-function proto-method lambda-expression environment) (standard-generic-function standard-method t t) real-make-method-lambda)) (make-method-initargs-form ((proto-generic-function proto-method lambda-expression lambda-list environment) (standard-generic-function standard-method t t t) real-make-method-initargs-form)) (compute-effective-method ((generic-function combin applicable-methods) (generic-function standard-method-combination t) standard-compute-effective-method)) )) ;;; FIXME need GCL support for these kernel:* functions ;;; ;;; ;;; ;;; ;;; ANSI 3.4.2, Generic Function Lambda Lists ;;; ;(defun parse-generic-function-lambda-list (lambda-list) ;; This is like kernel:parse-lambda-list, but returns an additional ;; value AUXP which is true if LAMBDA-LIST contains any &aux keyword. ; (multiple-value-bind (required optional restp rest keyp keys ; allow-other-keys-p aux morep ; more-context more-count) ; (kernel:parse-lambda-list lambda-list) ; (values required optional restp rest keyp keys allow-other-keys-p ; (or aux (member '&aux lambda-list :test #'eq)) aux ; morep more-context more-count))) ;(defun check-generic-function-lambda-list (function-specifier lambda-list) ; (multiple-value-bind (required optional restp rest keyp keys ; allow-other-keys-p auxp aux morep ; more-context more-count) ; (parse-generic-function-lambda-list lambda-list) ; (declare (ignore restp rest keyp aux allow-other-keys-p more-context ; more-count)) ; (labels ((lambda-list-error (format-control &rest format-arguments) ; (simple-program-error "Generic function ~A:~%~?" ; function-specifier ; format-control format-arguments)) ; (check-required-parameter (parameter) ; (unless (symbolp parameter) ; (lambda-list-error ; "Invalid generic function parameter name ~A" ; parameter))) ; (check-key-or-optional-parameter (parameter) ; (unless (or (symbolp parameter) ; (and (consp parameter) ; (symbolp (car parameter)))) ; (lambda-list-error ; "Invalid generic function parameter name: ~A" ; parameter)) ; (when (and (consp parameter) ; (not (null (cdr parameter)))) ; (lambda-list-error ; "Optional and key parameters of generic functions~%~ ; may not have default values or supplied-p ~ ; parameters: ~A" parameter)))) ; (when morep ; (lambda-list-error ; "&MORE not allowed in generic function lambda lists")) ; (when auxp ; (lambda-list-error ; "&AUX not allowed in generic function lambda lists")) ; (mapc #'check-required-parameter required) ; (mapc #'check-key-or-optional-parameter optional) ; (mapc #'check-key-or-optional-parameter keys)))) (defmacro defgeneric (function-specifier lambda-list &body options) ; (check-generic-function-lambda-list function-specifier lambda-list) (expand-defgeneric function-specifier lambda-list options)) (defun expand-defgeneric (function-specifier lambda-list options) (let ((initargs ()) (methods ())) (labels ((loose (format-control &rest format-arguments) (error 'program-error (format nil "~~@" format-control format-arguments) function-specifier)) (duplicate-option (name) (loose "The option ~S appears more than once." name)) (check-declaration (declaration-specifiers) (loop for specifier in declaration-specifiers when (and (consp specifier) (member (car specifier) '(special ftype function inline notinline declaration))) do (loose "Declaration specifier ~S is not allowed" specifier))) (check-argument-precedence-order (precedence) (let ((required (ldiff lambda-list (member-if (lambda (x) (member x '(&optional &rest &key &allow-other-keys &aux))) lambda-list)))) (when (set-difference required precedence) (loose "Argument precedence order must list all ~ required parameters and only those: ~s" precedence)) (when (/= (length (remove-duplicates precedence)) (length precedence)) (loose "Duplicate parameter names in argument ~ precedence order: ~s" precedence)))) (initarg (key &optional (new nil new-supplied-p)) (if new-supplied-p (setf (getf initargs key) new) (getf initargs key)))) (when (and (symbolp function-specifier) (special-operator-p function-specifier)) (loose "Special operators cannot be made generic functions")) (dolist (option options) (case (car option) (:argument-precedence-order (when (initarg :argument-precedence-order) (duplicate-option :argument-precedence-order)) (check-argument-precedence-order (cdr option)) (initarg :argument-precedence-order `',(cdr option))) (declare (check-declaration (cdr option)) (initarg :declarations (append (cdr option) (initarg :declarations)))) (:documentation (if (initarg :documentation) (duplicate-option :documentation) (initarg :documentation `',(cadr option)))) (:method-combination (if (initarg :method-combination) (duplicate-option :method-combination) (initarg :method-combination `',(cdr option)))) (:generic-function-class (if (initarg :generic-function-class) (duplicate-option :generic-function-class) (initarg :generic-function-class `',(cadr option)))) (:method-class (if (initarg :method-class) (duplicate-option :method-class) (initarg :method-class `',(cadr option)))) (:method (push `(defmethod ,function-specifier ,@(cdr option)) methods)) (t (loose "Unsupported option ~S." option)))) (let ((declarations (initarg :declarations))) (when declarations (initarg :declarations `',declarations)))) ; (tell-compiler-about-gf function-specifier lambda-list) `(progn (proclaim-defgeneric ',function-specifier ',lambda-list) ,(make-top-level-form `(defgeneric ,function-specifier) *defgeneric-times* `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)) ,@(when methods `((set-initial-methods (mapcar 'eval ',methods) (function ,function-specifier)))) `,(function ,function-specifier)))) (defun set-initial-methods (methods gf) (setf (generic-function-initial-methods gf) methods)) (defun load-defgeneric (function-specifier lambda-list &rest initargs) (when (fboundp function-specifier) (warn "Redefining ~s" function-specifier) (let ((fun (fdefinition function-specifier))) (when (generic-function-p fun) (mapc (lambda (x) (remove-method fun x)) (generic-function-initial-methods fun)) (setf (generic-function-initial-methods fun) '())))) (apply #'ensure-generic-function function-specifier :lambda-list lambda-list :definition-source `((defgeneric ,function-specifier) ,(load-truename)) initargs)) ;;; ;;; ;;; (defmacro DEFMETHOD (&rest args &environment env) (declare (arglist name {method-qualifier}* specialized-lambda-list &body body)) (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda name) (expand-defmethod name proto-gf proto-method qualifiers lambda-list body env)))) (defun prototypes-for-make-method-lambda (name) (if (not (eq *boot-state* 'complete)) (values nil nil) (let ((gf? (and (gboundp name) (gdefinition name)))) (if (or (null gf?) (not (generic-function-p gf?))) (values (class-prototype (find-class 'standard-generic-function)) (class-prototype (find-class 'standard-method))) (values gf? (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method)))))))) ;;; ;;; takes a name which is either a generic function name or a list specifying ;;; a setf generic function (like: (SETF )). Returns ;;; the prototype instance of the method-class for that generic function. ;;; ;;; If there is no generic function by that name, this returns the default ;;; value, the prototype instance of the class STANDARD-METHOD. This default ;;; value is also returned if the spec names an ordinary function or even a ;;; macro. In effect, this leaves the signalling of the appropriate error ;;; until load time. ;;; ;;; NOTE that during bootstrapping, this function is allowed to return NIL. ;;; (defun method-prototype-for-gf (name) (let ((gf? (and (gboundp name) (gdefinition name)))) (cond ((neq *boot-state* 'complete) nil) ((or (null gf?) (not (generic-function-p gf?))) ;Someone else MIGHT ;error at load time. (class-prototype (find-class 'standard-method))) (t (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method))))))) (defvar *optimize-asv-funcall-p* nil) (defvar *asv-readers*) (defvar *asv-writers*) (defvar *asv-boundps*) (defun expand-defmethod (name proto-gf proto-method qualifiers lambda-list body env) (let ((*make-instance-function-keys* nil) (*optimize-asv-funcall-p* t) (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil)) (declare (special *make-instance-function-keys*)) (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) (add-method-declarations name qualifiers lambda-list body env) (multiple-value-bind (method-function-lambda initargs) (make-method-lambda proto-gf proto-method method-lambda env) (let ((initargs-form (make-method-initargs-form proto-gf proto-method method-function-lambda initargs env))) ; (tell-compiler-about-gf name lambda-list) `(progn (proclaim-defgeneric ',name ',lambda-list) ,@(when *make-instance-function-keys* `((get-make-instance-functions ',*make-instance-function-keys*))) ,@(when (or *asv-readers* *asv-writers* *asv-boundps*) `((initialize-internal-slot-gfs* ',*asv-readers* ',*asv-writers* ',*asv-boundps*))) ,(make-defmethod-form name qualifiers specializers unspecialized-lambda-list (if proto-method (class-name (class-of proto-method)) 'standard-method) initargs-form (getf (getf initargs :plist) :pv-table-symbol)))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) (defun make-defmethod-form (name qualifiers specializers unspecialized-lambda-list method-class-name initargs-form &optional pv-table-symbol) (let (fn fn-lambda) (if (and (interned-symbol-p (if (consp name) (and (eq (car name) 'setf) (cadr name)) name)) (every #'interned-symbol-p qualifiers) (every (lambda (s) (if (consp s) (and (eq (car s) 'eql) (constantp (cadr s)) (let ((sv (eval (cadr s)))) (or (interned-symbol-p sv) (integerp sv) (and (characterp sv) (standard-char-p sv))))) (interned-symbol-p s))) specializers) (consp initargs-form) (eq (car initargs-form) 'list*) (memq (cadr initargs-form) '(:function :fast-function)) (consp (setq fn (caddr initargs-form))) (eq (car fn) 'function) (consp (setq fn-lambda (cadr fn))) (eq (car fn-lambda) 'lambda)) (let* ((specls (mapcar (lambda (specl) (if (consp specl) `(,(car specl) ,(eval (cadr specl))) specl)) specializers)) (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) ,name ,@qualifiers ,specls)) (mname-sym (intern (let ((*print-pretty* nil)) (format nil "~S" mname))))) `(eval-when ,*defmethod-times* (defun ,mname-sym ,(cadr fn-lambda) ,@(cddr fn-lambda)) ,(make-defmethod-form-internal name qualifiers `',specls unspecialized-lambda-list method-class-name `(list* ,(cadr initargs-form) #',mname-sym ,@(cdddr initargs-form)) pv-table-symbol))) (make-top-level-form `(defmethod ,name ,@qualifiers ,specializers) *defmethod-times* (make-defmethod-form-internal name qualifiers `(list ,@(mapcar (lambda (specializer) (if (consp specializer) ``(,',(car specializer) ,,(cadr specializer)) `',specializer)) specializers)) unspecialized-lambda-list method-class-name initargs-form pv-table-symbol))))) (defun make-defmethod-form-internal (name qualifiers specializers-form unspecialized-lambda-list method-class-name initargs-form &optional pv-table-symbol) `(load-defmethod ',method-class-name ',name ',qualifiers ,specializers-form ',unspecialized-lambda-list ,initargs-form ;;Paper over a bug in KCL by passing the cache-symbol ;;here in addition to in the list. ',pv-table-symbol)) (defmacro make-method-function (method-lambda &environment env) (make-method-function-internal method-lambda env)) (defun make-method-function-internal (method-lambda &optional env) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda nil) (multiple-value-bind (method-function-lambda initargs) (make-method-lambda proto-gf proto-method method-lambda env) (make-method-initargs-form proto-gf proto-method method-function-lambda initargs env)))) (defun add-method-declarations (name qualifiers lambda-list body env) (multiple-value-bind (parameters unspecialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list) (declare (ignore parameters)) (multiple-value-bind (documentation declarations real-body) (extract-declarations body env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) (declare (method-name ,(list name qualifiers specializers))) (declare (method-lambda-list ,@lambda-list)) ,@declarations ,@real-body) unspecialized-lambda-list specializers)))) (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The method-lambda argument to make-method-function, ~S,~ is not a lambda form" method-lambda)) (make-method-initargs-form-internal method-lambda initargs env)) (unless (fboundp 'make-method-initargs-form) (setf (gdefinition 'make-method-initargs-form) (symbol-function 'real-make-method-initargs-form))) (defun real-make-method-lambda (proto-gf proto-method method-lambda env) (declare (ignore proto-gf proto-method)) (make-method-lambda-internal method-lambda env)) (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)) (specialized-parameters (loop for s in specialized-lambda-list for p in required-parameters when (listp s) collect p)) (slots (mapcar #'list required-parameters)) (calls (list nil)) (class-declarations `(declare ,@(mapcan (lambda (a s) (when (and (symbolp s) (neq s t)) (list `(class ,a ,s)))) ; (list `(type ,s ,a)))) 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 (declare (ignorable ,@specialized-parameters)) ,class-declarations ,@declarations (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) ())) (walked-lambda (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 (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. :method-name-declaration ,name-decl) ,@walked-declarations ,@walked-lambda-body)) `(,@(when plist `(:plist ,plist)) ,@(when documentation `(:documentation ,documentation)))))))))) (unless (fboundp 'make-method-lambda) (setf (gdefinition 'make-method-lambda) (symbol-function 'real-make-method-lambda))) (defmacro simple-lexical-method-functions ((lambda-list method-args next-methods &rest lmf-options) &body body) `(progn ,method-args ,next-methods (bind-simple-lexical-method-macros (,method-args ,next-methods) (bind-lexical-method-functions (,@lmf-options) (bind-args (,lambda-list ,method-args) ,@body))))) (defmacro fast-lexical-method-functions ((lambda-list next-method-call args rest-arg &rest lmf-options) &body body) `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) (bind-lexical-method-functions (,@lmf-options) (bind-args (,lambda-list (list* ,@args ,rest-arg)) ,@body)))) (defun call-no-next-method (method-name-declaration &rest args) (destructuring-bind (name qualifiers specializers) (car method-name-declaration) (let ((method (find-method (gdefinition name) qualifiers specializers))) (apply #'no-next-method (method-generic-function method) method args)))) (defun %check-cnm-args (cnm-args orig-args method-name-declaration) (declare (optimize (speed 3) (safety 0) (debug 0)) (type list cnm-args orig-args)) ;; 1. Check for no arguments. (when cnm-args (let* ((gf (gdefinition (caar method-name-declaration)));(method-generic-function (car method-cell)) (nreq (generic-function-nreq gf))) (declare (type (integer 0 #.call-arguments-limit) nreq)) ;; 2. Consider required arguments pairwise: if the old and new ;; arguments in all pairs are EQL, the applicable methods must ;; be the same. This takes care of the relatively common case of ;; twiddling with &KEY arguments. (unless (do ((orig orig-args (cdr orig)) (args cnm-args (cdr args)) (n nreq (1- n))) ((zerop n) t) (declare (type (integer 0 #.call-arguments-limit) n)) (unless (eql (car orig) (car args)) (return nil))) ;; 3. Only then make a cnm args checker and do the full check. ;; Disabled until problems with EQL specializers and method ;; "shadowing" are worked out. #+(or) (let ((result (%use-cnm-checker gf nreq cnm-args orig-args))) (when result (destructuring-bind (cnm-methods . orig-methods) result (error "~@" cnm-methods (length cnm-args) cnm-args orig-methods (length orig-args) orig-args)))) (let ((orig-methods (compute-applicable-methods gf orig-args)) (cnm-methods (compute-applicable-methods gf cnm-args))) (unless (equal orig-methods cnm-methods) (error "~@" cnm-methods (length cnm-args) cnm-args orig-methods (length orig-args) orig-args))))))) (defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) `(macrolet ((call-next-method-bind (&body body) `(let ((.next-method. (car ,',next-methods)) (,',next-methods (cdr ,',next-methods))) .next-method. ,',next-methods ,@body)) (call-next-method-body (method-name-declaration cnm-args) `(progn (%check-cnm-args cnm-args ,',method-args ',method-name-declaration) (if .next-method. (funcall (if (std-instance-p .next-method.) (method-function .next-method.) .next-method.) ; for early methods (or ,cnm-args ,',method-args) ,',next-methods) (apply #'call-no-next-method ',method-name-declaration (or ,cnm-args ,',method-args))))) (next-method-p-body () `(not (null .next-method.)))) ,@body)) (defstruct method-call (function #'identity :type function) call-method-args) #+cmu (declaim (ext:freeze-type method-call)) (defmacro invoke-method-call1 (function args cm-args) `(let ((.function. ,function) (.args. ,args) (.cm-args. ,cm-args)) (if (and .cm-args. (null (cdr .cm-args.))) (funcall .function. .args. (car .cm-args.)) (apply .function. .args. .cm-args.)))) (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg) `(invoke-method-call1 (method-call-function ,method-call) ,(if restp `(list* ,@required-args+rest-arg) `(list ,@required-args+rest-arg)) (method-call-call-method-args ,method-call))) (defstruct fast-method-call (function #'identity :type function) pv-cell next-method-call arg-info) #+cmu (declaim (ext:freeze-type fast-method-call)) #-akcl (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) (defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) `(fmc-funcall (fast-method-call-function ,method-call) (fast-method-call-pv-cell ,method-call) (fast-method-call-next-method-call ,method-call) ,@required-args+rest-arg)) (defstruct fast-instance-boundp (index 0 :type fixnum)) #+cmu (declaim (ext:freeze-type fast-instance-boundp)) (eval-when (compile load eval) (defvar *allow-emf-call-tracing-p* nil) (defvar *enable-emf-call-tracing-p* #-testing nil #+testing t) ) (defvar *emf-call-trace-size* 200) (defvar *emf-call-trace* nil) (defvar emf-call-trace-index 0) (defun show-emf-call-trace () (when *emf-call-trace* (let ((j emf-call-trace-index) (*enable-emf-call-tracing-p* nil)) (format t "~&(The oldest entries are printed first)~%") (dotimes (i *emf-call-trace-size*) (declare (fixnum i)) (let ((ct (aref *emf-call-trace* j))) (when ct (print ct))) (incf j) (when (= j *emf-call-trace-size*) (setq j 0)))))) (defun trace-emf-call-internal (emf format args) (unless *emf-call-trace* (setq *emf-call-trace* (make-array *emf-call-trace-size*))) (setf (aref *emf-call-trace* emf-call-trace-index) (list* emf format args)) (incf emf-call-trace-index) (when (= emf-call-trace-index *emf-call-trace-size*) (setq emf-call-trace-index 0))) (defmacro trace-emf-call (emf format args) (when *allow-emf-call-tracing-p* `(when *enable-emf-call-tracing-p* (trace-emf-call-internal ,emf ,format ,args)))) (defmacro invoke-effective-method-function-fast (emf restp &rest required-args+rest-arg) `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (invoke-fast-method-call ,emf ,@required-args+rest-arg))) (defmacro invoke-effective-method-function (emf restp &rest required-args+rest-arg) (unless (constantp restp) (error "The restp argument to invoke-effective-method-function is not constant")) (setq restp (eval restp)) `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond ((typep ,emf 'fast-method-call) (invoke-fast-method-call ,emf ,@required-args+rest-arg)) ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fixnum) (let* ((.slots. (get-slots-or-nil ,(car required-args+rest-arg))) (value (when .slots. (%instance-ref .slots. ,emf)))) (if (eq value ',*slot-unbound*) (slot-unbound-internal ,(car required-args+rest-arg) ,emf) value))))) ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) `(((typep ,emf 'fixnum) (let ((.new-value. ,(car required-args+rest-arg)) (.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) (when .slots. ; just to avoid compiler wranings (setf (%instance-ref .slots. ,emf) .new-value.)))))) #|| ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fast-instance-boundp) (let ((.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) (and .slots. (not (eq (%instance-ref .slots. (fast-instance-boundp-index ,emf)) ',*slot-unbound*))))))) ||# (t (etypecase ,emf (method-call (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) (function ,(if restp `(apply (the function ,emf) ,@required-args+rest-arg) `(funcall (the function ,emf) ,@required-args+rest-arg)))))))) (defun invoke-emf (emf args) (trace-emf-call emf t args) (etypecase emf (fast-method-call (let* ((arg-info (fast-method-call-arg-info emf)) (restp (cdr arg-info)) (nreq (car arg-info))) (if restp (let* ((rest-args (nthcdr nreq args)) (req-args (ldiff args rest-args))) (apply (fast-method-call-function emf) (fast-method-call-pv-cell emf) (fast-method-call-next-method-call emf) (nconc req-args (list rest-args)))) (cond ((null args) (if (eql nreq 0) (invoke-fast-method-call emf) (error 'program-error :format-control "wrong number of args"))) ((null (cdr args)) (if (eql nreq 1) (invoke-fast-method-call emf (car args)) (error 'program-error :format-control "wrong number of args"))) ((null (cddr args)) (if (eql nreq 2) (invoke-fast-method-call emf (car args) (cadr args)) (error 'program-error :format-control "wrong number of args"))) (t (apply (fast-method-call-function emf) (fast-method-call-pv-cell emf) (fast-method-call-next-method-call emf) args)))))) (method-call (apply (method-call-function emf) args (method-call-call-method-args emf))) (fixnum (cond ((null args) (error "1 or 2 args expected")) ((null (cdr args)) (let ((value (%instance-ref (get-slots (car args)) emf))) (if (eq value *slot-unbound*) (slot-unbound-internal (car args) emf) value))) ((null (cddr args)) (setf (%instance-ref (get-slots (cadr args)) emf) (car args))) (t (error "1 or 2 args expected")))) (fast-instance-boundp (if (or (null args) (cdr args)) (error "1 arg expected") (not (eq (%instance-ref (get-slots (car args)) (fast-instance-boundp-index emf)) *slot-unbound*)))) (function (apply emf args)))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) `(macrolet ((call-next-method-bind (&body body) `(let () ,@body)) (call-next-method-body (method-name-declaration cnm-args) `(progn (%check-cnm-args cnm-args (list ,@',args) ',method-name-declaration) (if ,',next-method-call ,(if (and (null ',rest-arg) (consp cnm-args) (eq (car cnm-args) 'list)) `(invoke-effective-method-function ,',next-method-call nil ,@(cdr cnm-args)) (let ((call `(invoke-effective-method-function ,',next-method-call ,',(not (null rest-arg)) ,@',args ,@',(when rest-arg `(,rest-arg))))) `(if ,cnm-args (bind-args ((,@',args ,@',(when rest-arg `(&rest ,rest-arg))) ,cnm-args) ,call) ,call))) ,(if (and (null ',rest-arg) (consp cnm-args) (eq (car cnm-args) 'list)) `(call-no-next-method ',method-name-declaration ,@(cdr cnm-args)) `(call-no-next-method ',method-name-declaration ,@',args ,@',(when rest-arg `(,rest-arg))))))) (next-method-p-body () `(not (null ,',next-method-call)))) ,@body)) (defmacro bind-lexical-method-functions ((&key method-name-declaration) &body body) `(call-next-method-bind (flet ((call-next-method (&rest cnm-args) (declare (dynamic-extent cnm-args)) (call-next-method-body ,method-name-declaration cnm-args)) (next-method-p () (next-method-p-body))) (declare (ignorable #'call-next-method #'next-method-p)) ,@body))) (defmacro bind-args ((lambda-list args) &body body) `(destructuring-bind ,lambda-list ,args ,@body)) (defun get-key-arg-tail (keyword list) (loop for (key . tail) on list by #'cddr when (null tail) do (error 'program-error :format-control "Odd number of keyword arguments in ~S" :format-arguments (list list)) when (eq key keyword) return tail)) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (flet ((walk-function (form context env) (cond ((not (eq context :eval)) form) ((not (listp form)) form) ((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 (eq (car form) 'apply) (consp (cadr form)) (eq (car (cadr form)) 'function) (generic-function-name-p (cadr (cadr form)))) (optimize-generic-function-call form required-parameters env slots calls)) ((and (or (symbolp (car form)) (and (consp (car form)) (eq (caar form) 'setf))) (generic-function-name-p (car form))) (optimize-generic-function-call form required-parameters env slots calls)) ((and (eq (car form) 'asv-funcall) *optimize-asv-funcall-p*) (case (fourth form) (reader (push (third form) *asv-readers*)) (writer (push (third form) *asv-writers*)) (boundp (push (third form) *asv-boundps*))) `(,(second form) ,@(cddddr form))) (t form)))) (walk-form method-lambda env #'walk-function))) (defun generic-function-name-p (name) (and (or (symbolp name) (and (consp name) (eq (car name) 'setf) (consp (cdr name)) (symbolp (cadr name)) (null (cddr name)))) (gboundp name) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) (defvar *method-function-plist* (make-hash-table :test #'eq)) (defvar *mf1* nil) (defvar *mf1p* nil) (defvar *mf1cp* nil) (defvar *mf2* nil) (defvar *mf2p* nil) (defvar *mf2cp* nil) (defun method-function-plist (method-function) (unless (eq method-function *mf1*) (rotatef *mf1* *mf2*) (rotatef *mf1p* *mf2p*) (rotatef *mf1cp* *mf2cp*)) (unless (or (eq method-function *mf1*) (null *mf1cp*)) (setf (gethash *mf1* *method-function-plist*) *mf1p*)) (unless (eq method-function *mf1*) (setf *mf1* method-function *mf1cp* nil *mf1p* (gethash method-function *method-function-plist*))) *mf1p*) (defun (setf method-function-plist) (val method-function) (unless (eq method-function *mf1*) (rotatef *mf1* *mf2*) (rotatef *mf1cp* *mf2cp*) (rotatef *mf1p* *mf2p*)) (unless (or (eq method-function *mf1*) (null *mf1cp*)) (setf (gethash *mf1* *method-function-plist*) *mf1p*)) (setf *mf1* method-function *mf1cp* t *mf1p* val)) (defun method-function-get (method-function key &optional default) (getf (method-function-plist method-function) key default)) (defun (setf method-function-get) (val method-function key) (setf (getf (method-function-plist method-function) key) val)) (defun method-function-pv-table (method-function) (method-function-get method-function :pv-table)) (defun method-function-method (method-function) (method-function-get method-function :method)) (defmacro method-function-closure-generator (method-function) `(method-function-get ,method-function 'closure-generator)) (defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol) (setq initargs (copy-tree initargs)) (let ((method-spec (or (getf initargs :method-spec) (make-method-spec name quals specls)))) (setf (getf initargs :method-spec) method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list initargs pv-table-symbol) (when pv-table-symbol (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers) ,(load-truename)) initargs))) (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) (format *error-output* "~&At the time the method with qualifiers ~:S and~%~ specializers ~:S on the generic function ~S~%~ was compiled, the method-class for that generic function was~%~ ~S. But, the method class is now ~S, this~%~ may mean that this method was compiled improperly.~%" qualifiers specializers gf-spec method-class (class-name (class-of method)))) method)) (defun make-method-spec (gf-spec qualifiers unparsed-specializers) `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) (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))))))) (defun analyze-lambda-list (lambda-list) ;;(declare (values nrequired noptional keysp restp allow-other-keys-p ;; keywords keyword-parameters)) (flet ((parse-keyword-argument (arg) (if (listp arg) (if (listp (car arg)) (caar arg) (make-keyword (car arg))) (make-keyword arg)))) (let ((nrequired 0) (noptional 0) (keysp nil) (restp nil) (allow-other-keys-p nil) (keywords ()) (keyword-parameters ()) (state 'required)) (dolist (x lambda-list) (if (memq x lambda-list-keywords) (case x (&optional (setq state 'optional)) (&key (setq keysp 't state 'key)) (&allow-other-keys (setq allow-other-keys-p 't)) (&rest (setq restp 't state 'rest)) (&aux (return t)) (otherwise (error "Encountered the non-standard lambda list keyword ~S." x))) (ecase state (required (incf nrequired)) (optional (incf noptional)) (key (push (parse-keyword-argument x) keywords) (push x keyword-parameters)) (rest ())))) (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords) (reverse keyword-parameters))))) (defun keyword-spec-name (x) (let ((key (if (atom x) x (car x)))) (if (atom key) (intern (symbol-name key) (find-package "KEYWORD")) (car key)))) (defun ftype-declaration-from-lambda-list (lambda-list #+cmu name) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) (let* (#+cmu (old (c::info function type name)) #+cmu (old-ftype (if (c::function-type-p old) old nil)) #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype))) #+cmu (old-keys (and old-ftype (mapcar #'c::key-info-name (c::function-type-keywords old-ftype)))) #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keywords)) #-cmu (mapcar #'keyword-spec-name keywords))) `(function ,(append (make-list nrequired :initial-element t) (when (plusp noptional) (append '(&optional) (make-list noptional :initial-element t))) (when (or restp #+cmu old-restp) '(&rest t)) (when (or keysp #+cmu old-keysp) (append '(&key) (mapcar (lambda (key) `(,key t)) keywords) (when (or allow-other-keys-p #+cmu old-allowp) '(&allow-other-keys))))) *)))) (defun proclaim-defgeneric (spec lambda-list) #-cmu (declare (ignore lambda-list)) (when (consp spec) (setq spec (get-setf-function-name (cadr spec)))) (let (#+cmu (decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec) ,spec))) #+cmu (proclaim decl) ;;FIXME proclaim setf compiled closures too #+kcl (when (symbolp spec) (setf (get spec 'compiler::proclaimed-closure) t)))) ;;;; Early generic-function support ;;; ;;; (defvar *early-generic-functions* ()) (defun ensure-generic-function (function-specifier &rest all-keys &key environment &allow-other-keys) (declare (ignore environment)) (let* ((function-specifier (or (get (si::funid-sym function-specifier) 'si::traced) function-specifier)) (existing (and (gboundp function-specifier) (gdefinition function-specifier)))) (when (and existing (eq *boot-state* 'complete) (null (generic-function-p existing))) (generic-clobbers-function function-specifier) (setq existing nil)) (apply #'ensure-generic-function-using-class existing function-specifier all-keys))) (defun generic-clobbers-function (function-specifier) (cerror "Discard the existing definition." 'program-error :format-control "~S already names an ordinary function or a macro.~%~ If you want to replace it with a generic function, you should remove~%~ the existing definition beforehand.~%" :format-arguments (list function-specifier)) (fmakunbound function-specifier)) (defvar *sgf-wrapper* (#+cmu17 boot-make-wrapper #-cmu17 make-wrapper (early-class-size 'standard-generic-function) #+cmu17 'standard-generic-function)) (defvar *sgf-slots-init* (map 'vector (lambda (canonical-slot) (if (memq (getf canonical-slot :name) '(arg-info source)) *slot-unbound* (let ((initfunction (getf canonical-slot :initfunction))) (if initfunction (funcall initfunction) *slot-unbound*)))) (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* (bootstrap-slot-index 'standard-generic-function 'method-class)) (defun early-gf-p (x) (and (fsc-instance-p x) (eq (instance-ref (get-slots x) *sgf-method-class-index*) *slot-unbound*))) (defvar *sgf-methods-index* (bootstrap-slot-index 'standard-generic-function 'methods)) (defmacro early-gf-methods (gf) `(instance-ref (get-slots ,gf) *sgf-methods-index*)) (defvar *sgf-arg-info-index* (bootstrap-slot-index 'standard-generic-function 'arg-info)) (defmacro early-gf-arg-info (gf) `(instance-ref (get-slots ,gf) *sgf-arg-info-index*)) (defvar *sgf-dfun-state-index* (bootstrap-slot-index 'standard-generic-function 'dfun-state)) (defstruct (arg-info (:conc-name nil) (:constructor make-arg-info ())) (arg-info-lambda-list :no-lambda-list) arg-info-precedence arg-info-metatypes arg-info-number-optional arg-info-key/rest-p arg-info-keywords ;nil no keyword or rest allowed ;(k1 k2 ..) each method must accept these keyword arguments ;T must have &key or &rest gf-info-simple-accessor-type ; nil, reader, writer, boundp (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info gf-info-static-c-a-m-emf (gf-info-c-a-m-emf-std-p t) gf-info-fast-mf-p) #+cmu (declaim (ext:freeze-type arg-info)) (defun arg-info-valid-p (arg-info) (not (null (arg-info-number-optional arg-info)))) (defun arg-info-applyp (arg-info) (or (plusp (the fixnum (arg-info-number-optional arg-info))) (arg-info-key/rest-p arg-info))) (defun arg-info-number-required (arg-info) (length (arg-info-metatypes arg-info))) (defun arg-info-nkeys (arg-info) (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info))) ;;; Keep pages clean by not setting if the value is already the same. (defmacro esetf (pos val) (let ((valsym (gensym "value"))) `(let ((,valsym ,val)) (unless (equal ,pos ,valsym) (setf ,pos ,valsym))))) (defun generic-function-nreq (gf) (let* ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) (gf-arg-info gf)));safe (metatypes (arg-info-metatypes arg-info))) (declare (list metatypes)) (length metatypes))) (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf))) (methods (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf))) (was-valid-p (integerp (arg-info-number-optional arg-info))) (first-p (and new-method (null (cdr methods))))) (when (and (not lambda-list-p) methods) (setq lambda-list (gf-lambda-list gf))) (when (or lambda-list-p (and first-p (eq (arg-info-lambda-list arg-info) :no-lambda-list))) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list lambda-list) (when (and methods (not first-p)) (let ((gf-nreq (arg-info-number-required arg-info)) (gf-nopt (arg-info-number-optional arg-info)) (gf-key/rest-p (arg-info-key/rest-p arg-info))) (unless (and (= nreq gf-nreq) (= nopt gf-nopt) (eq (or keysp restp) gf-key/rest-p)) (error "The lambda-list ~S is incompatible with ~ existing methods of ~S." lambda-list gf)))) (when lambda-list-p (esetf (arg-info-lambda-list arg-info) lambda-list)) (when (or lambda-list-p argument-precedence-order (null (arg-info-precedence arg-info))) (esetf (arg-info-precedence arg-info) (compute-precedence lambda-list nreq argument-precedence-order))) (esetf (arg-info-metatypes arg-info) (make-list nreq)) (esetf (arg-info-number-optional arg-info) nopt) (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) (esetf (arg-info-keywords arg-info) (if lambda-list-p (if allow-other-keys-p t keywords) (arg-info-key/rest-p arg-info))))) (when new-method (check-method-arg-info gf arg-info new-method)) (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) arg-info)) (defun check-method-arg-info (gf arg-info 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))) (flet ((lose (format-control &rest format-args) (error 'program-error :format-control "Attempt to add the method ~S to the generic function ~S.~%~ But ~?" :format-arguments (list method gf format-control format-args))) (compare (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) (gf-nopt (arg-info-number-optional arg-info)) (gf-key/rest-p (arg-info-key/rest-p arg-info)) (gf-keywords (arg-info-keywords arg-info))) (unless (= nreq gf-nreq) (lose "the method has ~A required arguments than the generic function." (compare nreq gf-nreq))) (unless (= nopt gf-nopt) (lose "the method has ~S optional arguments than the generic function." (compare nopt gf-nopt))) (unless (eq (or keysp restp) gf-key/rest-p) (lose "the method and generic function differ in whether they accept~%~ rest or keyword arguments.")) (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p (every (lambda (k) (memq k keywords)) gf-keywords)) (lose "the method does not accept each of the keyword arguments~%~ ~S." gf-keywords))))))) (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) (let* ((existing-p (and methods (cdr methods) new-method)) (nreq (length (arg-info-metatypes arg-info))) (metatypes (if existing-p (arg-info-metatypes arg-info) (make-list nreq))) (type (if existing-p (gf-info-simple-accessor-type arg-info) nil))) (when (arg-info-valid-p arg-info) (dolist (method (if new-method (list new-method) methods)) (let* ((specializers (if (or (eq *boot-state* 'complete) (not (consp method))) (method-specializers method) (early-method-specializers method t))) (class (if (or (eq *boot-state* 'complete) (not (consp method))) (class-of method) (early-method-class method))) (new-type (when (and class (or (not (eq *boot-state* 'complete)) (eq (generic-function-method-combination gf) *standard-method-combination*))) (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))))) (setq metatypes (mapcar #'raise-metatype metatypes specializers)) (setq type (cond ((null type) new-type) ((eq type new-type) type) (t nil))))) (esetf (arg-info-metatypes arg-info) metatypes) (esetf (gf-info-simple-accessor-type arg-info) type))) (when (or (not was-valid-p) first-p) (multiple-value-bind (c-a-m-emf std-p) (if (early-gf-p gf) (values t t) (compute-applicable-methods-emf gf)) (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p) (unless (gf-info-c-a-m-emf-std-p arg-info) (esetf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p (let ((name (if (eq *boot-state* 'complete) (generic-function-name gf) (early-gf-name gf)))) (esetf (gf-precompute-dfun-and-emf-p arg-info) (let* ((sym (if (atom name) name (cadr name))) (pkg-list (cons *the-pcl-package* (package-use-list *the-pcl-package*)))) (and sym (symbolp sym) (not (null (memq (symbol-package sym) pkg-list))) (not (find #\space (symbol-name sym)))))))) (esetf (gf-info-fast-mf-p arg-info) (or (not (eq *boot-state* 'complete)) (let* ((method-class (generic-function-method-class gf)) (methods (compute-applicable-methods #'make-method-lambda (list gf (class-prototype method-class) '(lambda) nil)))) (and methods (null (cdr methods)) (let ((specls (method-specializers (car methods)))) (and (classp (car specls)) (eq 'standard-generic-function (class-name (car specls))) (classp (cadr specls)) (eq 'standard-method (class-name (cadr specls))))))))) arg-info) ;;; ;;; This is the early definition of ensure-generic-function-using-class. ;;; ;;; The static-slots field of the funcallable instances used as early generic ;;; functions is used to store the early methods and early discriminator code ;;; for the early generic function. The static slots field of the fins ;;; contains a list whose: ;;; CAR - a list of the early methods on this early gf ;;; CADR - the early discriminator code for this method ;;; (defun ensure-generic-function-using-class (existing spec &rest keys &key (lambda-list nil lambda-list-p) argument-precedence-order &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) existing) ((assoc spec *generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing argument-precedence-order) (error "The function ~S is not already defined" spec))) (existing (error "~S should be on the list ~S" spec '*generic-function-fixups*)) (t (pushnew spec *early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil argument-precedence-order)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p function argument-precedence-order) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin (or function (if (eq spec 'print-object) (fin-lambda-fn (instance stream) (printing-random-thing (instance stream) (format stream "std-instance"))) (fin-lambda-fn (&rest args) (declare (ignore args)) (warn "The function of the funcallable-instance ~S~ has not been set" fin) (values-list (make-list (random multiple-values-limit))))))) (setf (gdefinition spec) fin) (bootstrap-set-slot 'standard-generic-function fin 'name spec) (bootstrap-set-slot 'standard-generic-function fin 'source (load-truename)) (set-function-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p (proclaim-defgeneric spec lambda-list) (if argument-precedence-order (set-arg-info fin :lambda-list lambda-list :argument-precedence-order argument-precedence-order) (set-arg-info fin :lambda-list lambda-list)))) fin)) (defun set-dfun (gf &optional dfun cache info) (when cache (setf (cache-owner cache) gf)) (let ((new-state (if (and dfun (or cache info)) (list* dfun cache info) dfun))) (if (eq *boot-state* 'complete) (setf (gf-dfun-state gf) new-state) (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) dfun) (defun gf-dfun-cache (gf) (let ((state (if (eq *boot-state* 'complete) (gf-dfun-state gf) (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cadr state))))) (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) (gf-dfun-state gf) (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cddr state))))) (defvar *sgf-name-index* (bootstrap-slot-index 'standard-generic-function 'name)) (defun early-gf-name (gf) (instance-ref (get-slots gf) *sgf-name-index*)) (defun gf-lambda-list (gf) (let ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf)))) (if (eq :no-lambda-list (arg-info-lambda-list arg-info)) (let ((methods (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf)))) (if (null methods) (progn (warn "No way to determine the lambda list for ~S." gf) nil) (let* ((method (car (last methods)))) (if (consp method) (early-method-lambda-list method) (method-lambda-list method))))) (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) `(progn (cond ((symbolp ,gf-class) (setq ,gf-class (find-class ,gf-class t ,env))) ((classp ,gf-class)) (t (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ class nor a symbol that names a class." ,gf-class))) (remf ,all-keys :generic-function-class) (remf ,all-keys :environment) (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) (unless (eq combin '.shes-not-there.) (setf (getf ,all-keys :method-combination) (find-method-combination (class-prototype ,gf-class) (car combin) (cdr combin))))) (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) (if (classp method-class) method-class (find-class method-class t ,env))))))) (defun real-ensure-gf-using-class--generic-function (existing function-specifier &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function gf-class-p) &allow-other-keys) (real-ensure-gf-internal generic-function-class all-keys environment) (unless (or (null gf-class-p) (eq (class-of existing) generic-function-class)) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) (when lambda-list-p (proclaim-defgeneric function-specifier lambda-list)))) (defun real-ensure-gf-using-class--null (existing function-specifier &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function) &allow-other-keys) (declare (ignore existing)) (real-ensure-gf-internal generic-function-class all-keys environment) (prog1 (setf (gdefinition function-specifier) (apply #'make-instance generic-function-class :name function-specifier all-keys)) (when lambda-list-p (proclaim-defgeneric function-specifier lambda-list)))) (defun get-generic-function-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) (gf-arg-info gf))) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes arg-info)) ; (print (list 'baz gf (early-gf-p gf) arg-info (arg-info-applyp arg-info))) (values (length metatypes) applyp metatypes (count-if (lambda (x) (neq x t)) metatypes) arg-info))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc &optional slot-name) (initialize-method-function initargs) (let ((parsed ()) (unparsed ())) ;; Figure out whether we got class objects or class names as the ;; specializers and set parsed and unparsed appropriately. If we ;; got class objects, then we can compute unparsed, but if we got ;; class names we don't try to compute parsed. ;; ;; Note that the use of not symbolp in this call to every should be ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. (if (every (lambda (s) (not (symbolp s))) specializers) (setq parsed specializers unparsed (mapcar (lambda (s) (if (eq s t) t (class-name s))) specializers)) (setq unparsed specializers parsed ())) (list :early-method ;This is an early method dammit! (getf initargs :function) (getf initargs :fast-function) parsed ;The parsed specializers. This is used ;by early-method-specializers to cache ;the parse. Note that this only comes ;into play when there is more than one ;early method on an early gf. (list class ;A list to which real-make-a-method qualifiers ;can be applied to make a real method arglist ;corresponding to this early one. unparsed initargs doc slot-name) ))) (defun real-make-a-method (class qualifiers lambda-list specializers initargs doc &optional slot-name) (setq specializers (parse-specializers specializers)) (apply #'make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers specializers :documentation doc :slot-name slot-name :allow-other-keys t initargs)) (defun early-method-function (early-method) (values (cadr early-method) (caddr early-method))) (defun early-method-class (early-method) (find-class (car (fifth early-method)))) (defun early-method-standard-accessor-p (early-method) (let ((class (first (fifth early-method)))) (or (eq class 'standard-reader-method) (eq class 'standard-writer-method) (eq class 'standard-boundp-method)))) (defun early-method-standard-accessor-slot-name (early-method) (seventh (fifth early-method))) ;;; ;;; Fetch the specializers of an early method. This is basically just a ;;; simple accessor except that when the second argument is t, this converts ;;; the specializers from symbols into class objects. The class objects ;;; are cached in the early method, this makes bootstrapping faster because ;;; the class objects only have to be computed once. ;;; NOTE: ;;; the second argument should only be passed as T by early-lookup-method. ;;; this is to implement the rule that only when there is more than one ;;; early method on a generic function is the conversion from class names ;;; to class objects done. ;;; the corresponds to the fact that we are only allowed to have one method ;;; on any generic function up until the time classes exist. ;;; (defun early-method-specializers (early-method &optional objectsp) (if (and (listp early-method) (eq (car early-method) :early-method)) (cond ((eq objectsp t) (or (fourth early-method) (setf (fourth early-method) (mapcar #'find-class (cadddr (fifth early-method)))))) (t (cadddr (fifth early-method)))) (error "~S is not an early-method." early-method))) (defun early-method-qualifiers (early-method) (cadr (fifth early-method))) (defun early-method-lambda-list (early-method) (caddr (fifth early-method))) (defun early-add-named-method (generic-function-name qualifiers specializers arglist &rest initargs) (let* ((gf (ensure-generic-function generic-function-name)) (existing (dolist (m (early-gf-methods gf)) (when (and (equal (early-method-specializers m) specializers) (equal (early-method-qualifiers m) qualifiers)) (return m)))) (new (make-a-method 'standard-method qualifiers arglist specializers initargs ()))) (when existing (remove-method gf existing)) (add-method gf new))) ;;; ;;; This is the early version of add-method. Later this will become a ;;; generic function. See fix-early-generic-functions which has special ;;; knowledge about add-method. ;;; (defun add-method (generic-function method) (when (not (fsc-instance-p generic-function)) (error "Early add-method didn't get a funcallable instance.")) (when (not (and (listp method) (eq (car method) :early-method))) (error "Early add-method didn't get an early method.")) (push method (early-gf-methods generic-function)) (set-arg-info generic-function :new-method method) (unless (assoc (early-gf-name generic-function) *generic-function-fixups* :test #'equal) (update-dfun generic-function))) ;;; ;;; This is the early version of remove method. ;;; (defun remove-method (generic-function method) (when (not (fsc-instance-p generic-function)) (error "Early remove-method didn't get a funcallable instance.")) (when (not (and (listp method) (eq (car method) :early-method))) (error "Early remove-method didn't get an early method.")) (setf (early-gf-methods generic-function) (remove method (early-gf-methods generic-function))) (set-arg-info generic-function) (unless (assoc (early-gf-name generic-function) *generic-function-fixups* :test #'equal) (update-dfun generic-function))) ;;; ;;; And the early version of get-method. ;;; (defun get-method (generic-function qualifiers specializers &optional (errorp t)) (if (early-gf-p generic-function) (or (dolist (m (early-gf-methods generic-function)) (when (and (or (equal (early-method-specializers m nil) specializers) (equal (early-method-specializers m t) specializers)) (equal (early-method-qualifiers m) qualifiers)) (return m))) (if errorp (error "Can't get early method.") nil)) (real-get-method generic-function qualifiers specializers errorp))) (defvar *fegf-debug-p* nil) (defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*)) (let ((accessors nil)) ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions. (dolist (early-gf-spec *early-generic-functions*) (when (every #'early-method-standard-accessor-p (early-gf-methods (gdefinition early-gf-spec))) (push early-gf-spec accessors))) (dolist (spec (nconc accessors '(accessor-method-slot-name generic-function-methods method-specializers specializerp specializer-type specializer-class slot-definition-location slot-definition-name class-slots gf-arg-info class-precedence-list slot-boundp-using-class (setf slot-value-using-class) slot-value-using-class structure-class-p standard-class-p funcallable-standard-class-p specializerp))) (setq *early-generic-functions* (cons spec (delete spec *early-generic-functions* :test #'equal)))) (dolist (early-gf-spec *early-generic-functions*) (when noisyp (format t "~&~S..." early-gf-spec)) (let* ((gf (gdefinition early-gf-spec)) (methods (mapcar (lambda (early-method) (let ((args (copy-list (fifth early-method)))) (setf (fourth args) (early-method-specializers early-method t)) (apply #'real-make-a-method args))) (early-gf-methods gf)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) *standard-method-combination*) (set-methods gf methods))) (dolist (fns *early-functions*) (setf (gdefinition (car fns)) (symbol-function (caddr fns)))) (dolist (fixup *generic-function-fixups*) (let* ((fspec (car fixup)) (gf (gdefinition fspec)) (methods (mapcar (lambda (method) (let* ((lambda-list (first method)) (specializers (second method)) (method-fn-name (third method)) (fn-name (or method-fn-name fspec)) (fn (symbol-function fn-name)) (initargs (list :function (set-function-name (lambda (args next-methods) (declare (ignore next-methods)) (apply fn args)) `(call ,fn-name))))) (declare (type function fn)) (make-a-method 'standard-method () lambda-list specializers initargs nil))) (cdr fixup)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) *standard-method-combination*) (set-methods gf methods))))) ;;; ;;; parse-defmethod is used by defmethod to parse the &rest argument into ;;; the 'real' arguments. This is where the syntax of defmethod is really ;;; implemented. ;;; (defun parse-defmethod (cdr-of-form) (declare (list cdr-of-form)) (let ((name (pop cdr-of-form)) (qualifiers ()) (spec-ll ())) (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) (push (pop cdr-of-form) qualifiers) (return (setq qualifiers (nreverse qualifiers))))) (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) (defun parse-specializers (specializers) (declare (list specializers)) (flet ((parse (spec) (let ((result (specializer-from-type spec))) (if (specializerp result) result (if (symbolp spec) (error "~S used as a specializer,~%~ but is not the name of a class." spec) (error "~S is not a legal specializer." spec)))))) (mapcar #'parse specializers))) (defun unparse-specializers (specializers-or-method) (if (listp specializers-or-method) (flet ((unparse (spec) (if (specializerp spec) (let ((type (specializer-type spec))) (if (and (consp type) (eq (car type) 'class)) (let* ((class (cadr type)) (class-name (class-name class))) (if (eq class (find-class class-name nil)) class-name type)) type)) (error "~S is not a legal specializer." spec)))) (mapcar #'unparse specializers-or-method)) (unparse-specializers (method-specializers specializers-or-method)))) (defun parse-method-or-spec (spec &optional (errorp t)) ;;(declare (values generic-function method method-name)) (let (gf method name temp) (if (method-p spec) (setq method spec gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp (intern-function-name (make-method-spec temp (method-qualifiers method) (unparse-specializers (method-specializers method)))) (make-symbol (format nil "~S" method)))) (multiple-value-bind (gf-spec quals specls) (parse-defmethod spec) (and (setq gf (and (or errorp (gboundp gf-spec)) (gdefinition gf-spec))) (let ((nreq (compute-discriminating-function-arglist-info gf))) (setq specls (append (parse-specializers specls) (make-list (- nreq (length specls)) :initial-element *the-class-t*))) (and (setq method (get-method gf quals specls errorp)) (setq name (intern-function-name (make-method-spec gf-spec quals specls)))))))) (values gf method name))) (defun extract-parameters (specialized-lambda-list) (multiple-value-bind (parameters ignore1 ignore2) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2)) parameters)) (defun extract-lambda-list (specialized-lambda-list) (multiple-value-bind (ignore1 lambda-list ignore2) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2)) lambda-list)) (defun extract-specializer-names (specialized-lambda-list) (multiple-value-bind (ignore1 ignore2 specializers) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2)) specializers)) (defun extract-required-parameters (specialized-lambda-list) (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2 ignore3)) required-parameters)) (defun parse-specialized-lambda-list (arglist &optional post-keyword) ;;(declare (values parameters lambda-list specializers required-parameters)) (check-type arglist list) (let ((arg (car arglist))) (cond ((null arglist) (values nil nil nil nil)) ((eq arg '&aux) (values nil arglist nil)) ((memq arg lambda-list-keywords) (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) ;; Warn about non-standard lambda-list-keywords, but then ;; go on to treat them like a standard lambda-list-keyword ;; what with the warning its probably ok. (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ Assuming that the symbols following it are parameters,~%~ and not allowing any parameter specializers to follow~%~ to follow it." arg)) ;; When we are at a lambda-list-keyword, the parameters don't ;; include the lambda-list-keyword; the lambda-list does include ;; the lambda-list-keyword; and no specializers are allowed to ;; follow the lambda-list-keywords (at least for now). (multiple-value-bind (parameters lambda-list) (parse-specialized-lambda-list (cdr arglist) t) (values parameters (cons arg lambda-list) () ()))) (post-keyword ;; After a lambda-list-keyword there can be no specializers. (multiple-value-bind (parameters lambda-list) (parse-specialized-lambda-list (cdr arglist) t) (values (cons (if (listp arg) (car arg) arg) parameters) (cons arg lambda-list) () ()))) (t (multiple-value-bind (parameters lambda-list specializers required) (parse-specialized-lambda-list (cdr arglist)) (values (cons (if (listp arg) (car arg) arg) parameters) (cons (if (listp arg) (car arg) arg) lambda-list) (cons (if (and (listp arg) (listp (cdr arg))) (cadr arg) t) specializers) (cons (if (listp arg) (car arg) arg) required))))))) (eval-when (load eval) (setq *boot-state* 'early)) #-cmu ;; CMUCL Has a real symbol-macrolet (progn (defmacro symbol-macrolet (bindings &body body &environment env) (let ((specs (mapcar (lambda (binding) (when (or (si::specialp (car binding)) (constantp (car binding))) (error 'program-error));FIXME (list (car binding) (variable-lexical-p (car binding) env) (cadr binding))) bindings))) (do ((l body (cdr l))) ((or (atom (car l)) (not (eq (caar l) 'declare)))) (dolist (ll (cdar l)) (when (and (consp ll) (eq (car ll) 'special) (some (lambda (x) (assoc x bindings)) (cdr ll))) (error 'program-error))));FIXME (walk-form `(let nil ,@body) env (lambda (f c e) (expand-symbol-macrolet-internal specs f c e))))) (defun expand-symbol-macrolet-internal (specs form context env) (let ((entry nil)) (cond ((not (eq context :eval)) form) ((symbolp form) (if (and (setq entry (assoc form specs)) (eq (cadr entry) (variable-lexical-p form env))) (caddr entry) form)) ((not (listp form)) form) ((member (car form) '(setq setf psetq psetf));FIXME -- other setf forms? or real symbol-macrolet ;; Have to be careful. We must only convert the form to a SETF ;; form when we convert one of the 'logical' variables to a form ;; Otherwise we will get looping in implementations where setf ;; is a macro which expands into setq. (let ((kind (car form))) (labels ((scan-setf (tail) (when tail (walker::relist* tail (if (and (setq entry (assoc (car tail) specs)) (eq (cadr entry) (variable-lexical-p (car tail) env))) (progn (setq kind (if (eq kind 'psetf) kind 'setf)) (caddr entry)) (car tail)) (cadr tail) (scan-setf (cddr tail)))))) (let (new-tail) (setq new-tail (scan-setf (cdr form))) (let ((r (walker::recons form kind new-tail))) (if (eq (car form) 'psetq) `(progn ,r nil) r)))))) ((eq (car form) 'multiple-value-setq) (let* ((vars (cadr form)) (vars (mapcar (lambda (x) (let ((y (assoc x specs))) (if (and y (eq (cadr y) (variable-lexical-p x env))) (walker::macroexpand-all (caddr y) env) x))) vars)) (gensyms (mapcar (lambda (i) (declare (ignore i)) (gensym)) vars)) (pls (mapcan 'cdr (copy-tree (remove-if-not 'consp vars)))) (psyms (mapcar (lambda (x) (declare (ignore x)) (gensym)) pls)) (ppsyms psyms) (vars (mapcar (lambda (x) (if (atom x) x (cons (car x) (mapcar (lambda (x) (declare (ignore x)) (pop ppsyms)) (cdr x))))) vars))) `(let* ,(mapcar 'list psyms pls) (multiple-value-bind ,gensyms ,(caddr form) .,(reverse (mapcar (lambda (v g) `(setf ,v ,g)) vars gensyms)))))) ((eq (car form) 'restart-case) (let* ((nf (cadr form)) (nf (let ((y (assoc nf specs))) (if (and y (eq (cadr y) (variable-lexical-p nf env))) (walker::macroexpand-all (caddr y) env) nf)))) (if (eq nf (cadr form)) form `(,(car form) ,nf ,@(cddr form))))) ((eq (car form) 'symbol-macrolet) (walker::macroexpand-all form env));(macroexpand form env) ((eq 'si::macro (cadar (assoc (car form) env :key 'car)));(not (eq (car form) 'symbol-macrolet)) (let ((kind (car form))) (labels ((scan-setf (tail) (when tail (walker::relist* tail (if (and (setq entry (assoc (car tail) specs)) (eq (cadr entry) (variable-lexical-p (car tail) env))) (caddr entry) (car tail)) (scan-setf (cdr tail)))))) (walker::recons form kind (scan-setf (cdr form)))))) (form))))) ;; (defun expand-symbol-macrolet-internal (specs form context env) ;; (let ((entry nil)) ;; (cond ((not (eq context :eval)) form) ;; ((symbolp form) ;; (if (and (setq entry (assoc form specs)) ;; (eq (cadr entry) (variable-lexical-p form env))) ;; (caddr entry) ;; form)) ;; ((not (listp form)) form) ;; ((member (car form) '(setq setf psetq psetf));FIXME -- other setf forms? or real symbol-macrolet ;; ;; Have to be careful. We must only convert the form to a SETF ;; ;; form when we convert one of the 'logical' variables to a form ;; ;; Otherwise we will get looping in implementations where setf ;; ;; is a macro which expands into setq. ;; (let ((kind (car form))) ;; (labels ((scan-setf (tail) ;; (if (null tail) ;; nil ;; (walker::relist* ;; tail ;; (if (and (setq entry (assoc (car tail) specs)) ;; (eq (cadr entry) (variable-lexical-p (car tail) env))) ;; (progn (setq kind (if (eq kind 'psetf) kind 'setf)) ;; (caddr entry)) ;; (car tail)) ;; (cadr tail) ;; (scan-setf (cddr tail)))))) ;; (let (new-tail) ;; (setq new-tail (scan-setf (cdr form))) ;; (let ((r (walker::recons form kind new-tail))) (if (eq (car form) 'psetq) `(progn ,r nil) r)))))) ;; ((eq (car form) 'multiple-value-setq) ;; (let* ((vars (cadr form)) ;; (vars (mapcar (lambda (x) ;; (let ((y (assoc x specs))) ;; (if (and y (eq (cadr y) (variable-lexical-p x env))) (walker::macroexpand-all (caddr y) env) x))) vars)) ;; (gensyms (mapcar (lambda (i) (declare (ignore i)) (gensym)) vars)) ;; (pls (mapcan 'cdr (copy-tree (remove-if-not 'consp vars)))) ;; (psyms (mapcar (lambda (x) (declare (ignore x)) (gensym)) pls)) ;; (ppsyms psyms) ;; (vars (mapcar (lambda (x) (if (atom x) x (cons (car x) (mapcar (lambda (x) (declare (ignore x)) (pop ppsyms)) (cdr x))))) vars))) ;; `(let* ,(mapcar 'list psyms pls) ;; (multiple-value-bind ;; ,gensyms ;; ,(caddr form) ;; .,(reverse (mapcar (lambda (v g) `(setf ,v ,g)) vars gensyms)))))) ;; ((eq (car form) 'conditions::restart-case) ;; (let* ((nf (cadr form)) ;; (nf (let ((y (assoc nf specs))) ;; (if (and y (eq (cadr y) (variable-lexical-p nf env))) (walker::macroexpand-all (caddr y) env) nf)))) ;; (if (eq nf (cadr form)) form ;; `(,(car form) ,nf ,@(cddr form))))) ;; (t form))))) (defmacro with-slots (slots instance &body body) (declare (optimize (safety 2))) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) (third instance) instance))) (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) (let ((variable-name (if (symbolp slot-entry) slot-entry (car slot-entry))) (slot-name (if (symbolp slot-entry) slot-entry (cadr slot-entry)))) `(,variable-name (slot-value ,in ',slot-name)))) slots) ,@body)))) (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) (third instance) instance))) (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) (let ((variable-name (car slot-entry)) (accessor-name (cadr slot-entry))) `(,variable-name (,accessor-name ,in)))) slots) ,@body)))) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_cpl.lisp0000644000000000000000000000013114542551763015267 xustar0030 mtime=1703597043.364022997 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_cpl.lisp0000644000175000017500000002572214542551763014676 0ustar00cammcamm;;;-*-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.7.1/pcl/PaxHeaders/gcl_pcl_dlisp2.lisp0000644000000000000000000000013114575045345015706 xustar0030 mtime=1710508773.379731228 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_dlisp2.lisp0000644000175000017500000001407414575045345015313 0ustar00cammcamm;;;-*-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-reader/writer-function (reader/writer 1-or-2-class class-slot-p) (values (ecase reader/writer (:reader (ecase 1-or-2-class (1 (if class-slot-p (emit-reader/writer-macro :reader 1 t) (emit-reader/writer-macro :reader 1 nil))) (2 (if class-slot-p (emit-reader/writer-macro :reader 2 t) (emit-reader/writer-macro :reader 2 nil))))) (:writer (ecase 1-or-2-class (1 (if class-slot-p (emit-reader/writer-macro :writer 1 t) (emit-reader/writer-macro :writer 1 nil))) (2 (if class-slot-p (emit-reader/writer-macro :writer 2 t) (emit-reader/writer-macro :writer 2 nil)))))) nil)) (defun emit-one-or-n-index-reader/writer-function (reader/writer cached-index-p class-slot-p) (values (ecase reader/writer (:reader (if cached-index-p (if class-slot-p (emit-one-or-n-index-reader/writer-macro :reader t t) (emit-one-or-n-index-reader/writer-macro :reader t nil)) (if class-slot-p (emit-one-or-n-index-reader/writer-macro :reader nil t) (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) (:writer (if cached-index-p (if class-slot-p (emit-one-or-n-index-reader/writer-macro :writer t t) (emit-one-or-n-index-reader/writer-macro :writer t nil)) (if class-slot-p (emit-one-or-n-index-reader/writer-macro :writer nil t) (emit-one-or-n-index-reader/writer-macro :writer nil nil))))) nil)) (eval-when (compile load eval) (defparameter checking-or-caching-list '() #|| '((T NIL (CLASS) NIL) (T NIL (CLASS CLASS) NIL) (T NIL (CLASS CLASS CLASS) NIL) (T NIL (CLASS CLASS T) NIL) (T NIL (CLASS CLASS T T) NIL) (T NIL (CLASS CLASS T T T) NIL) (T NIL (CLASS T) NIL) (T NIL (CLASS T T) NIL) (T NIL (CLASS T T T) NIL) (T NIL (CLASS T T T T) NIL) (T NIL (CLASS T T T T T) NIL) (T NIL (CLASS T T T T T T) NIL) (T NIL (T CLASS) NIL) (T NIL (T CLASS T) NIL) (T NIL (T T CLASS) NIL) (T NIL (CLASS) T) (T NIL (CLASS CLASS) T) (T NIL (CLASS T) T) (T NIL (CLASS T T) T) (T NIL (CLASS T T T) T) (T NIL (T CLASS) T) (T T (CLASS) NIL) (T T (CLASS CLASS) NIL) (T T (CLASS CLASS CLASS) NIL) (NIL NIL (CLASS) NIL) (NIL NIL (CLASS CLASS) NIL) (NIL NIL (CLASS CLASS T) NIL) (NIL NIL (CLASS CLASS T T) NIL) (NIL NIL (CLASS T) NIL) (NIL NIL (T CLASS T) NIL) (NIL NIL (CLASS) T) (NIL NIL (CLASS CLASS) T)) ||# )) (defmacro make-checking-or-caching-function-list () `(list ,@(mapcar #'(lambda (key) `(cons ',key (emit-checking-or-caching-macro ,@key))) checking-or-caching-list))) (defvar checking-or-caching-function-list) (defun initialize-checking-or-caching-function-list () (setq checking-or-caching-function-list (make-checking-or-caching-function-list))) (initialize-checking-or-caching-function-list) (defmacro emit-checking-or-caching-function-precompiled () `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp) checking-or-caching-function-list :test #'equal))) (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) (let ((fn (emit-checking-or-caching-function-precompiled))) (if fn (values fn nil) (values (emit-checking-or-caching-function-preliminary cached-emf-p return-value-p metatypes applyp) t)))) (defvar not-in-cache (make-symbol "not in cache")) (defun emit-checking-or-caching-function-preliminary (cached-emf-p return-value-p metatypes applyp) (declare (ignore applyp)) (if cached-emf-p #'(lambda (cache miss-fn) (declare (type (function (t) nil) miss-fn)) (fin-lambda-fn (&rest args) (declare #.*optimize-speed*) #+copy-&rest-arg (setq args (copy-list args)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) (values (apply miss-fn args)) (if invalid-wrapper-p (values (apply miss-fn args)) (let ((emf (probe-cache cache dfun-wrappers not-in-cache))) (if (eq emf not-in-cache) (values (apply miss-fn args)) (if return-value-p emf (invoke-emf emf args)))))))) #'(lambda (cache emf miss-fn) (declare (type (function (t) nil) miss-fn)) (fin-lambda-fn (&rest args) (declare #.*optimize-speed*) #+copy-&rest-arg (setq args (copy-list args)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) (values (apply miss-fn args)) (if invalid-wrapper-p (values (apply miss-fn args)) (let ((found-p (not (eq not-in-cache (probe-cache cache dfun-wrappers not-in-cache))))) (if found-p (invoke-emf emf args) (if return-value-p t (values (apply miss-fn args))))))))))) (defun emit-default-only-function (metatypes applyp) (declare (ignore metatypes applyp)) (values #'(lambda (emf) #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (invoke-emf emf args))) t)) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_impl_low.lisp0000644000000000000000000000013114733440601016321 xustar0030 mtime=1735278977.090650063 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_impl_low.lisp0000644000175000017500000001474614733440601015734 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (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)) (defun %%allocate-instance--class (&aux wrapper slots) (let ((i (system:make-structure 'std-instance wrapper slots))) (c-set-t-tt i (logior 1 (c-t-tt i))) i)) (import '(si::memq) 'pcl) (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defun printing-random-thing-internal (thing stream) (format stream "~O" (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)) (si::freeze-defstruct 'pcl::std-instance) (si::freeze-defstruct 'method-call) (si::freeze-defstruct 'fast-method-call) (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) (declare (ignore y)) (and (symbolp x) (setf (get x 'compiler::proclaimed-closure ) t))) (import 'si::seqind) (defun %cclosure-env-nthcdr (n f) (function-env f n)) (defun cclosurep (x) (typep x 'function));(typecase x (compiled-function t))) (defun %cclosure-env (f) (function-env f 0)) (declaim (inline %cclosure-env-nthcdr cclosurep %cclosure-env)) (defconstant funcallable-instance-closure-size 15) (defun allocate-funcallable-instance-2 () (let (dummy) (declare (ignore dummy)) (lambda (&rest args) (declare (ignore args)) (setq dummy (make-dummy-var));use dummy to ensure freshly allocated closure (called-fin-without-function)))) (defun fun-to-funcallable-instance (fin);This cannot be inlines (c-set-t-tt fin (logior 1 (c-t-tt fin))) (the si::funcallable-std-instance fin)) (defun allocate-funcallable-instance-1 () (let ((fin (allocate-funcallable-instance-2)) (env (make-list funcallable-instance-closure-size :initial-element nil))) (si::set-function-environment fin env) (fun-to-funcallable-instance fin))) (defun funcallable-instance-p (x) (typep x 'funcallable-std-instance)) (defun std-instance-p (x) (typep x 'std-instance)) (declaim (inline std-instance-p funcallable-instance-p)) (remprop 'std-instance-p 'compiler::co1) (defun si:%structure-name (x) (si::lit :object "(" (:object x) ")->str.str_def->str.str_self[0]")) (defun %fboundp (x) (/= 0 (si::address (c-symbol-gfdef x)))) (declaim (inline si:%structure-name %fboundp)) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (typecase fn (function;compiled-function (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil)) (setf (si::call-name (c-function-plist fn)) new-name))) fn) (defun %set-cclosure (r v) (unless (typep r 'function) (error "Bad fn 1")) (unless (typep v 'function) (error "Bad fn 1")) (si::use-fast-links nil r) (progn (compiler::side-effects) (compiler::lit :object (:object r) "->fun.fun_self=" (:object v) "->fun.fun_self"));FIXME (c-set-function-minarg r (c-function-minarg v)) (c-set-function-maxarg r (c-function-maxarg v)) (c-set-function-neval r (c-function-neval v)) (c-set-function-vv r (c-function-vv v)) (c-set-function-data r (c-function-data v)) (c-set-function-plist r (c-function-plist v)) (c-set-function-argd r (c-function-argd v)) (mapl (lambda (x y) (setf (car x) (car y))) (%cclosure-env r) (%cclosure-env v))) (defun structure-functions-exist-p nil t) (defun structure-instance-p (x) (typep x 'structure)) (declaim (inline structure-instance-p)) ;; (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) (typecase x (structure (si:%structure-name x))));FIXME type-of (declaim (inline structure-type)) ;; (defun structure-type (x) ;; (and (si:structurep x) ;; (si:%structure-name x))) ;; (define-compiler-macro structure-type (x) ;; (once-only (x) ;; `(and (si:structurep ,x) ;; (si:%structure-name ,x)))) (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)))) (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))) (setf (symbol-function reader-sym) reader) (setf (symbol-function writer-sym) writer) (do-standard-defsetf-1 reader-sym) (list (list slot-name (find-symbol (concatenate 'string (symbol-name type) "-" (symbol-name slot-name)) (or (symbol-package type) *package*)) reader-sym writer (third slotd) (second 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))))) (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)) (defun structure-slotd-type (slotd) (fifth slotd)) (defun structure-slotd-init-form (slotd) (sixth slotd)) (defun renew-sys-files nil ;; packages: (compiler::get-packages-ansi '(:walker :iterate :pcl :slot-accessor-name) "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\") ")) (si::do-recomp2 "sys-proclaim.lisp" (mapcar 'namestring (directory "*.*p")))) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_fixup.lisp0000644000000000000000000000013014542551763015643 xustar0029 mtime=1703597043.37202301 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_fixup.lisp0000644000175000017500000000262414542551763015247 0ustar00cammcamm;;;-*-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-early-generic-functions) (setq *boot-state* 'complete) #+Lispm (eval-when (load eval) (si:record-source-file-name 'print-std-instance 'defun 't)) (defun print-std-instance (instance stream depth) (declare (ignore depth)) (print-object instance stream)) gcl-2.7.1/pcl/PaxHeaders/gcl_pcl_macros.lisp0000644000000000000000000000013114733440601015763 xustar0030 mtime=1735278977.090650063 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/pcl/gcl_pcl_macros.lisp0000644000175000017500000006356314733440601015377 0ustar00cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; Copyright (c) 2024 Camm Maguire ;;; 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) (import '(si::memq) 'pcl) ;(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 (ignore environment)) (multiple-value-bind (doc decls ctps body) (si::parse-body-header body) (values doc decls (nconc ctps 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. ;;; ; FIXME use regular destructuring-bind ;; #+gcl(setf (macro-function 'pcl-destructuring-bind) (macro-function 'destructuring-bind)) ;; #-gcl ;; (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 'program-error :format-control "Malformed plist in doplist, odd number of elements.")) (when (not (symbolp ,key)) (error 'program-error :format-control "Supplied key is not a symbol.")) (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) #+(or cmu17 gcl) `(print-unreadable-object (,thing ,stream :identity t) ,@body) #-(or cmu17 gcl) (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 ">")))) #-gcl(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) #+gcl(defvar *structure-table* (make-hash-table :test 'eq)) #+gcl(defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let ((s-data nil)) (and (symbolp type) (setq s-data (get type 'si::s-data)) (null (si::s-data-type s-data)))))) (defun find-class-from-cell (symbol cell &optional (errorp t)) (or (find-class-cell-class cell) (and *create-classes-from-internal-structure-definitions-p* (fboundp 'find-structure-class) (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) (symbolp 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. #+(or gcl 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 &optional errorp environment) (declare (ignore errorp environment)) (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)))) new-value) (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))) ;; FIXME remove this when all is well (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 (funcall #',setf-function-name ,(car (last form)) ,@vars))))) (format t "defsetfinf ~S~%" `(defsetf ,function-name ,helper)) (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.7.1/PaxHeaders/gcl-tk0000644000000000000000000000013214776130457012466 xustar0030 mtime=1744351535.594908214 30 atime=1744351538.814879383 30 ctime=1744351535.594908214 gcl-2.7.1/gcl-tk/0000755000175000017500000000000014776130457012141 5ustar00cammcammgcl-2.7.1/gcl-tk/PaxHeaders/guis.c0000644000000000000000000000013214555557372013662 xustar0030 mtime=1706483450.788392733 30 atime=1744340056.024936335 30 ctime=1744351535.570908429 gcl-2.7.1/gcl-tk/guis.c0000644000175000017500000002637714555557372013277 0ustar00cammcamm/* Copyright (C) 1994 Rami el Charif, W. Schelter Copyright (C) 2024 Camm Maguire 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(); } gcl-2.7.1/gcl-tk/PaxHeaders/gcltksrv.in0000644000000000000000000000013214776006046014726 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.438909613 gcl-2.7.1/gcl-tk/gcltksrv.in0000755000175000017500000000113614776006046014330 0ustar00cammcamm#!/bin/sh TK_XLIB_DIR=@TK_XLIB_DIR@ 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=@TK_LIBRARY@ 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=@TCL_LIBRARY@ if [ -f ${TCL_LIBRARY}/init.tcl ] ; then export TCL_LIBRARY ; fi fi if [ $# -ge 4 ] ;then DISPLAY=$4 ; export DISPLAY; fi exec $(dirname $0)/gcltkaux $1 $2 $3 gcl-2.7.1/gcl-tk/PaxHeaders/comm.c0000644000000000000000000000013214770537327013643 xustar0030 mtime=1742913239.922489134 30 atime=1744339828.959500935 30 ctime=1744351535.594908214 gcl-2.7.1/gcl-tk/comm.c0000755000175000017500000001601614770537327013250 0ustar00cammcamm #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",object,fScheck_fd_for_input,SI,2,2,NONE,II,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 (object)-1; else if (FD_ISSET(fd, &inp)) return (object)1; else return (object)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 (((fixnum)(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; } } return 0; } /* 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("CLEAR-CONNECTION",object,fSclear_connection,SI,1,1,NONE,II,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 ((fixnum)(FFN(fScheck_fd_for_input)(fd,0))) n+=read(fd,buffer,sizeof(buffer)); return (object)(fixnum)n; } #ifdef STATIC_FUNCTION_POINTERS object fSclear_connection(fixnum fd) { return FFN(fSclear_connection)(fd); } #endif gcl-2.7.1/gcl-tk/PaxHeaders/gcl.tcl0000644000000000000000000000013114774534126014012 xustar0030 mtime=1743960150.152924817 29 atime=1744294997.75795256 30 ctime=1744351535.410909864 gcl-2.7.1/gcl-tk/gcl.tcl0000755000175000017500000000257614774534126013426 0ustar00cammcamm # 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.7.1/gcl-tk/PaxHeaders/tkAppInit.c0000644000000000000000000000013214542551763014610 xustar0030 mtime=1703597043.064022526 30 atime=1744340056.024936335 30 ctime=1744351535.570908429 gcl-2.7.1/gcl-tk/tkAppInit.c0000755000175000017500000000703514542551763014216 0ustar00cammcamm/* * 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.7.1/gcl-tk/PaxHeaders/guis.h0000644000000000000000000000013214542551763013661 xustar0030 mtime=1703597043.064022526 30 atime=1744340056.028936361 30 ctime=1744351535.570908429 gcl-2.7.1/gcl-tk/guis.h0000755000175000017500000000336514542551763013271 0ustar00cammcamm#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.7.1/gcl-tk/PaxHeaders/tkMain.c0000644000000000000000000000013214753165412014124 xustar0030 mtime=1739385610.873119866 30 atime=1744340056.024936335 30 ctime=1744351535.570908429 gcl-2.7.1/gcl-tk/tkMain.c0000644000175000017500000004463714753165412013540 0ustar00cammcamm/* * 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. * Copyright (c) 2024 Camm Maguire * 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 TCL_MAJOR_VERSION >= 9 #include #endif #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)); */ extern int Tcl_AppInit(Tcl_Interp *interp); /* * 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] ; snprintf(buf,sizeof(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, (void *)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) { char *fullName; FILE *f; #if TCL_MAJOR_VERSION >= 9 wordexp_t exp_result; wordexp(tcl_RcFileName, &exp_result, WRDE_NOCMD); fullName = exp_result.we_wordv[0]; #else Tcl_DString buffer; fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer); #endif 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); } } #if TCL_MAJOR_VERSION >= 9 wordfree(&exp_result); #else Tcl_DStringFree(&buffer); #endif } dfprintf(stderr, "guis : Creating file handler for %d\n", dsfd->fd); #ifndef __MINGW32__ Tcl_CreateFileHandler(dsfd->fd, TCL_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); /* Tcl_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__ Tcl_CreateFileHandler(dsfd->fd, TCL_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 = fScheck_dsfd_for_input(dsfd,0); if (fNotDone > 0) { dfprintf(stderr, "\nguis : in StdinProc, not done, executed %s" , msg->body); } } while (fNotDone > 0); /* Tcl_CreateFileHandler(dsfd->fd, TCL_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.7.1/gcl-tk/PaxHeaders/tk-package.lsp0000644000000000000000000000013014542551763015266 xustar0030 mtime=1703597043.064022526 30 atime=1744340055.352932045 28 ctime=1744351535.4069099 gcl-2.7.1/gcl-tk/tk-package.lsp0000755000175000017500000000160014542551763014666 0ustar00cammcamm(unless (find-package "TK") (make-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.7.1/gcl-tk/PaxHeaders/sheader.h0000644000000000000000000000013114566141714014321 xustar0030 mtime=1708704716.158218088 29 atime=1744339828.95550091 30 ctime=1744351535.518908896 gcl-2.7.1/gcl-tk/sheader.h0000755000175000017500000000577614566141714013742 0ustar00cammcamm #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 ? 1 : (fixnum)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.7.1/gcl-tk/PaxHeaders/tinfo.lsp0000644000000000000000000000013214776006046014376 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.426909721 gcl-2.7.1/gcl-tk/tinfo.lsp0000755000175000017500000004501514776006046014004 0ustar00cammcamm;; 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 ,(ecase op (>= 'boolean)((+ -) '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 'character :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.7.1/gcl-tk/PaxHeaders/tkl.lisp0000644000000000000000000000013214776006046014222 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.286035001 30 ctime=1744351535.426909721 gcl-2.7.1/gcl-tk/tkl.lisp0000644000175000017500000014000614776006046013621 0ustar00cammcamm;; Copyright (C) 1994 W. Schelter ;; Copyright (C) 2024 Camm Maguire ;; 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 (grab-tk-command)) (*command-strings* *command-strings*)) (declare (string 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 'character :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 (eval `(lambda ,*percent-symbols-used* ,command))) (if ans (setq name (concatenate 'string "{"name " " ans"}")))) (t (setq command (eval `(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.7.1/gcl-tk/PaxHeaders/demos0000644000000000000000000000012614776130457013600 xustar0028 mtime=1744351535.4069099 30 atime=1744351538.814879383 28 ctime=1744351535.4069099 gcl-2.7.1/gcl-tk/demos/0000755000175000017500000000000014776130457013250 5ustar00cammcammgcl-2.7.1/gcl-tk/demos/PaxHeaders/mkLabel.lisp0000644000000000000000000000013114542551763016107 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.853822209 30 ctime=1744351535.398909972 gcl-2.7.1/gcl-tk/demos/mkLabel.lisp0000755000175000017500000000312414542551763015511 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkRuler.lisp0000644000000000000000000000013114542551763016161 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.857822234 30 ctime=1744351535.402909936 gcl-2.7.1/gcl-tk/demos/mkRuler.lisp0000755000175000017500000001214614542551763015567 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkForm.lisp0000644000000000000000000000013114542551763015773 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.853822209 30 ctime=1744351535.398909972 gcl-2.7.1/gcl-tk/demos/mkForm.lisp0000755000175000017500000000363314542551763015402 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkEntry2.lisp0000644000000000000000000000013114542551763016253 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.849822185 30 ctime=1744351535.398909972 gcl-2.7.1/gcl-tk/demos/mkEntry2.lisp0000755000175000017500000000477514542551763015672 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkCanvText.lisp0000644000000000000000000000013114542551763016624 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.849822185 30 ctime=1744351535.394910007 gcl-2.7.1/gcl-tk/demos/mkCanvText.lisp0000755000175000017500000001162514542551763016233 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/nqthm-stack.lisp0000644000000000000000000000013014542551763016771 xustar0030 mtime=1703597043.064022526 30 atime=1744346651.861822259 28 ctime=1744351535.4069099 gcl-2.7.1/gcl-tk/demos/nqthm-stack.lisp0000755000175000017500000000505114542551763016375 0ustar00cammcamm(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 #+anci-cl cl-user::do-frames #-ansi-cl user::do-frames) :command #+ansi-cl '(cl-user::MAINTAIN-REWRITE-PATH cl-user::do-frames) #-ansi-cl '(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))) #+ansi-cl(in-package "CL-USER") #-ansi-cl(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 #+ansi-cl cl-user::REWRITE-PATH-STK-PTR #-ansi-cl user::REWRITE-PATH-STK-PTR do (setq tem (aref #+ansi-cl cl-user::REWRITE-PATH-STK #-ansi-cl 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.7.1/gcl-tk/demos/PaxHeaders/mkStyles.lisp0000644000000000000000000000013114542551763016353 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.857822234 30 ctime=1744351535.402909936 gcl-2.7.1/gcl-tk/demos/mkStyles.lisp0000755000175000017500000001215714542551763015763 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/widget.lisp0000644000000000000000000000013014542551763016022 xustar0030 mtime=1703597043.064022526 30 atime=1744346651.861822259 28 ctime=1744351535.4069099 gcl-2.7.1/gcl-tk/demos/widget.lisp0000755000175000017500000002440414542551763015431 0ustar00cammcamm (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.7.1/gcl-tk/demos/PaxHeaders/mkRadio.lisp0000644000000000000000000000013114542551763016126 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.857822234 30 ctime=1744351535.402909936 gcl-2.7.1/gcl-tk/demos/mkRadio.lisp0000755000175000017500000000577314542551763015544 0ustar00cammcamm(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.7.1/gcl-tk/demos/PaxHeaders/mkPlot.lisp0000644000000000000000000000013114542551763016006 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.857822234 30 ctime=1744351535.402909936 gcl-2.7.1/gcl-tk/demos/mkPlot.lisp0000755000175000017500000000555114542551763015416 0ustar00cammcamm(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.7.1/gcl-tk/demos/PaxHeaders/mkListbox.lisp0000644000000000000000000000013114542551763016514 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.857822234 30 ctime=1744351535.402909936 gcl-2.7.1/gcl-tk/demos/mkListbox.lisp0000755000175000017500000000336714542551763016127 0ustar00cammcamm(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.7.1/gcl-tk/demos/PaxHeaders/mkVScale.lisp0000644000000000000000000000012714542551763016252 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.861822259 28 ctime=1744351535.4069099 gcl-2.7.1/gcl-tk/demos/mkVScale.lisp0000755000175000017500000000300114542551763015641 0ustar00cammcamm(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.7.1/gcl-tk/demos/PaxHeaders/mkTextBind.lisp0000644000000000000000000000012714542551763016616 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.861822259 28 ctime=1744351535.4069099 gcl-2.7.1/gcl-tk/demos/mkTextBind.lisp0000755000175000017500000001005014542551763016207 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkItems.lisp0000644000000000000000000000013114542551763016151 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.853822209 30 ctime=1744351535.398909972 gcl-2.7.1/gcl-tk/demos/mkItems.lisp0000755000175000017500000003532214542551763015560 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/gc-monitor.lisp0000644000000000000000000000013214776006046016615 xustar0030 mtime=1744309286.154034363 30 atime=1744309286.282034981 30 ctime=1744351535.394910007 gcl-2.7.1/gcl-tk/demos/gc-monitor.lisp0000755000175000017500000001214214776006046016216 0ustar00cammcamm ;; 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 (si::seqind 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 si::seqind (+ 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)))) (maxpage (aref ar (setq i(+ i 1)))) (nppage (aref ar (setq i(+ i 1)))) (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 si::seqind (- tot (the si::seqind nfree))))) tot)))) (declare (si::seqind 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* (si::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.7.1/gcl-tk/demos/PaxHeaders/mkSearch.lisp0000644000000000000000000000013114542551763016275 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.857822234 30 ctime=1744351535.402909936 gcl-2.7.1/gcl-tk/demos/mkSearch.lisp0000755000175000017500000001161314542551763015701 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkBasic.lisp0000644000000000000000000000013114542551763016111 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.849822185 30 ctime=1744351535.394910007 gcl-2.7.1/gcl-tk/demos/mkBasic.lisp0000755000175000017500000000535314542551763015521 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkHScale.lisp0000644000000000000000000000013114542551763016227 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.853822209 30 ctime=1744351535.398909972 gcl-2.7.1/gcl-tk/demos/mkHScale.lisp0000755000175000017500000000300414542551763015626 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/showVars.lisp0000644000000000000000000000013014542551763016353 xustar0030 mtime=1703597043.064022526 30 atime=1744346651.861822259 28 ctime=1744351535.4069099 gcl-2.7.1/gcl-tk/demos/showVars.lisp0000755000175000017500000000210514542551763015754 0ustar00cammcamm(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.7.1/gcl-tk/demos/PaxHeaders/mkEntry.lisp0000644000000000000000000000013114542551763016171 xustar0029 mtime=1703597043.06002252 30 atime=1744346651.853822209 30 ctime=1744351535.398909972 gcl-2.7.1/gcl-tk/demos/mkEntry.lisp0000755000175000017500000000331014542551763015570 0ustar00cammcamm;;# 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.7.1/gcl-tk/demos/PaxHeaders/mkdialog.lisp0000644000000000000000000000013214542551763016330 xustar0030 mtime=1703597043.064022526 30 atime=1744346651.849822185 30 ctime=1744351535.398909972 gcl-2.7.1/gcl-tk/demos/mkdialog.lisp0000755000175000017500000000475114542551763015740 0ustar00cammcamm;;# 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.7.1/PaxHeaders/o0000644000000000000000000000013214776130457011543 xustar0030 mtime=1744351535.598908178 30 atime=1744351538.814879383 30 ctime=1744351535.598908178 gcl-2.7.1/o/0000755000175000017500000000000014776130457011216 5ustar00cammcammgcl-2.7.1/o/PaxHeaders/usig2_aux.c0000644000000000000000000000013114565740505013666 xustar0030 mtime=1708638533.125567798 30 atime=1744339828.251496512 29 ctime=1744351535.59090825 gcl-2.7.1/o/usig2_aux.c0000644000175000017500000000201414565740505013262 0ustar00cammcammXSI(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(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); XSI(left_trim); XSI(right_trim); XS(lex_env); XS(key_function); XS(test_function); XS(item_compared); XSI(intern_flag); XS(sfaslp); XSI(preserving_whitespace_flag); XS(sharing_table); XSI(string_sign); XSI(string_boundary); 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.7.1/o/PaxHeaders/hash.d0000644000000000000000000000013114555557372012713 xustar0029 mtime=1706483450.80039273 30 atime=1744340056.088936744 30 ctime=1744351535.574908393 gcl-2.7.1/o/hash.d0000644000175000017500000004252714555557372012324 0ustar00cammcamm/*-*-C-*-*/ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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. */ /* hash.d 06/2005 Update Boyer & Hunt For a number of reasons, we have modified this file from its long-standing form to improve the performance of the Common Lisp GETHASH and the SETHASH procedures. These changes extend to the GCL header file "h/object.h" where we included an additional field. In the spirit of the comment just above, we have attempted to write down some observations, comments, and invariants, about the modified code contained in this file. The two C-code procedures that were substantially modified are "gethash" and "sethash", which in turn, required additional changes to be made in "make_hash_table" and "extend_hashtable". - We never allow a hashtable to become completely full -- no matter what the REHASH-THRESHOLD is; we require that there is always at least one empty table entry. */ #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; 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); } #define ihash_equal(a_,b_) ((type_of(a_)==t_symbol && (a_)->s.s_hash) ? (a_)->s.s_hash : ihash_equal1(a_,b_)) ufixnum ihash_equal1(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[labs(depth%(sizeof(rtb)/sizeof(*rtb)))]; x = x->c.c_cdr; goto BEGIN; break; case t_symbol: x=coerce_to_string(x); case t_simple_string: case t_string: h^=uarrhash(x->st.st_self,x->st.st_self+VLEN(x),0,0); break; case t_package: break; case t_bitvector: case t_simple_bitvector: { ufixnum *u=x->bv.bv_self+x->bv.bv_offset/BV_BITS; ufixnum *ue=x->bv.bv_self+(VLEN(x)+x->bv.bv_offset)/BV_BITS; uchar s=x->bv.bv_offset%BV_BITS; uchar m=((VLEN(x)+x->bv.bv_offset)%BV_BITS); for (;u>s; if (upn.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("HASH-EQUAL",object,fShash_equal,SI,2,2,NONE,IO,IO,OO,OO,(object x,fixnum depth),"") { return (object)ihash_equal(x,depth); } #define ihash_equalp(a_,b_) ((type_of(a_)==t_symbol && (a_)->s.s_hash) ? (a_)->s.s_hash : ihash_equalp1(a_,b_)) unsigned long ihash_equalp1(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)^rtb[labs(depth%(sizeof(rtb)/sizeof(*rtb)))]; x = x->c.c_cdr; goto BEGIN; break; case t_symbol: x=coerce_to_string(x); case t_simple_string: case t_string: { ufixnum len=VLEN(x); uchar *s=(void *)x->st.st_self; for (;len--;) h^=rtb[toupper(*s++)]; } break; case t_package: break; case t_bitvector: case t_simple_bitvector: { ufixnum *u=x->bv.bv_self+x->bv.bv_offset/BV_BITS; ufixnum *ue=x->bv.bv_self+(VLEN(x)+x->bv.bv_offset)/BV_BITS; uchar s=x->bv.bv_offset%BV_BITS; uchar m=((VLEN(x)+x->bv.bv_offset)%BV_BITS); for (;u>s; if (u10 ? 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].c_cdr!=OBJNULL) switch (x->ht.ht_test) { case htt_eq: h^=(((unsigned long)x->ht.ht_self[i].c_cdr)>>3) ^ ihash_equalp(x->ht.ht_self[i].c_car,depth); break; case htt_eql: h^=hash_eql(x->ht.ht_self[i].c_cdr) ^ ihash_equalp(x->ht.ht_self[i].c_car,depth); break; case htt_equal: h^=ihash_equal(x->ht.ht_self[i].c_cdr,depth) ^ ihash_equalp(x->ht.ht_self[i].c_car,depth); break; case htt_equalp: h^=ihash_equalp(x->ht.ht_self[i].c_cdr,depth) ^ ihash_equalp(x->ht.ht_self[i].c_car,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: h^=rtb[toupper(x->ch.ch_code)]; break; default: h^=hash_eql(x); break; } return MHSH(h); } DEFUN("HASH-EQUALP",object,fShash_equalp,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum depth),"") { RETURN1(make_fixnum(ihash_equalp(x,depth))); } /* gethash Here are conditions on the two inputs, key and hashtable, and the value returned. Condition 1. key may not be OBJNULL. Definition. i is an "open" location in hashtable iff its key slot holds OBJNULL. Condition 2. There is an open location in hashtable. Definition. i is an "initially open" location in hashtable iff it is open and furthermore its value slot also holds OBJNULL. Condition 3. If there is an entry for key in hashtable, then starting at the "init_hash_index" location of hashtable for key and searching to the top of the hashtable, and then wrapping to start the search at the beginning of the hashtable, will find the entry for key before encountering an initially open location. (What this means in practice is that remhash must set the value field to something other than OBJNULL, e.g., to NIL.) Output condition. If there is an entry in hashtable whose key slot holds key, then the value returned is the address of that entry. On the otherhand, if there is no entry in hashtable whose key slot holds key, then the value returned is the first open (not necessarily intially open) slot encounterd starting at the hkey generated for key, and wrappping if necessary. */ struct cons * gethash(object key, object ht) { long s,q; struct cons *e,*ee,*first_open=NULL; static struct cons dummy={OBJNULL,OBJNULL}; if (ht->ht.ht_cache && ht->ht.ht_cache->c_cdr==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;ec_cdr; \ if (hkey==OBJNULL) { \ if (e->c_car==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 hashtable) { object old; fixnum new_size=0,new_max_ent=0,i; struct cons *hte; /* Compute new size for the larger hashtable */ new_size=hashtable->ht.ht_size+1; switch (type_of(hashtable->ht.ht_rhsize)) { case t_fixnum: new_size *= fix(hashtable->ht.ht_rhsize); break; case t_shortfloat: new_size *= sf(hashtable->ht.ht_rhsize); break; case t_longfloat: new_size *= lf(hashtable->ht.ht_rhsize); break; } /* Compute the maximum number of entries */ switch (type_of(hashtable->ht.ht_rhthresh)) { case t_fixnum: new_max_ent = fix(hashtable->ht.ht_rhthresh) + ( new_size - hashtable->ht.ht_size ); break; case t_shortfloat: new_max_ent = (fixnum)(( new_size * sf(hashtable->ht.ht_rhthresh)) + 0.5 ); break; case t_longfloat: new_max_ent = (fixnum)(( new_size * lf(hashtable->ht.ht_rhthresh)) + 0.5 ); break; } if (new_max_ent>=new_size || new_max_ent<=0) new_max_ent = new_size - 1; { 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 = (struct cons *)alloc_relblock(new_size * sizeof(struct cons)); for (i = 0; i < new_size; i++) { hashtable->ht.ht_self[i].c_cdr = OBJNULL; hashtable->ht.ht_self[i].c_car = OBJNULL; } for (i=0;iht.ht_size;i++) if (old->ht.ht_self[i].c_cdr != OBJNULL) { hte = gethash(old->ht.ht_self[i].c_cdr, hashtable); /* Initially empty, only empty locations. */ hte->c_cdr = old->ht.ht_self[i].c_cdr; hte->c_car = old->ht.ht_self[i].c_car; } hashtable->ht.ht_nent = old->ht.ht_nent; hashtable->ht.ht_max_ent = new_max_ent; vs_popp; END_NO_INTERRUPT; } } void sethash(object key, object hashtable, object value) { struct cons *e; if (hashtable->ht.ht_nent+1>=hashtable->ht.ht_max_ent) extend_hashtable(hashtable); e = gethash(key, hashtable); if (e->c_cdr == OBJNULL) hashtable->ht.ht_nent++; e->c_cdr = key; e->c_car = value; } DEFUN("MAKE-HASH-TABLE-INT",object,fSmake_hash_table_int,SI,5,5,NONE,OO,OO,OO,OO, (object test,object size,object rehash_size, object rehash_threshold,object staticp),"") { enum httest htt=0; fixnum i,max_ent=0,err; object h; 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 || fix(size)<0) FEerror("~S is an illegal hash-table size.", 1, size); err=0; switch(type_of(rehash_size)) { case t_fixnum: if (fix(rehash_size)<=0) err=1; break; case t_shortfloat: if (sf(rehash_size)<=1.0) err=1; break; case t_longfloat: if (lf(rehash_size)<=1.0) err=1; break; default: err=1; } if (err) FEerror("~S is an illegal hash-table rehash-size.",1, rehash_size); err=0; switch(type_of(rehash_threshold)) { case t_fixnum: max_ent=fix(rehash_threshold); if (max_ent<0 || max_ent>fix(size)) err=1; break; case t_shortfloat: BLOCK_EXCEPTIONS(max_ent=sf(rehash_threshold)*fix(size)+0.5); if (sf(rehash_threshold)<0.0 || sf(rehash_threshold)>1.0) err=1; break; case t_longfloat: BLOCK_EXCEPTIONS(max_ent=lf(rehash_threshold)*fix(size)+0.5); if (lf(rehash_threshold)<0.0 || lf(rehash_threshold)>1.0) err=1; break; case t_ratio: { double d=number_to_double(rehash_threshold); max_ent=(fixnum)(d*fix(size)+0.5); if (d<0.0 || d>1.0) err=1; break; } default: err=1; break; } if (err) FEerror("~S is an illegal hash-table rehash-threshold.",1,rehash_threshold); { BEGIN_NO_INTERRUPT; h = alloc_object(t_hashtable); h->ht.tt=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_max_ent = max_ent; h->ht.ht_static=staticp==Cnil ? 0 : 1; h->ht.ht_self = NULL; h->ht.ht_self = h->ht.ht_static ? (struct cons *)alloc_contblock(fix(size) * sizeof(struct cons)) : (struct cons *)alloc_relblock(fix(size) * sizeof(struct cons)); for(i = 0; i < fix(size); i++) { h->ht.ht_self[i].c_cdr = OBJNULL; h->ht.ht_self[i].c_car = OBJNULL; } END_NO_INTERRUPT; } RETURN1(h); } 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),""); object gcl_make_hash_table(object test) { return FFN(fSmake_hash_table_int)(test, sSAdefault_hash_table_sizeA->s.s_dbind, sSAdefault_hash_table_rehash_sizeA->s.s_dbind, sSAdefault_hash_table_rehash_thresholdA->s.s_dbind, Cnil); } DEFUN("GCL-MAKE-HASH-TABLE",object,fSgcl_make_hash_table,SI,1,1,NONE,OO,OO,OO,OO,(object test),"") { return gcl_make_hash_table(test); } DEFUN("GETHASH-INT",object,fSgethash_int,SI,2,2,NONE,IO,OO,OO,OO,(object x,object y),"") { return (object)gethash(x,y); } DEFUN("EXTEND-HASHTABLE",object,fSextent_hashtable,SI,1,1,NONE,IO,OO,OO,OO,(object table),"") { extend_hashtable(table); return (object)(fixnum)table->ht.ht_size; } void gcl_init_hash() { ufixnum i; 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"); { object x=find_symbol(make_simple_string("MOST-NEGATIVE-FIXNUM"),system_package); x=number_negate(x->s.s_dbind); for (i=0;i=0;u=0,o=o && f=0;u=0,o=o && fst.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) #define trt(c) (READtable->rt.rt_self[char_code((c))] \ .rte_chatrait) static void setup_READtable() { READtable = current_readtable(); } /* 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; static int inlp; 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; READeval = symbol_value(sLAread_evalA) != Cnil; sSAsharp_eq_contextA->s.s_dbind=Cnil; backq_level = 0; PP0=P0; LP=NULL; inlp=0; } object read_char(in) object in; { return(code_char(readc_stream(in))); } static object read_char_no_echo(object in) { int c; if (type_of(in)==t_stream && in->sm.sm_mode==smm_echo) { c = readc_stream(STREAM_INPUT_STREAM(in)); if (ECHO_STREAM_N_UNREAD(in) != 0) --(ECHO_STREAM_N_UNREAD(in)); return(code_char(c)); } else 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; bool old_READeval = READeval; /* 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; READeval = symbol_value(sLAread_evalA) != 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; READeval = old_READeval; /* 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; int old_READeval; object old_READcontext; int old_backq_level; old_READtable = READtable; old_READdefault_float_format = READdefault_float_format; old_READbase = READbase; old_READsuppress = READsuppress; old_READeval = READeval; 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 (fLinteractive_stream_p(in)!=Cnil && 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; READeval = old_READeval; 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 && stream_at_end(in)) { eof_code;} \ res = code_char(ch); \ }} while(0) #define read_char_to2(in,eof_code) \ ({FILE *fp=in->sm.sm_fp;int ch; \ fp ? \ ((ch=getc(fp))==EOF && feof(fp) ? ({eof_code;Cnil;}) : code_char(ch)) : \ (stream_at_end(in) || ((ch=readc_stream(in))==EOF && stream_at_end(in)) ? \ ({eof_code;Cnil;}) : code_char(ch));}) #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. */ 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); delimiting_char = vs_head; if (delimiting_char != OBJNULL && c == delimiting_char) { delimiting_char = OBJNULL; vs_reset; LP=NULL; 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); LP=NULL; 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 = READsuppress ? Cnil : vs_base[0]; /*FIXME, centralize here rather than in reader macros ??*/ 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 { if (trt(c)==trait_invalid) READER_ERROR(in,"Cannot read character"); 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; READER_ERROR(in,"Dots appeared illegally."); } N: token->st.st_fillp = length; if (escape_flag || (READbase<=10 && token_buffer[0]>'9')) goto SYMBOL; null_terminate_token(); x = parse_number(in,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); vs_reset; return(x); } static void Lleft_parenthesis_reader() { object in, x; object *p; check_arg(2); in = vs_base[0]; vs_head = Cnil; p = &vs_head; inlp=1; 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; } for (;;) { delimiting_char = code_char(')'); in_list_flag = TRUE; x = read_object(in); if (x == OBJNULL) goto ENDUP; 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 = 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."); goto ENDUP; } vs_push(x); *p = make_cons(x, Cnil); vs_popp; p = &((*p)->c.c_cdr); } ENDUP: if (PP0>P0) PP0--; vs_base[0] = vs_pop; inlp=0; return; } /* 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);/*FIXME continue*/ 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 && !(READsuppress && cat(c)==cat_non_terminating)) { unread_char(c, in); break; } j = char_code(c); token_buffer[i++] = j; } FIN: token->st.st_fillp = i; } DEFUN("DOUBLE-QUOTE-READER",object,fSdouble_quote_reader,SI,2,2,NONE,OO,OO,OO,OO, (object s,object c),"") { read_string(char_code(c),s); RETURN1(copy_simple_string(token)); } /* static void */ /* Ldouble_quote_reader() */ /* { */ /* object c; */ /* check_arg(2); */ /* c=vs_base[1]; */ /* vs_popp; */ /* read_string(char_code(c), 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(in,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); } DEFUN("SINGLE-QUOTE-READER",object,fSsingle_quote_reader,SI,2,2,NONE,OO,OO,OO,OO, (object s,object c),"") { RETURN1(MMcons(sLquote,MMcons(read_object(s),Cnil))); } /* static void */ /* Lsingle_quote_reader() */ /* { */ /* check_arg(2); */ /* vs_popp; */ /* vs_push(sLquote); */ /* vs_push(read_object(vs_base[0])); */ /* vs_push(Cnil); */ /* stack_cons(); */ /* stack_cons(); */ /* vs_base[0] = vs_pop; */ /* } */ DEFUN("RIGHT-PARENTHESIS-READER",object,fSright_parenthesis_reader,SI,2,2,NONE,OO,OO,OO,OO, (object s,object c),"") { if (!inlp) READER_ERROR(vs_base[0],"Right paren found with no left."); RETURN1(Cnil); } /* static void */ /* Lright_parenthesis_reader() */ /* { */ /* check_arg(2); */ /* if (!inlp) */ /* READER_ERROR(vs_base[0],"Right paren found with no left."); */ /* vs_popp; */ /* vs_popp; */ /* /\* no result *\/ */ /* } */ /* Lcomma_reader(){} */ DEFUNM("SEMICOLON-READER",object,fSsemicolon_reader,SI,2,2,NONE,OO,OO,OO,OO, (object str,object c),"") { fixnum vals=fcall.valp; object *base=vs_top; do { read_char_to(c,str, goto L); } while (char_code(c) != '\n'); L: RETURN0; } /* 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); DEFUN("SHARP-C-READER",object,fSsharp_c_reader,SI,3,3,NONE,OO,OO,OO,OO,(object s,object x,object y),"") { object r,i; x=OBJNULL; if (y!=Cnil && !READsuppress) extra_argument('C'); if (READsuppress) { read_object(s); s= Cnil; } else { do {read_char_to(x,s, {READER_ERROR(s,"A left parenthesis is expected.");}); } while (cat(x) == cat_whitespace); if (char_code(x) != '(') READER_ERROR(s,"A left parenthesis is expected."); delimiting_char = code_char(')'); x = read_object(s); if (x==OBJNULL || !realp(x)) TYPE_ERROR(x,TSor_rational_float); r=x; delimiting_char = code_char(')'); x = read_object(s); if (x==OBJNULL || !realp(x)) TYPE_ERROR(x,TSor_rational_float); i=x; delimiting_char = code_char(')'); x = read_object(s); if (x != OBJNULL) READER_ERROR(s,"A right parenthesis is expected."); if (contains_sharp_comma(r) || contains_sharp_comma(i)) { s = alloc_object(t_complex); s->cmp.cmp_real = r; s->cmp.cmp_imag = i; } else { check_type_number(&r); check_type_number(&i); s = make_complex(r, i); } } RETURN1(s); } /* static void */ /* Lsharp_C_reader() */ /* { */ /* object x=OBJNULL; */ /* check_arg(3); */ /* if (vs_base[2] != Cnil && !READsuppress) */ /* extra_argument('C'); */ /* vs_popp; */ /* vs_popp; */ /* if (READsuppress) { */ /* read_object(vs_base[0]); */ /* vs_base[0]= Cnil; */ /* } else { */ /* do {read_char_to(x,vs_base[0], { */ /* READER_ERROR(vs_base[0],"A left parenthesis is expected."); */ /* }); */ /* } while (cat(x) == cat_whitespace); */ /* if (char_code(x) != '(') */ /* READER_ERROR(vs_base[0],"A left parenthesis is expected."); */ /* delimiting_char = code_char(')'); */ /* x = read_object(vs_base[0]); */ /* if (x==OBJNULL || !realp(x)) */ /* TYPE_ERROR(x,TSor_rational_float); */ /* vs_push(x); */ /* delimiting_char = code_char(')'); */ /* x = read_object(vs_base[0]); */ /* if (x==OBJNULL || !realp(x)) */ /* TYPE_ERROR(x,TSor_rational_float); */ /* vs_push(x); */ /* delimiting_char = code_char(')'); */ /* x = read_object(vs_base[0]); */ /* if (x != OBJNULL) */ /* READER_ERROR(vs_base[0],"A right parenthesis is expected."); */ /* 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; */ /* } */ DEFUN("SHARP-\\-READER",object,fSsharp_sl_reader,SI,3,3,NONE,OO,OO,OO,OO,(object s,object x,object y),"") { object c,u; /*FIXME, read_token function*/ token->st.st_fillp=0; token_buffer[token->st.st_fillp++]=char_code((c=read_char(s)));/*FIXME, eof?*/ for (u=Cnil;u!=c;) switch (cat((c=read_char_to2(s,break)))) { case cat_single_escape: c=read_char_to2(s,u=c;break); case cat_constituent: token_buffer[token->st.st_fillp++]=char_code(c); case cat_multiple_escape: continue; default: unread_char(u=c,s); } if (READsuppress) RETURN1(Cnil); c = token; if (c->st.st_fillp == 1) { RETURN1(code_char(c->ust.ust_self[0])); } if (string_equal(c, STreturn)) s = code_char('\r'); else if (string_equal(c, STspace)) s = code_char(' '); else if (string_equal(c, STrubout)) s = code_char('\177'); else if (string_equal(c, STpage)) s = code_char('\f'); else if (string_equal(c, STtab)) s = code_char('\t'); else if (string_equal(c, STbackspace)) s = code_char('\b'); else if (string_equal(c, STlinefeed) || string_equal(c, STnewline)) s = code_char('\n'); else if (c->st.st_fillp == 2 && c->st.st_self[0] == '^') s = code_char(c->st.st_self[1] & 037); else if (c->st.st_self[0] =='\\' && c->st.st_fillp > 1) { int i, n; for (n = 0, i = 1; i < c->st.st_fillp; i++) if (c->st.st_self[i] < '0' || '7' < c->st.st_self[i]) FEerror("Octal digit expected.", 0); else n = 8*n + c->st.st_self[i] - '0'; s = code_char(n & 0377); } else FEerror("~S is an illegal character name.", 1, c); RETURN1(s); } /* 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); */ /* } */ DEFUN("SHARP-'-READER",object,fSsharp_q_reader,SI,3,3,NONE,OO,OO,OO,OO,(object s,object x,object y),"") { if(y != Cnil && !READsuppress) extra_argument('#'); RETURN1(MMcons(sLfunction,MMcons(read_object(s),Cnil))); } 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); 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') { if (cat(x)==cat_constituent) READER_ERROR(in,"Invalid bit vector element"); unreadc_stream(char_code(x),in); break; } vs_check_push(x); dimcount++; } if (dim >= 0) { if (dimcount > dim) { READER_ERROR(in,"Too many elements in #*...."); } else { /* if (dimcount == 0) */ /* FEerror("Cannot fill the bit-vector #*.",0); */ 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(ceil(dimcount,BV_ALLOC)*sizeof(*x->bv.bv_self)); vs_popp; for (dim = 0; dim < dimcount; dim++) switch(char_code(vsp[dim])) { case '0': CLEAR_BITREF(x,dim); break; case '1': SET_BITREF(x,dim); break; default: READER_ERROR(in,"Invalid bit vector entry"); break; } 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; } if (READeval) { vs_base[0] = read_object(vs_base[0]); /*FIXME: assumes no sharing until patch-sharp appears. Bootstrap requires *fasd-data**/ vs_base[0] = ieval(sSpatch_sharp->s.s_gfdef!=OBJNULL ? patch_sharp(vs_base[0]) : vs_base[0]); } else { READER_ERROR(vs_base[0],"Sharp dot found with *read-eval* set to nil"); } } 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(vs_base[0],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(vs_base[0],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(vs_base[0],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(vs_base[0],token_buffer, radix); null_terminate_token(); vs_base[0] = parse_number(vs_base[0],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() { object c=OBJNULL; int level = 0; check_arg(3); if (vs_base[2] != Cnil && !READsuppress) extra_argument('|'); vs_popp; vs_popp; for (;;) { read_char_to(c,vs_base[0],goto END); L: if (char_code(c) == '#') { read_char_to(c,vs_base[0],goto END); if (char_code(c) == '|') level++; } else if (char_code(c) == '|') { read_char_to(c,vs_base[0],goto END); if (char_code(c) == '#') { if (level == 0) break; else --level; } else goto L; } } END: vs_popp; vs_base[0] = Cnil; /* no result */ } static void Ldefault_dispatch_macro() { READER_ERROR(vs_base[0],"The default dispatch macro signalled an error."); } /* #$ 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(object from,object 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 = OBJNULL; /* 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]; */ } else rtab=to->rt.rt_self; /* structure assignment */ for (i = 0; i < RTABSIZE; i++) rtab[i] = from->rt.rt_self[i]; 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",object,fLread,LISP,0,4,NONE,OO,OO,OO,OO,(object f,...),"") { fixnum nargs=INIT_NARGS(0); object l=Cnil,x,strm,eof_errorp,eof_value,recursivep; va_list ap; va_start(ap,f); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); eof_errorp=NEXT_ARG(nargs,ap,l,f,Ct); eof_value= NEXT_ARG(nargs,ap,l,f,Cnil); recursivep=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); 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) RETURN1(eof_value); end_of_stream(strm); } RETURN1(x); } DEFUN("READ-PRESERVING-WHITESPACE",object,fLread_preserving_whitespace,LISP, 0,4,NONE,OO,OO,OO,OO,(object f,...),"") { fixnum nargs=INIT_NARGS(0); object l=Cnil,c,x,strm,eof_errorp,eof_value,recursivep; va_list ap; va_start(ap,f); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); eof_errorp=NEXT_ARG(nargs,ap,l,f,Ct); eof_value= NEXT_ARG(nargs,ap,l,f,Cnil); recursivep=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); 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) RETURN1(eof_value); end_of_stream(strm); READ: if (recursivep == Cnil) preserving_whitespace_flag = TRUE; if (recursivep == Cnil) x = read_object_non_recursive(strm); else x = read_object_recursive(strm); RETURN1(x); } DEFUN("READ-DELIMITED-LIST",object,fLread_delimited_list,LISP,1,3,NONE,OO,OO,OO,OO,(object d,...),"") { fixnum nargs=INIT_NARGS(1); object l=Cnil,x,f=OBJNULL,strm,recursivep,*p; va_list ap; bool e; volatile object old_READcontext; volatile int old_backq_level=0; va_start(ap,d); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); recursivep=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); 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; *p = make_cons(x, Cnil); p = &((*p)->c.c_cdr); } 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); } } RETURN1(l); } DEFUNM("READ-LINE",object,fLread_line,LISP,0,4,NONE,OO,OO,OO,OO,(object f,...),"") { fixnum vals=(fixnum)fcall.valp,nargs=INIT_NARGS(0),i; object l=Cnil,c,strm,eof_errorp,eof_value,recursivep,*base=vs_top; va_list ap; va_start(ap,f); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); eof_errorp=NEXT_ARG(nargs,ap,l,f,Ct); eof_value= NEXT_ARG(nargs,ap,l,f,Cnil); recursivep=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); 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) RETURN2(eof_value,Ct); 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) 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 */ RETURN2(copy_simple_string(token),c); } DEFUN("READ-CHAR",object,fLread_char,LISP,0,4,NONE,OO,OO,OO,OO,(object f,...),"") { fixnum nargs=INIT_NARGS(0); object l=Cnil,strm,eof_errorp,eof_value,recursivep; va_list ap; va_start(ap,f); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); eof_errorp=NEXT_ARG(nargs,ap,l,f,Ct); eof_value= NEXT_ARG(nargs,ap,l,f,Cnil); recursivep=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); 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); RETURN1(x); AT_EOF: if (eof_errorp == Cnil && recursivep == Cnil) RETURN1(eof_value); else end_of_stream(strm); RETURN1(Cnil); } } DEFUN("UNREAD-CHAR",object,fLunread_char,LISP,1,2,NONE,OO,OO,OO,OO,(object c,...),"") { fixnum nargs=INIT_NARGS(1); object l=Cnil,f=OBJNULL,strm; va_list ap; va_start(ap,c); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); va_end(ap); 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); RETURN1(Cnil); } DEFUN("PEEK-CHAR",object,fLpeek_char,LISP,0,5,NONE,OO,OO,OO,OO,(object peek_type,...),"") { fixnum nargs=INIT_NARGS(0); object l=Cnil,c,f=peek_type,strm,eof_errorp,eof_value,recursivep; va_list ap; va_start(ap,peek_type); peek_type=NEXT_ARG(nargs,ap,l,f,Cnil); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); eof_errorp=NEXT_ARG(nargs,ap,l,f,Ct); eof_value= NEXT_ARG(nargs,ap,l,f,Cnil); recursivep=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); 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) RETURN1(eof_value); else end_of_stream(strm); } c = read_char_no_echo(strm); unread_char(c, strm); RETURN1(c); } if (peek_type == Ct) { while (!stream_at_end(strm)) { c = read_char(strm); if (cat(c) != cat_whitespace) { unread_char(c, strm); RETURN1(c); } } if (eof_errorp == Cnil) RETURN1(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); RETURN1(c); } } if (eof_errorp == Cnil) RETURN1(eof_value); else end_of_stream(strm); RETURN1(Cnil); } DEFUN("LISTEN",object,fLlisten,LISP,0,1,NONE,OO,OO,OO,OO,(object f,...),"") { fixnum nargs=INIT_NARGS(0); object l=Cnil,strm; va_list ap; va_start(ap,f); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); va_end(ap); if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); RETURN1(listen_stream(strm) ? Ct : Cnil); } DEFUN("READ-CHAR-NO-HANG",object,fLread_char_no_hang,LISP,0,4,NONE,OO,OO,OO,OO,(object f,...),"") { fixnum nargs=INIT_NARGS(0); object l=Cnil,strm,eof_errorp,eof_value/* ,recursivep */; va_list ap; va_start(ap,f); strm=NEXT_ARG(nargs,ap,l,f,sLAstandard_inputA->s.s_dbind); eof_errorp=NEXT_ARG(nargs,ap,l,f,Ct); eof_value= NEXT_ARG(nargs,ap,l,f,Cnil); /* FIXME: recursivep=NEXT_ARG(nargs,ap,l,f,Cnil); */ va_end(ap); 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) RETURN1(eof_value); else end_of_stream(strm); } RETURN1(listen_stream(strm) ? read_char(strm) : Cnil); } @(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) @) DEFUNM("PARSE-INTEGER-INT",object,fSparse_integer_int,SI,5,5,NONE,OO,OO,IO,OO, (object strng,object start,object end,fixnum radix,object junk_allowed),"") { fixnum vals=(fixnum)fcall.valp; int s,e,ep; object *base=vs_top,x; if (junk_allowed==Cnil) check_type_string(&strng); get_string_start_end(strng, start, end, &s, &e); if (radix < 2 || 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) RETURN2(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, radix); ep=q-token->st.st_self; } if (x == OBJNULL) { if (junk_allowed != Cnil) RETURN2(Cnil,make_fixnum(ep+s)); else goto CANNOT_PARSE; } if (junk_allowed != Cnil) RETURN2(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; RETURN2(x,make_fixnum(e)); CANNOT_PARSE: PARSE_ERROR("Cannot parse integer from string"); RETURN2(Cnil,make_fixnum(0)); } /* @(defun read_byte (binary_input_stream */ /* &optional (eof_errorp Ct) 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); SGC_TOUCH(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("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("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, VLEN(x)); 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(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) #define make_f(f) find_symbol(make_simple_string(f),system_package)->s.s_gfdef; 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['\b'].rte_chatrait = trait_invalid; rtab['\t'].rte_chatrait = trait_invalid; rtab['\n'].rte_chatrait = trait_invalid; rtab['\r'].rte_chatrait = trait_invalid; rtab['\f'].rte_chatrait = trait_invalid; rtab[' '].rte_chatrait = trait_invalid; rtab['\177'].rte_chatrait = trait_invalid; rtab['\t'].rte_chattrib = cat_whitespace; rtab['\r'].rte_chattrib = cat_whitespace; rtab['\n'].rte_chattrib = cat_whitespace; rtab['\f'].rte_chattrib = cat_whitespace; rtab[' '].rte_chattrib = cat_whitespace; rtab['"'].rte_chattrib = cat_terminating; rtab['"'].rte_macro = make_f("DOUBLE-QUOTE-READER"); rtab['#'].rte_chattrib = cat_non_terminating; rtab['#'].rte_macro = dispatch_reader; rtab['\''].rte_chattrib = cat_terminating; rtab['\''].rte_macro = make_f("SINGLE-QUOTE-READER"); rtab['('].rte_chattrib = cat_terminating; rtab['('].rte_macro = make_cf(Lleft_parenthesis_reader); rtab[')'].rte_chattrib = cat_terminating; rtab[')'].rte_macro = make_f("RIGHT-PARENTHESIS-READER"); /* rtab[','].rte_chattrib = cat_terminating; rtab[','].rte_macro = make_cf(Lcomma_reader); */ rtab[';'].rte_chattrib = cat_terminating; rtab[';'].rte_macro = find_symbol(make_simple_string("SEMICOLON-READER"),system_package)->s.s_gfdef; 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_f("SHARP-C-READER"); dtab['\\'] = make_f("SHARP-\\-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); dtab['p'] = make_si_ordinary("SHARP-P-READER"); dtab['P'] = make_si_ordinary("SHARP-P-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; READeval = TRUE; 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; gcl-2.7.1/o/PaxHeaders/unixfsys.c0000644000000000000000000000013114775056562013656 xustar0030 mtime=1744067954.976337367 30 atime=1744339825.111476898 29 ctime=1744351535.47490929 gcl-2.7.1/o/unixfsys.c0000644000175000017500000003050514775056562013260 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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: return x->s.s_name; case t_simple_string: 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_file_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(stringp(namestring)); massert(VLEN(namestring)st.st_self,VLEN(namestring)); p[VLEN(namestring)]=0; #ifdef FIX_FILENAME FIX_FILENAME(spec,p); #endif } #ifndef __MINGW32__ static char GETPW_BUF[16384]; #endif DEFUN("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 } #include #include #include #include DEFUN("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,VLEN(nm),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 (({enum type _t=type_of(x);_t==t_string || _t==t_simple_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("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("STAT",object,fSstat,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { object *vals=(object *)fcall.valp; object *base=vs_top; 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("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("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("READLINKAT",object,fSreadlinkat,SI,2,2,NONE,OI,OO,OO,OO,(fixnum d,object s),"") { ssize_t l,z1; check_type_string(&s); z1=VLEN(s); massert(z1st.st_self,z1); FN1[z1]=0; massert((l=readlinkat(d ? dirfd((DIR *)d) : AT_FDCWD,FN1,FN2,sizeof(FN2)))>=0 && l #include DEFUN("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("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("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 && (d_type=get_d_type(e,s))!=DT_UNKNOWN && y!=d_type;); 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("CLOSEDIR",object,fSclosedir,SI,1,1,NONE,OI,OO,OO,OO,(fixnum x),"") { closedir((DIR *)x); return Cnil; } DEFUN("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("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("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("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("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.7.1/o/PaxHeaders/earith.c0000644000000000000000000000013214542551763013236 xustar0030 mtime=1703597043.288022878 30 atime=1744339822.043457741 30 ctime=1744351535.470909326 gcl-2.7.1/o/earith.c0000644000175000017500000000011514542551763012631 0ustar00cammcamm#define NEED_MP_H #include "include.h" #ifdef CMAC #include "cmac.c" #endif gcl-2.7.1/o/PaxHeaders/alloc.c0000644000000000000000000000013214776064417013060 xustar0030 mtime=1744333071.833790576 30 atime=1744335405.576655416 30 ctime=1744351535.450909505 gcl-2.7.1/o/alloc.c0000644000175000017500000012620014776064417012457 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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; void *stack_alloc_start=NULL,*stack_alloc_end=NULL; #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_vector(make_fixnum(aet_fix),16,Ct,make_fixnum(0),Cnil,0,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) { ufixnum f=contblock_array==Cnil ? 0 : contblock_array->v.v_fillp;/*FIXME*/ expand_contblock_array(); memmove(contblock_array->v.v_self+f+1,contblock_array->v.v_self+f, (contblock_array->v.v_fillp-f)*sizeof(*contblock_array->v.v_self)); contblock_array->v.v_self[f]=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; */ /* The SGC_PERM_WRITABLE facility is no longer used in favor of SGC_TOUCH. Implicitly grouping object types by size is unreliable.*/ #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 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;i fixnum set_tm_maxpage(struct typemanager *tm,fixnum n) { fixnum r=tm->tm_type==t_relocatable,j=tm->tm_maxpage,z=(n-j)*(r ? 2 : 1); if (z>available_pages) return 0; available_pages-=z; ({fenv_t f;feholdexcept(&f);tm->tm_adjgbccnt*=((double)j+1)/(n+1);fesetenv(&f);}); 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) { ifuncall1(sSAafter_gbc_hookA->s.s_dbind,intern(str((tm_table[(int)t].tm_name+1)),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_vector(make_fixnum(aet_fix),16,Ct,make_fixnum(0),Cnil,0,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; } 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--; expand_contblock_index_space(); GBC(t_relocatable); } sSAleaf_collection_thresholdA->s.s_dbind=o; } 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_calling_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); /*This is called from GBC so we do not want to expand the contblock index*/ if (cbv->v.v_fillp+1==cbv->v.v_dim || contblock_array->v.v_fillp==contblock_array->v.v_dim) return NULL; 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; VSET_MAX_FILLP(sSAcode_block_reserveA->s.s_dbind); } 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); tm->tm_calling_type=t_cons; 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("ALLOCATED",object,fSallocated,SI,1,1,NONE,OO,OO,OO,OO,(object typ),"") { struct typemanager *tm=(&tm_table[t_from_type(typ)]); fixnum vals=(fixnum)fcall.valp; object *base=vs_top; 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("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 = 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*/ 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); #ifdef GCL_GPROF if (raw_image) { sigset_t prof; sigemptyset(&prof); sigaddset(&prof,SIGPROF); sigprocmask(SIG_BLOCK,&prof,NULL); } #endif 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; /* == RLIM_INFINITY ? rl.rlim_max : rl.rlim_max/64; */ 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 #ifdef INITIALIZE_BRK INITIALIZE_BRK; #endif update_real_maxpage(); cumulative_allocation=recent_allocation=0; if (gcl_alloc_initialized) { maybe_set_hole_from_maxpages(); return; } #ifdef INIT_ALLOC INIT_ALLOC; #endif 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_simple_string, "\'SIMPLE-STRING", sizeof(struct unadjstring),0,1,0); init_tm(t_string, "\"STRING", sizeof(struct string),0,1,0 ); init_tm(t_simple_array, "ASIMPLE-ARRAY", sizeof(struct unadjarray),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_simple_vector, "VSIMPLE-VECTOR", sizeof(struct unadjvector),0 ,1,0); init_tm(t_vector, "vVECTOR", sizeof(struct vector),0 ,1,0); init_tm(t_simple_bitvector, "BSIMPLE-BIT-VECTOR", sizeof(struct unadjbitvector),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_function, "xFUNCTION", sizeof(struct function), 85 ,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("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); type=coerce_to_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,VLEN(type)) ) 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("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("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=ttm_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("ALLOCATE-CONTIGUOUS-PAGES",object,fSallocate_contiguous_pages,SI ,1,2,NONE,OI,OO,OO,OO,(fixnum npages,...),"") { object really_do,l=Cnil,f=OBJNULL; va_list ap; fixnum nargs=INIT_NARGS(1); va_start(ap,npages); really_do=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); 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("ALLOCATED-CONTIGUOUS-PAGES",object,fSallocated_contiguous_pages,SI ,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1((make_fixnum(ncbpage))); } DEFUN("MAXIMUM-CONTIGUOUS-PAGES",object,fSmaximum_contiguous_pages,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1((make_fixnum(maxcbpage))); } DEFUN("ALLOCATE-RELOCATABLE-PAGES",object,fSallocate_relocatable_pages,SI,1,2,NONE,OI,OO,OO,OO,(fixnum npages,...),"") { object really_do,l=Cnil,f=OBJNULL; va_list ap; fixnum nargs=INIT_NARGS(1); va_start(ap,npages); really_do=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); if (npages <= 0) FEerror("Requires positive arg",0); if (npagestm_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("ALLOCATED-RELOCATABLE-PAGES",object,fSallocated_relocatable_pages,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1(make_fixnum(nrbpage)); } DEFUN("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("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("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("SET-HOLE-SIZE",object,fSset_hole_size,SI,1,2,NONE,OI,IO,OO,OO,(fixnum npages,...),"") { fixnum vals=(fixnum)fcall.valp; object *base=vs_top; 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) { 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_string(size), malloc_list); malloc_list->c.c_car->st.st_self = alloc_contblock(size); malloc_list->c.c_car->st.st_writable=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) { VFILLP_SET(x,size); return(ptr); } else { x->st.st_self = alloc_contblock(size); x->st.st_dim = size; VSET_MAX_FILLP(x); 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_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.7.1/o/PaxHeaders/num_log.c0000644000000000000000000000013214720116405013406 xustar0030 mtime=1732287749.459422997 30 atime=1744339820.667449152 30 ctime=1744351535.470909326 gcl-2.7.1/o/num_log.c0000644000175000017500000001557014720116405013014 0ustar00cammcamm /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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. */ /* Logical operations on number */ #define NEED_MP_H #define EXPORT_GMP #include "include.h" #include "num_include.h" #ifdef GMP #include "gmp_num_log.c" #else #include "pari_num_log.c" #endif inline object fixnum_big_shift(fixnum x,fixnum w) { MPOP(return,shifti,SI_TO_MP(x,big_fixnum1),w); } inline 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); } inline 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; } } inline 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; } inline object integer_length(object x) { return make_fixnum(type_of(x)==t_fixnum ? fixnum_length(fix(x)) : MP_SIZE_IN_BASE2(MP(x))); } inline object integer_count(object x) { return make_fixnum(type_of(x)==t_fixnum ? fixnum_count(fix(x)) : MP_BITCOUNT(MP(x))); } #define DEFLOG(n_,a_,b_,c_) \ DEFUN(n_,object,Join(fL,a_),LISP,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { \ fixnum nargs=INIT_NARGS(0),fx=0; \ object l=Cnil,x,y; \ enum type tx,ty; \ va_list ap; \ \ va_start(ap,first); \ x=NEXT_ARG(nargs,ap,l,first,c_); \ if ((tx=type_of(x))==t_fixnum) {fx=fix(x);x=OBJNULL;} \ for (;(y=NEXT_ARG(nargs,ap,l,first,OBJNULL))!=OBJNULL;) { \ ty=type_of(y); \ if (tx==t_fixnum&&ty==t_fixnum) \ fx=fixnum_log_op2(b_,fx,fix(y)); \ else { \ x=normalize_big(integer_log_op2(b_,x==OBJNULL ? make_fixnum(fx) : x,tx,y,ty)); \ if ((tx=type_of(x))==t_fixnum) {fx=fix(x);x=OBJNULL;} \ } \ } \ va_end(ap); \ return x==OBJNULL ? make_fixnum(fx) : maybe_replace_big(x); \ } \ DEFLOG("LOGIOR",logior,BOOLIOR,small_fixnum(0)); DEFLOG("LOGXOR",logxor,BOOLXOR,small_fixnum(0)); DEFLOG("LOGAND",logand,BOOLAND,small_fixnum(-1)); DEFLOG("LOGEQV",logeqv,BOOLEQV,small_fixnum(-1)); /* #define IF1(a_) BF(1,a_,f,b) */ /* IF1(bitcount) */ /* IF1(popcount) */ /* IF1(bitlength) */ /* BF(2,sizeinbase,f,b,f) */ /* IF1(get_si) */ /* IF1(get_ui) */ /* IF1(sgn) */ /* BF(1,fac_ui,b,f) */ /* BF(1,fib_ui,b,f) */ /* BF(3,powm,b,b,b,b) */ /* BF(3,powm_ui,b,b,f,b) */ /* BF(2,tdiv_qr,m,b,b) */ /* #define BF1(a_) BF(1,a_,b,b) */ /* BF1(com) */ /* BF1(sqrt) */ /* BF1(neg) */ /* BF(2,cmp,f,b,b) */ /* #define BF2(a_) BF(2,a_,b,b,b) */ /* BF2(invert) */ /* BF2(remove) */ /* BF2(add) */ /* BF2(mul) */ /* BF2(sub) */ /* BF2(and) */ /* BF2(ior) */ /* BF2(xor) */ /* BF2(gcd) */ /* BF2(lcm) */ /* BF2(divexact) */ /* BF(2,tstbit,f,b,f) */ /* BF(2,jacobi,f,b,b) */ /* #define BF2I(a_) BF(2,a_,b,b,f) */ /* BF2I(root) */ /* BF2I(divexact_ui) */ /* BF2I(gcd_ui) */ /* BF2I(bin_ui) */ /* BF2I(lcm_ui) */ /* BF2I(sub_ui) */ /* BF2I(add_ui) */ /* BF2I(mul_ui) */ /* BF2I(mul_si) */ /* BF2I(mul_2exp) */ /* BF2I(fdiv_q_2exp) */ #define BI(n_)\ DEFUN(#n_,object,Join(fS,n_),SI,1,1,NONE,II,OO,OO,OO,(fixnum x),"") {\ \ RETURN1((object)(fixnum)Join(__builtin_,n_)(x)); \ \ } BI(clzl) BI(ctzl) BI(ffsl) BI(parityl) BI(popcountl) DEFUN("SHFT",object,fSshft,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum y),"") { object u=new_bignum(); ENSURE_MP(x,1); shifti(MP(u),MP(x),y); RETURN1(normalize_big(u)); } DEFUN("LOGCB1",object,fSlogcb1,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { object u=new_bignum(); ENSURE_MP(x,1); mpz_com(MP(u),MP(x)); RETURN1(normalize_big(u)); } #define B2OP(n_,b_) \ DEFUN(#n_ "B2",object,Join(Join(fSlog,n_),b2),SI,3,3,NONE,OO,OO,OO,OO,(object x,object y,object z),"") { \ \ object u=new_bignum();\ \ ENSURE_MP(x,1);\ ENSURE_MP(y,2);\ Join(mpz_,b_)(MP(u),MP(x),MP(y));\ if (z!=Cnil) mpz_com(MP(u),MP(u));\ RETURN1(normalize_big(u));\ \ } B2OP(AND,and) B2OP(IOR,ior) B2OP(XOR,xor) DEFUN("BOOLE",object,fLboole,LISP,3,3,NONE,OO,OO,OO,OO,(object o,object x,object y),"") { check_type_integer(&o); check_type_integer(&x); check_type_integer(&y); RETURN1(log_op2(fixint(o),x,y)); } DEFUN("ASH",object,fLash,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type_integer(&x); check_type_integer(&y); RETURN1(integer_shift(x,y)); } DEFUN("LOGBITP",object,fLlogbitp,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type_integer(&x); check_type_integer(&y); RETURN1(integer_bitp(x,y)?Ct:Cnil); } DEFUN("LOGCOUNT",object,fLlogcount,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_integer(&x); RETURN1(integer_count(x)); } DEFUN("INTEGER-LENGTH",object,fLloglength,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_integer(&x); RETURN1(integer_length(x)); } 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)); sLbit = make_ordinary("BIT"); } gcl-2.7.1/o/PaxHeaders/pathname.d0000644000000000000000000000013214555557372013566 xustar0030 mtime=1706483450.804392729 30 atime=1744340056.096936795 30 ctime=1744351535.578908358 gcl-2.7.1/o/pathname.d0000644000175000017500000000272014555557372013165 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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("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); } void gcl_init_pathname(void) { } void gcl_init_pathname_function() { } gcl-2.7.1/o/PaxHeaders/bitop.c0000644000000000000000000000013214542551763013077 xustar0030 mtime=1703597043.284022871 30 atime=1744340055.672934088 30 ctime=1744351535.450909505 gcl-2.7.1/o/bitop.c0000644000175000017500000000124514542551763012477 0ustar00cammcamm#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.7.1/o/PaxHeaders/number.c0000644000000000000000000000013214755671602013253 xustar0030 mtime=1740075906.434909288 30 atime=1744339818.215433849 30 ctime=1744351535.466909362 gcl-2.7.1/o/number.c0000644000175000017500000001714414755671602012660 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 /*FIXME, make these immutable and of type immfix*/ #define BIGGER_FIXNUM_RANGE #ifdef BIGGER_FIXNUM_RANGE struct {int min,max;} bigger_fixnums; struct fixnum_struct *bigger_fixnum_table=NULL,*bigger_fixnum_table_end=NULL; #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("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 int is_bigger_fixnum(void *v) { return v>=(void *)bigger_fixnum_table && v<(void *)bigger_fixnum_table_end ? 1 : 0; } 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,int pre_cancelled) { object g, r, get_gcd(object x, object y); vs_mark; if (den==small_fixnum(0) /* number_zerop(den) */) DIVISION_BY_ZERO(sLD,list(2,num,den)); if (num==small_fixnum(0)/* number_zerop(num) */) return(num); if (number_minusp(den)) { num = number_negate(num); vs_push(num); den = number_negate(den); vs_push(den); } if (den==small_fixnum(1)/* type_of(den) == t_fixnum && fix(den) == 1 */) return(num); if (!pre_cancelled) { g = get_gcd(num, den); num = integer_divide1(num, g,0); /*FIXME exact division here*/ den = integer_divide1(den, g,0); if(den==small_fixnum(1)/* type_of(den) == t_fixnum && fix(den) == 1 */) { return(num); } } r = alloc_object(t_ratio); r->rat.rat_num = num; r->rat.rat_den = den; vs_reset; return(r); } DEFUN("MAKE-RATIO",object,fSmake_ratio,SI,3,3,NONE,OO,OI,OO,OO,(object num,object den,fixnum pre_canceled),"") { RETURN1(make_ratio(num,den,pre_canceled)); } DEFUN("MAKE-COMPLEX",object,fSmake_complex,SI,3,3,NONE,OI,OO,OO,OO,(fixnum tt,object r,object i),"") { object x=alloc_object(t_complex); massert(tt>=0 && tt<=5); x->d.tt=tt; x->cmp.cmp_real=r; x->cmp.cmp_imag=i; RETURN1(x); } object make_shortfloat(float 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); {enum type tp=type_of(r); c->cmp.tt= tp==t_longfloat ? 5 : (tp==t_shortfloat ? 4 : (tp==t_ratio && type_of(i)==t_ratio ? 3 : (tp==t_ratio ? 2 : (type_of(i)==t_ratio ? 1 : 0)))); } 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: { 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.7.1/o/PaxHeaders/lex.c0000644000000000000000000000013114555557372012557 xustar0029 mtime=1706483450.80039273 30 atime=1744340055.680934139 30 ctime=1744351535.454909469 gcl-2.7.1/o/lex.c0000644000175000017500000000527114555557372012163 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.7.1/o/PaxHeaders/unexnt.c0000644000000000000000000000013114555557372013310 xustar0030 mtime=1706483450.808392729 29 atime=1744295002.02997124 30 ctime=1744351535.586908286 gcl-2.7.1/o/unexnt.c0000644000175000017500000010202114555557372012703 0ustar00cammcamm/* unexec for GNU Emacs on Windows NT. Copyright (C) 1994 Free Software Foundation, Inc. Copyright (C) 2024 Camm Maguire 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 /* in case the include of config.h defined it */ #undef va_start #include #include #include #include #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 "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.7.1/o/PaxHeaders/gbc.c0000644000000000000000000000013214776006046012513 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.302035078 30 ctime=1744351535.450909505 gcl-2.7.1/o/gbc.c0000644000175000017500000010321414776006046012112 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 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_object(x->s.s_name); 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].c_cdr!=OBJNULL) {/*FIXME*/ mark_object_address(&x->ht.ht_self[i].c_cdr,i); mark_object_address(&x->ht.ht_self[i].c_car,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_simple_array: case t_array: MARK_LEAF_DATA(x,x->a.a_dims,sizeof(*x->a.a_dims)*x->a.a_rank); case t_simple_vector: case t_simple_bitvector: case t_simple_string: case t_vector: case t_bitvector: case t_string: if (x->v.v_elttype==aet_object && ADISP(x)->c.c_car==Cnil) mark_object_array(x->v.v_self,x->v.v_self+x->v.v_dim); j=x->v.v_eltsize ? (1<<(x->v.v_eltsize-1)) : x->v.v_eltsize; if ((COLLECT_RELBLOCK_P) && (void *)x->v.v_self>=(void *)heap_end && j>sizeof(long)) rb_pointer=PCEI(rb_pointer,j); /*FIXME GC space violation*/ j=j ? j*x->v.v_dim : ceil(BV_OFFSET(x)+x->bv.bv_dim,BV_ALLOC)*sizeof(*x->bv.bv_self); if (ADISP(x)->c.c_car==Cnil) MARK_LEAF_DATA(x,x->v.v_self,j); mark_object(ADISP(x)); set_displaced_body_ptr(x); break; case t_structure: { mark_object(x->str.str_def); if (x->str.str_self) { 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;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); /* Only set by malloc, handled by malloc_list */ /* if (x->sm.sm_fp) { */ /* MARK_LEAF_DATA(x,x->sm.sm_buffer,BUFSIZ); */ /* } */ break; case smm_file_synonym: 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_function: mark_object(x->fun.fun_data); mark_object(x->fun.fun_plist); if (x->fun.fun_env != def_env && x->fun.fun_env != src_env) { mark_object(x->fun.fun_env[0]); x->fun.fun_env--; MARK_LEAF_DATA(x,x->fun.fun_env,(*(ufixnum *)x->fun.fun_env)*sizeof(*x->fun.fun_env)); x->fun.fun_env++; } break; case t_cfdata: mark_object(x->cfd.cfd_dlist); mark_object(x->cfd.cfd_name); 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_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(Cnil->s.s_name); mark_object(Ct->s.s_plist); mark_object(Ct->s.s_name); 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); cumulative_allocation+=recent_allocation; 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; { struct typemanager *tm=tm_of(t); tm->tm_gbccount++; tm->tm_adjgbccnt++; } if (sSAnotify_gbcA->s.s_dbind != Cnil #ifdef DEBUG || debug #endif ) { if (gc_time < 0) gc_time=0; #ifdef SGC omsg("[%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 omsg("[%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) omsg("(T=...).GC finished]\n"); else omsg("(T=%d).GC finished]\n",gc_start); } collect_both=0; END_NO_INTERRUPT; CHECK_INTERRUPT; } static void FFN(siLheap_report)(void) { int i; extern void *shared_lib_start; 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(((unsigned long)real_maxpage)<>1)); vs_push(make_fixnum(CSTACK_ALIGNMENT)); vs_push(make_fixnum(labs(cs_limit-cs_org)));/*CSSIZE*/ vs_push(make_fixnum(phys_pages)); #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<>20; if ((fixnum)x>=0) RETURN1(make_fixnum(x)); mpz_set_ui(MP(big_fixnum1),x); RETURN1(replace_big(big_fixnum1)); } DEFUN("ROOM-REPORT",object,fSroom_report,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { object x=Cnil; int i; x=make_cons(make_fixnum(real_maxpage-first_data_page),x); x=make_cons(make_fixnum(available_pages),x); x=make_cons(make_fixnum(ncbpage),x); x=make_cons(make_fixnum(maxcbpage),x); x=make_cons(make_fixnum(count_contblocks()),x); x=make_cons(make_fixnum(cbgbccount),x); x=make_cons(make_fixnum((rb_start-heap_end)>>PAGEWIDTH),x); x=make_cons(make_fixnum(rb_pointer - rb_begin()),x); x=make_cons(make_fixnum((rb_begin()+rb_size()) - rb_pointer),x); x=make_cons(make_fixnum(nrbpage),x); x=make_cons(make_fixnum(maxrbpage),x); x=make_cons(make_fixnum(rbgbccount),x); for (i = 0; i < (int)t_end; i++) { x=make_cons(make_simple_string(tm_table[i].tm_name+1),x); if (tm_table[i].tm_type == (enum type)i) { x=make_cons(make_fixnum(TM_NUSED(tm_table[i])),x); x=make_cons(make_fixnum(tm_table[i].tm_nfree+tm_table[i].tm_alt_nfree),x); x=make_cons(make_fixnum(tm_table[i].tm_npage),x); x=make_cons(make_fixnum(tm_table[i].tm_maxpage),x); x=make_cons(make_fixnum(tm_table[i].tm_gbccount),x); x=make_cons(make_fixnum(tm_table[i].tm_size/sizeof(fixnum)),x); } else { x=make_cons(Cnil,x); x=make_cons(make_simple_string(tm_of(i)->tm_name+1),x); x=make_cons(Cnil,x); x=make_cons(Cnil,x); x=make_cons(Cnil,x); x=make_cons(Cnil,x); } } RETURN1(nreverse(x)); } 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("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: case t_simple_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_simple_string: case t_string: case t_bitvector: case t_simple_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_function: d=o->fun.fun_env; s=o->fun.fun_env!=def_env && o->fun.fun_env!=src_env ? ((ufixnum *)o->fun.fun_env)[-1]*sizeof(object) : 0; break; case t_cfdata:/*FIXME*/ 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, object %p\n",s,tm_table[type_of(o)].tm_name,d,o); i+=s; j++; } } } } emsg("\nTotal leaf bytes %lu in %lu pieces\n",i,j); return Cnil; } DEFUN("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("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.7.1/o/PaxHeaders/iteration.c0000644000000000000000000000013214771143514013753 xustar0030 mtime=1743046476.398942455 30 atime=1744339816.459422893 30 ctime=1744351535.462909398 gcl-2.7.1/o/iteration.c0000644000175000017500000002166314771143514013361 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.7.1/o/PaxHeaders/fasdump.c0000644000000000000000000000013014720473024013406 xustar0030 mtime=1732408852.538015766 29 atime=1744339827.15948969 29 ctime=1744351535.59090825 gcl-2.7.1/o/fasdump.c0000644000175000017500000010501214720473024013005 0ustar00cammcamm /* Copyright William F. Schelter All Rights Reserved. Copyright 2024 Camm Maguire 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; \ dump_index = fix((fd)->index) ; \ current_fasd= * (fd);}while(0) #define SAVE_CURRENT_FASD \ struct fasd old_fd; \ int old_dump_index = dump_index; \ object 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 object 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 /*FIXME debugging versions need sync with getc -> readc_stream, etc.*/ #define PUT(x) writec_stream1((char)x,fas_stream) #define GET() readc_stream1() #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("}");} writec_stream(i,fas_stream);} void writec_stream1(x) int x; { if (debug) printf("(%x,%d,%c)",x,x,x); writec_stream(x,fas_stream); /* fflush(stdout); */ } int readc_stream1() { int x; x= readc_stream(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;is.s_dbind); printf("]"); /* fflush(stdout);} */ return j; } int fwrite1(p,n1,n2,st) FILE* st; char *p; int n1; int n2; {int i,j; j=fwrite(p,n1,n2,st); if(debug) {printf("["); n1=n1*n2; for(i=0;is.s_dbind); printf("]");} return j; } #define GET_OP() ((unsigned)print_op((unsigned char)readc_stream(fas_stream))) #define PUT_OP(x) writec_stream(print_op(x),fas_stream) #define DP(sw) sw /* if (debug) {printf("\ncase sw");} */ #define GETD(str) getd(str) int getd(str) char *str; { int i = (unsigned char)readc_stream(fas_stream); if(debug){ printf("{"); printf(str,i); printf("}");} return i;} #define DPRINTF(a,b) do{if(debug) printf(a,b);} while(0) #else #define PUT(x) writec_stream((char)x,fas_stream) #define GET() ((unsigned char)readc_stream(fas_stream)) #define GET_OP GET #define PUT_OP PUT #define D_FWRITE fwrite_int #define D_FREAD fread_int #define DP(sw) sw #define PUTD(a,b) PUT(b) #define GETD(a) GET() #define DPRINTF(a,b) /* #define fwrite_int(a_,b_,c_,d_) {register char *_p=(a_),*_pe=_p+(b_)*(c_);for (;_p<_pe;) writec_stream(*_p++,(d_));} */ /* #define fread_int(a_,b_,c_,d_) {register char *_p=(a_),*_pe=_p+(b_)*(c_);for (;_p<_pe;) *_p++=readc_stream(d_);} */ #define fwrite_int(a_,b_,c_,d_) {register unsigned _i;for (_i=0;_i<(b_)*(c_);_i++) writec_stream(((char *)(a_))[_i],(d_));} #define fread_int(a_,b_,c_,d_) {register unsigned _i;for (_i=0;_i<(b_)*(c_);_i++) ((char *)(a_))[_i]=readc_stream(d_);} #endif #define D_TYPE_OF(byt) \ ((enum dump_type )((unsigned int) byt & ~(~0UL << SIZE_D_CODE))) /* this field may be the top of a short for length, or part of an extended code */ #define E_TYPE_OF(byt) ((unsigned int) byt >> (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() ((unsigned char)readc_stream(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) writec_stream((((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_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 cons *e; int i; e=gethash(obj,dump_hash_table); if (e->c_cdr==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->c_car); if (i == -1) return NOT_INDEXED; /* don't want to index this baby */ if (dot) PUT_OP(dot); if ( i < -1) { e->c_car = 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("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("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("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); else check_type(tabl,t_simple_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)); array_allocself(result,1,Cnil); {struct fasd *fd= (struct fasd *)result->sv.sv_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(file_position(stream)); 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("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_simple_vector); if(fd->direction==sKoutput) {clrhash(fd->table); SETUP_FASD_IN(fd); PUT_OP(d_end_of_file); {int i = file_position(fd->stream); if(type_of(fd->filepos) == t_fixnum) { file_position_set(fd->stream,fix(fd->filepos) +2); /* record the length of array needed to read the indices */ PUT4(fix(fd->index)); /* move back to where we were */ file_position_set(fd->stream,i); }} } /* 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(consp(x)) {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 (consp(obj)) { 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=VLEN(obj->s.s_name); 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_name->st.st_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_simple_string:) case DP(t_string:) leng=VLEN(obj); 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_simple_vector:) case DP(t_vector:) TRY_HASH; PUT_OP(d_vector); { int leng=VLEN(obj); 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 (consp(x->c.c_cdr)) 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_simple_vector:) case DP(t_vector:) { int i; if ((enum aelttype)x->v.v_elttype != aet_object) break; for (i = 0; i < VLEN(x); 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("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); RETURN1(Ct); } static object lisp_eval(object x) { SAVE_CURRENT_FASD; x=ieval(x); RESTORE_FASD; return x; } #define CHECK_CH(i) do{if ((i)==EOF && stream_at_end(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+1)); {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=nl; VSET_MAX_FILLP(ar); 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; funcall(find_symbol(str("MAKE-STRUCTURE"),system_package)); /* 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; GET4(leng); { enum aelttype tp=GETD("v_elttype=%d"); x= tp==aet_object ? alloc_simple_vector(leng) : alloc_vector(leng,tp); } 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); set_array_elttype(x,GETD("a_elttype=%d")); x->a.a_dim=leng; x->a.a_hasfillp=1; x->a.a_rank= GETD("a_rank=%d"); x->a.a_self=0; x->a.a_adjustable=1; SET_ADISP(x,Cnil); if (x->a.a_rank > 0) { x->a.a_dims = (ufixnum *)alloc_relblock(sizeof(fixnum)*(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].c_cdr = OBJNULL; table->ht.ht_self[i].c_car = 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.7.1/o/PaxHeaders/gprof.c0000644000000000000000000000013214761577223013101 xustar0030 mtime=1741094547.602220601 30 atime=1744339838.383559851 30 ctime=1744351535.566908465 gcl-2.7.1/o/gprof.c0000644000175000017500000000401314761577223012475 0ustar00cammcamm#include "include.h" #include "page.h" #include "ptable.h" static unsigned long gprof_on; DEFUN("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("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("GPROF-ADDRESSES",object,fSgprof_addresses,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { void *min=heap_end,*max=data_start,*c; 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.7.1/o/PaxHeaders/toplevel.c0000644000000000000000000000013114556573017013614 xustar0030 mtime=1706751503.785071974 30 atime=1744339823.523466982 29 ctime=1744351535.47490929 gcl-2.7.1/o/toplevel.c0000644000175000017500000001644714556573017013227 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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,oname; object body, form; if (endp(args) || endp(MMcdr(args))) FEtoo_few_argumentsF(args); if (MMcadr(args) != Cnil && !consp(MMcadr(args))) FEerror("~S is an illegal lambda-list.", 1, MMcadr(args)); oname=name = MMcar(args); if (type_of(name) != t_symbol) name=ifuncall1(sSfunid_to_sym,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); } 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; */ vs_base[0]=fSfset_in(name,vs_base[0],name);/*FIXME ?*/ /* object x=alloc_object(t_ifun); */ /* x->ifn.ifn_self=vs_base[0]; */ /* x->ifn.ifn_name=name; */ /* x->ifn.ifn_call=Cnil; */ /* vs_base[0]=x; */ /* fname = clear_compiler_properties(name,vs_base[0]); */ /* fname->s.s_gfdef = vs_base[0]; */ /* fname->s.s_mflag = FALSE; */ } vs_base[0] = oname; for (body = MMcddr(args); !endp(body); body = body->c.c_cdr) { form = macro_expand(body->c.c_car); if (stringp(form)) { 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 (!consp(form) || 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; } DEFUN("OBJNULL",object,fSobjnull,SI,0,0,NONE,IO,OO,OO,OO,(void),"") {return OBJNULL;} DEFUN("*MAKE-CONSTANT",object,fSAmake_constant,SI,2,2,NONE,OO,OO,OO,OO, \ (object s,object v),"") { check_type_sym(&s); switch(s->s.s_stype) { case stp_special: FEerror("The argument ~S to defconstant is a special variable.", 1, s); break; case stp_constant: break; default: s->s.s_dbind=v; break; } s->s.s_stype=stp_constant; RETURN1(s); } /* 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_top; 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 (consp(args) && MMcar(args) == sLvalues) { vs = vs_base; for (args=MMcdr(args); !endp(args) && vss.s_gfdef!=OBJNULL && ifuncall2(sLtypep, vs_base[0], args) == Cnil) FEwrong_type_argument(args, vs_base[0]); } } DEF_ORDINARY("WILD-PATHNAME-P",sLwild_pathname_p,LISP,""); 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_function("DECLARE",Fdeclare); make_special_form("LOCALLY",Flocally); } gcl-2.7.1/o/PaxHeaders/prog.c0000644000000000000000000000013214555557372012737 xustar0030 mtime=1706483450.804392729 30 atime=1744339816.711424465 30 ctime=1744351535.462909398 gcl-2.7.1/o/prog.c0000644000175000017500000001363614555557372012346 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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)); */ PROGRAM_ERROR("~S is an undefined tag.", 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.7.1/o/PaxHeaders/regexp.h0000644000000000000000000000013114542551763013260 xustar0029 mtime=1703597043.32802294 30 atime=1744339813.027401486 30 ctime=1744351535.514908931 gcl-2.7.1/o/regexp.h0000755000175000017500000000142714542551763012666 0ustar00cammcamm#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.7.1/o/PaxHeaders/let.c0000644000000000000000000000013214753165412012542 xustar0030 mtime=1739385610.881119924 30 atime=1744339815.887419324 30 ctime=1744351535.458909434 gcl-2.7.1/o/let.c0000644000175000017500000001764114753165412012151 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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)) { object x; def = MMcar(def_list); x=MMcar(def); if (type_of(x)!=t_symbol) { x=ifuncall1(sSfunid_to_sym,x); def=MMcons(x,MMcdr(def)); } 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]); { top[0]=fSfset_in(Cnil,top[0],MMcar(def)); } /* { */ /* object x=alloc_object(t_ifun); */ /* x->ifn.ifn_self=top[0]; */ /* x->ifn.ifn_name=x->ifn.ifn_call=Cnil; */ /* top[0]=x; */ /* } */ 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; } DEF_ORDINARY("FUNID-TO-SYM",sSfunid_to_sym,SI,""); 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)) { object x; def = MMcar(def_list); x=MMcar(def); if (type_of(x)!=t_symbol) { x=ifuncall1(sSfunid_to_sym,x); def=MMcons(x,MMcdr(def)); } 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]); { top[0]=fSfset_in(Cnil,top[0],MMcar(def)); } /* { */ /* object x=alloc_object(t_ifun); */ /* x->ifn.ifn_self=top[0]; */ /* x->ifn.ifn_name=x->ifn.ifn_call=Cnil; */ /* top[0]=x; */ /* } */ 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)) { object x; def = MMcar(def_list); x=MMcar(def); if (type_of(x)!=t_symbol) { x=ifuncall1(sSfunid_to_sym,x); def=MMcons(x,MMcdr(def)); } if (endp(def) || endp(MMcdr(def)) || type_of(MMcar(def)) != t_symbol) FEerror("~S~%\ is an illegal macro definition in MACROLET.", 1, def); top[0] = ifuncall3(sSdefmacro_lambda, MMcar(def), MMcadr(def), MMcddr(def)); { top[0]=fSfset_in(Cnil,top[0],MMcar(def)); } /* { */ /* object x=alloc_object(t_ifun); */ /* x->ifn.ifn_self=top[0]; */ /* x->ifn.ifn_name=x->ifn.ifn_call=Cnil; */ /* top[0]=x; */ /* } */ lex_macro_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; } 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_si_special_form("COMPILER-LET", Fcompiler_let); make_special_form("FLET",Fflet); make_special_form("LABELS",Flabels); make_special_form("MACROLET",Fmacrolet); } gcl-2.7.1/o/PaxHeaders/user_match.c0000644000000000000000000000013214542551763014114 xustar0030 mtime=1703597043.344022966 30 atime=1744339830.379509809 30 ctime=1744351535.490909147 gcl-2.7.1/o/user_match.c0000644000175000017500000000010514542551763013506 0ustar00cammcamm#include "include.h" int user_match(const char *s,int n) {return 0;} gcl-2.7.1/o/PaxHeaders/package.d0000644000000000000000000000013214776006046013354 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.302035078 30 ctime=1744351535.578908358 gcl-2.7.1/o/package.d0000644000175000017500000007040714776006046012762 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.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]) 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 bool designate_package(object x,struct package *p) { switch(type_of(x)) { case t_simple_string: case t_string: return string_eq(x,p->p_name) || member_string_eq(x, p->p_nicknames); break; case t_character: case t_symbol: return designate_package(coerce_to_string(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,ufixnum *n,fixnum m) { object *ntab; object *tab = *ptab; object l,ll; fixnum 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(ufixnum 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) { x = make_package(n, ns, ul,isize,esize); goto L; } 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); L: 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_string(x); {int len=VLEN(x); 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("PACK-HASH",object,fSpack_hash,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((object)(fixnum)pack_hash(x)); } DEFUN("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("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("PACKAGE-INTERNAL_SIZE",object,fSpackage_internal_size,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { check_type_package(&x); RETURN1((object)x->p.p_internal_size); } DEFUN("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("PACKAGE-EXTERNAL_SIZE",object,fSpackage_external_size,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { check_type_package(&x); RETURN1((object)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_string(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->s.s_name, 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->s.s_name, 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->s.s_name, 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.tt=2; 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_string(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->s.s_name, 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->s.s_name, 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->s.s_name, 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; s->s.tt=0; } 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; x->s.tt=0; } 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_string(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; if (p==keyword_package) vs_head->s.tt=2; *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-INT",object,fSmake_package_int,SI,3,3,NONE,OO,OO,OO,OO,(object name,object nicknames,object use),"") { RETURN1(make_package(name,nicknames,use,0,0)); } @(defun in_package (pack_name &key nicknames (use Cnil use_sp) (internal `small_fixnum(0)`) (external `small_fixnum(0)`) ) @ pack_name=coerce_to_string(pack_name); 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("IN-PACKAGE-INTERNAL",object,fSin_package_internal,SI,1,2,NONE,OO,OO,OO,OO,(object p,...),"") { fixnum nargs=INIT_NARGS(1); va_list ap; object use=Cnil,nick=Cnil,l=Cnil,f=OBJNULL,r; p = coerce_to_string(p); va_start(ap,p); r = NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); /*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)); } DEFUN("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_internal)() { 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); new_name=coerce_to_string(new_name); 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_internal (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_simple_string: 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_simple_string: 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_simple_string: 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); gmp_package=make_package(make_simple_string("GMP"),Cnil,Cnil,0,0); /* 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_si_function("DELETE-PACKAGE-INTERNAL", Ldelete_package_internal); make_si_function("KCL-IN-PACKAGE", Lin_package); make_function("IN-PACKAGE", Lin_package); /* make_function("FIND-PACKAGE", Lfind_package); */ 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_si_function("IMPORT-INTERNAL", Limport_internal); 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("SET-SYMBOL-HPACK", siLset_symbol_hpack); */ /* make_si_function("PACKAGE-INTERNAL", siLpackage_internal); */ /* make_si_function("PACKAGE-EXTERNAL", siLpackage_external); */ } gcl-2.7.1/o/PaxHeaders/typespec.c0000644000000000000000000000013214556454523013617 xustar0030 mtime=1706711379.464802514 30 atime=1744340055.668934062 30 ctime=1744351535.450909505 gcl-2.7.1/o/typespec.c0000644000175000017500000004527414556454523013231 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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; */ /* void */ /* check_type_integer(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_fixnum && t != t_bignum) */ /* *p = wrong_type_argument(sLinteger, *p); */ /* } */ /* void */ /* check_type_non_negative_integer(object *p) */ /* { */ /* enum type t; */ /* for (;;) { */ /* t = type_of(*p); */ /* if (t == t_fixnum) { */ /* if (fix((*p)) >= 0) */ /* break; */ /* } else if (t == t_bignum) { */ /* if (big_sign((*p)) >= 0) */ /* break; */ /* } */ /* *p = wrong_type_argument(TSnon_negative_integer, *p); */ /* } */ /* } */ /* void */ /* check_type_rational(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_fixnum && */ /* t != t_bignum && t != t_ratio) */ /* *p = wrong_type_argument(sLrational, *p); */ /* } */ /* void */ /* check_type_float(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_shortfloat && t != t_longfloat) */ /* *p = wrong_type_argument(sLfloat, *p); */ /* } */ /* static void */ /* check_type_or_integer_float(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_fixnum && t != t_bignum && */ /* t != t_shortfloat && t != t_longfloat) */ /* *p = wrong_type_argument(TSor_integer_float, *p); */ /* } */ /* void */ /* check_type_or_rational_float(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_fixnum && t != t_bignum && */ /* t != t_ratio && t != t_shortfloat && t != t_longfloat) */ /* *p = wrong_type_argument(TSor_rational_float, *p); */ /* } */ /* void */ /* check_type_number(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_fixnum && t != t_bignum && */ /* t != t_ratio && t != t_shortfloat && t != t_longfloat && */ /* t != t_complex) */ /* *p = wrong_type_argument(sLnumber, *p); */ /* } */ /* static void */ /* check_type_bit(object *p) */ /* { */ /* while (type_of(*p) != t_fixnum || */ /* (fix((*p)) != 0 && fix((*p)) != 1)) */ /* *p = wrong_type_argument(sLbit, *p); */ /* } */ /* void */ /* check_type_character(object *p) */ /* { */ /* while (type_of(*p) != t_character) */ /* *p = wrong_type_argument(sLcharacter, *p); */ /* } */ /* void */ /* check_type_symbol(object *p) */ /* { */ /* while (type_of(*p) != t_symbol) */ /* *p = wrong_type_argument(sLsymbol, *p); */ /* } */ /* void */ /* check_type_or_symbol_string(object *p) */ /* { */ /* while (type_of(*p) != t_symbol && type_of(*p) != t_string) */ /* *p = wrong_type_argument(TSor_symbol_string, *p); */ /* } */ /* void */ /* check_type_or_string_symbol(object *p) */ /* { */ /* while (type_of(*p) != t_symbol && type_of(*p) != t_string) */ /* *p = wrong_type_argument(TSor_string_symbol, *p); */ /* } */ /* static void */ /* check_type_or_symbol_string_package(object *p) */ /* { */ /* while (type_of(*p) != t_symbol && */ /* type_of(*p) != t_string && */ /* type_of(*p) != t_package) */ /* *p = wrong_type_argument(TSor_symbol_string_package, */ /* *p); */ /* } */ /* void */ /* check_type_package(object *p) */ /* { */ /* while (type_of(*p) != t_package) */ /* *p = wrong_type_argument(sLpackage, *p); */ /* } */ /* void */ /* check_type_string(object *p) */ /* { */ /* while (type_of(*p) != t_string) */ /* *p = wrong_type_argument(sLstring, *p); */ /* } */ /* static void */ /* check_type_bit_vector(object *p) */ /* { */ /* while (type_of(*p) != t_bitvector) */ /* *p = wrong_type_argument(sLbit_vector, *p); */ /* } */ /* void */ /* check_type_cons(object *p) */ /* { */ /* while (!consp(*p)) */ /* *p = wrong_type_argument(sLcons, *p); */ /* } */ /* void */ /* check_type_stream(object *p) */ /* { */ /* while (type_of(*p) != t_stream) */ /* *p = wrong_type_argument(sLstream, *p); */ /* } */ /* /\* Thankfully we can do this bit of non-lispy c stuff since we pass by reference. FIXME*\/ */ /* void */ /* check_type_readtable_no_default(object *p) { */ /* if (type_of(*p) != t_readtable) */ /* *p = wrong_type_argument(sLreadtable, *p); */ /* } */ /* void */ /* check_type_readtable(object *p) { */ /* if (*p==Cnil) */ /* *p=standard_readtable; */ /* check_type_readtable_no_default(p); */ /* } */ /* #ifdef UNIX */ /* void */ /* check_type_or_Pathname_string_symbol(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_pathname && */ /* t != t_string && t != t_symbol) */ /* *p = wrong_type_argument( */ /* TSor_pathname_string_symbol, *p); */ /* } */ /* #endif */ /* void */ /* check_type_or_pathname_string_symbol_stream(object *p) */ /* { */ /* enum type t; */ /* while ((t = type_of(*p)) != t_pathname && */ /* t != t_string && t != t_symbol && t != t_stream) */ /* *p = wrong_type_argument( */ /* TSor_pathname_string_symbol_stream, *p); */ /* } */ /* void */ /* check_type_random_state(object *p) */ /* { */ /* while (type_of(*p) != t_random) */ /* *p = wrong_type_argument(sLrandom_state, *p); */ /* } */ /* void */ /* check_type_hash_table(object *p) */ /* { */ /* while (type_of(*p) != t_hashtable) */ /* *p = wrong_type_argument(sLhash_table, *p); */ /* } */ /* void */ /* check_type_array(object *p) */ /* { */ /* BEGIN: */ /* switch (type_of(*p)) { */ /* case t_array: */ /* case t_vector: */ /* case t_string: */ /* case t_bitvector: */ /* return; */ /* default: */ /* *p = wrong_type_argument(sLarray, *p); */ /* goto BEGIN; */ /* } */ /* } */ /* static void */ /* check_type_vector(object *p) */ /* { */ /* BEGIN: */ /* switch (type_of(*p)) { */ /* case t_vector: */ /* case t_string: */ /* case t_bitvector: */ /* return; */ /* default: */ /* *p = wrong_type_argument(sLvector, *p); */ /* goto BEGIN; */ /* } */ /* } */ enum type t_vtype; int vtypep_fn(object x) {return type_of(x)==t_vtype;} void Check_type(object *x,int (*p)(object),object n) { object s1,s2; s1=make_simple_string("Supply a new value"); s2=make_simple_string("~S is not of type ~S."); for (;!p(*x);*x=Ieval1(read_object(sLAstandard_inputA->s.s_dbind))) Icall_continue_error_handler(s1,sKwrong_type_argument,s2,2,*p,n); } /* void */ /* check_type(object x, int t) */ /* {if (type_of(x) !=t) */ /* FEerror("~s is not a ~a",2, */ /* x,make_simple_string(tm_table[t].tm_name +1)); */ /* } */ 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,""); DEFUN("TYPE-OF-C",object,siLtype_of_c,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { fixnum i; switch (type_of(x)) { case t_fixnum: i=fix(x); return (!i || i==1 ? sLbit : (i>0 ? sSnon_negative_fixnum : sLfixnum)); case t_bignum: return big_sign(x)<0 ? sLbignum : sSnon_negative_bignum; case t_ratio: return sLratio; case t_shortfloat: return sLshort_float; case t_longfloat: return sLlong_float; case t_complex: return sLcomplex; case t_character: if (char_font(x) != 0 || char_bits(x) != 0) return sLcharacter; { i = char_code(x); if ((' ' <= i && i < '\177') || i == '\n') return sLstandard_char; return sLbase_char; } case t_symbol: if (x==Cnil) return sLnull; if (x==Ct) return sLboolean; if (x->s.s_hpack == keyword_package) return sLkeyword; return sLsymbol; case t_package: return sLpackage; case t_cons: return sLcons; case t_hashtable: return sLhash_table; case t_array: return sLarray; case t_simple_vector: case t_vector: return sLvector; case t_simple_string:/*FIXME?*/ case t_string: return sLstring; case t_simple_bitvector: case t_bitvector: return sLbit_vector; case t_structure: return S_DATA(x->str.str_def)->name; case t_stream: if ((x->sm.sm_mode == smm_input) || (x->sm.sm_mode == smm_output) || (x->sm.sm_mode == smm_probe) || (x->sm.sm_mode == smm_io)) return sLfile_stream; if ((x->sm.sm_mode == smm_string_input) || (x->sm.sm_mode == smm_string_output)) return sLstring_stream; if (x->sm.sm_mode == smm_synonym || x->sm.sm_mode == smm_file_synonym) return sLsynonym_stream; if (x->sm.sm_mode == smm_broadcast) return sLbroadcast_stream; if (x->sm.sm_mode == smm_concatenated) return sLconcatenated_stream; if (x->sm.sm_mode == smm_two_way) return sLtwo_way_stream; if (x->sm.sm_mode == smm_echo) return sLecho_stream; #ifdef USER_DEFINED_STREAMS if (x->sm.sm_mode == (int)smm_user_defined) return x->sm.sm_object1->str.str_self[8]; #endif return sLstream; case t_readtable: return sLreadtable; case t_pathname: if (x->d.tt) return sLlogical_pathname; return sLpathname; case t_random: return sLrandom_state; case t_function: return sLcompiled_function; default: error("not a lisp data object"); } return Cnil; } DEF_ORDINARY("IN-CALL",sSin_call,SI,""); DEF_ORDINARY("OUT-CALL",sSout_call,SI,""); DEFVAR("*PROFILING*",sSAprofilingA,SI,sLnil,""); DEF_ORDINARY("FLOOR",sLfloor,LISP,""); DEF_ORDINARY("CEILING",sLceiling,LISP,""); DEF_ORDINARY("TRUNCATE",sLtruncate,LISP,""); DEF_ORDINARY("EXP",sLexp,LISP,""); DEF_ORDINARY("/",sLD,LISP,""); DEF_ORDINARY("COMMON",sScommon,SI,""); DEF_ORDINARY("NULL",sLnull,LISP,""); DEF_ORDINARY("CONS",sLcons,LISP,""); DEF_ORDINARY("LIST",sLlist,LISP,""); DEF_ORDINARY("PROPER-LIST",siLproper_list,SI,""); 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("FUNCTION-IDENTIFIER",sLfunction_identifier,SI,""); DEF_ORDINARY("COMPILED-FUNCTION",sLcompiled_function,LISP,""); /* DEF_ORDINARY("INTERPRETED-FUNCTION",siLinterpreted_function,SI,""); */ DEF_ORDINARY("PATHNAME",sLpathname,LISP,""); DEF_ORDINARY("CHARACTER",sLcharacter,LISP,""); DEF_ORDINARY("NUMBER",sLnumber,LISP,""); DEF_ORDINARY("RATIONAL",sLrational,LISP,""); DEF_ORDINARY("REAL",sLreal,LISP,""); DEF_ORDINARY("FLOAT",sLfloat,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("SEQIND",sSseqind,SI,""); DEF_ORDINARY("RNKIND",sSrnkind,SI,""); DEF_ORDINARY("CHAR",sLchar,LISP,""); DEF_ORDINARY("NON-NEGATIVE-CHAR",sSnon_negative_char,SI,""); DEF_ORDINARY("NEGATIVE-CHAR",sSnegative_char,SI,""); DEF_ORDINARY("SIGNED-CHAR",sSsigned_char,SI,""); DEF_ORDINARY("UNSIGNED-CHAR",sSunsigned_char,SI,""); DEF_ORDINARY("SHORT",sSshort,SI,""); DEF_ORDINARY("NON-NEGATIVE-SHORT",sSnon_negative_short,SI,""); DEF_ORDINARY("NEGATIVE-SHORT",sSnegative_short,SI,""); DEF_ORDINARY("SIGNED-SHORT",sSsigned_short,SI,""); DEF_ORDINARY("UNSIGNED-SHORT",sSunsigned_short,SI,""); DEF_ORDINARY("NON-NEGATIVE-INT",sSnon_negative_int,SI,""); DEF_ORDINARY("NEGATIVE-INT",sSnegative_int,SI,""); DEF_ORDINARY("SIGNED-INT",sSsigned_int,SI,""); DEF_ORDINARY("UNSIGNED-INT",sSunsigned_int,SI,""); DEF_ORDINARY("FIXNUM",sLfixnum,LISP,""); DEF_ORDINARY("NON-NEGATIVE-FIXNUM",sSnon_negative_fixnum,SI,""); DEF_ORDINARY("NEGATIVE-FIXNUM",sSnegative_fixnum,SI,""); DEF_ORDINARY("NON-NEGATIVE-BIGNUM",sSnon_negative_bignum,SI,""); DEF_ORDINARY("NEGATIVE-BIGNUM",sSnegative_bignum,SI,""); DEF_ORDINARY("SIGNED-FIXNUM",sSsigned_fixnum,SI,""); DEF_ORDINARY("UNSIGNED-FIXNUM",sSunsigned_fixnum,SI,""); DEF_ORDINARY("LFIXNUM",sSlfixnum,SI,""); DEF_ORDINARY("NON-NEGATIVE-LFIXNUM",sSnon_negative_lfixnum,SI,""); DEF_ORDINARY("NEGATIVE-LFIXNUM",sSnegative_lfixnum,SI,""); DEF_ORDINARY("SIGNED-LFIXNUM",sSsigned_lfixnum,SI,""); DEF_ORDINARY("UNSIGNED-LFIXNUM",sSunsigned_lfixnum,SI,""); 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("OUTPUT-STREAM-P",sLoutput_stream_p,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("*",sLA,LISP,""); DEF_ORDINARY("PLUSP",sLplusp,LISP,""); DEF_ORDINARY("FILE-STREAM",sLfile_stream,LISP,""); DEF_ORDINARY("INPUT-STREAM",sLinput_stream,SI,""); DEF_ORDINARY("OUTPUT-STREAM",sLoutput_stream,SI,""); /* logical pathnames exist even in non ansi gcl */ DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,""); DEF_ORDINARY("BASE-CHAR",sLbase_char,LISP,""); 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,""); DEFCONST("CHAR-LENGTH", sSchar_length, SI,small_fixnum(CHAR_SIZE), "Size in bits of a character"); DEFCONST("SHORT-LENGTH", sSshort_length, SI,small_fixnum(CHAR_SIZE*sizeof(short)), "Size in bits of a short integer"); DEFCONST("INT-LENGTH", sSint_length, SI,small_fixnum(CHAR_SIZE*sizeof(int)), "Size in bits of an int"); DEFCONST("FIXNUM-LENGTH", sSfixnum_length, SI,small_fixnum(CHAR_SIZE*sizeof(fixnum)), "Size in bits of a fixnum"); DEFCONST("LFIXNUM-LENGTH",sSlfixnum_length,SI,small_fixnum(CHAR_SIZE*sizeof(lfixnum)), "Size in bits of a long fixnum"); 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); } gcl-2.7.1/o/PaxHeaders/error.c0000644000000000000000000000013114726332530013103 xustar0030 mtime=1733932376.904079274 30 atime=1744339825.487479247 29 ctime=1744351535.47490929 gcl-2.7.1/o/error.c0000644000175000017500000003347014726332530012511 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.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) && errno!=ENOMEM && ihs_top>=ihs_org) 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)); 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 (!consp(x)) return(sSlambda_block); return(x->c.c_car); } if (y == sSlambda_block_closure) { x = x->c.c_cdr; if (!consp(x)) return(sSlambda_block_closure); x = x->c.c_cdr; if (!consp(x)) return(sSlambda_block_closure); x = x->c.c_cdr; if (!consp(x)) return(sSlambda_block_closure); x = x->c.c_cdr; if (!consp(x)) 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_cfun: */ /* return(x->cf.cf_name); */ case t_function: return(Cnil); 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("IHS-TOP",object,fSihs_top,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { fixnum i=ihs_top-ihs_org; for (;i>0 && type_of(ihs_org[i].ihs_function)==t_function && ihs_org[i].ihs_function->fun.fun_self==FFN(fSihs_top);i--); RETURN1(make_fixnum(i)); } DEFUN("IHS-FUN",object,fSihs_fun,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { x0 = get_ihs_ptr(x0)->ihs_function; RETURN1(x0); } DEFUN("IHS-VS",object,fSihs_vs,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { 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; if (frs_org <= p && p <= frs_top) return(p); ILLEGAL: FEerror("~S is an illegal frs index.", 1, x); return NULL; } DEFUN("FRS-TOP",object,fSfrs_top,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { RETURN1((make_fixnum(frs_top - frs_org))); } DEFUN("FRS-VS",object,fSfrs_vs,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { x0 = make_fixnum(get_frame_ptr(x0)->frs_lex - vs_org); RETURN1(x0); } DEFUN("FRS-BDS",object,fSfrs_bds,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { x0=make_fixnum(get_frame_ptr(x0)->frs_bds_top - bds_org); RETURN1(x0); } DEFUN("FRS-CLASS",object,fSfrs_class,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { enum fr_class c; 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("FRS-TAG",object,fSfrs_tag,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { x0 = get_frame_ptr(x0)->frs_val; RETURN1(x0); } DEFUN("FRS-IHS",object,fSfrs_ihs,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { 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; if (bds_org <= p && p <= bds_top) return(p); ILLEGAL: FEerror("~S is an illegal bds index.", 1, x); return NULL; } DEFUN("BDS-TOP",object,fSbds_top,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { RETURN1((make_fixnum(bds_top - bds_org))); } DEFUN("BDS-VAR",object,fSbds_var,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { x0 = get_bds_ptr(x0)->bds_sym; RETURN1(x0); } DEFUN("BDS-VAL",object,fSbds_val,SI,1,1,NONE,IO,OO,OO,OO,(object x0),"") { RETURN1(get_bds_ptr(x0)->bds_val); } static object *get_vs_ptr(object x) { object *p; if (type_of(x) != t_fixnum) goto ILLEGAL; p = vs_org + fix(x); if (vs_org <= p && p < vs_top) return(p); ILLEGAL: FEerror("~S is an illegal vs index.", 1, x); return NULL; } DEFUN("VS-TOP",object,fSvs_top,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { object x; x = (make_fixnum(vs_top - vs_org)); RETURN1(x); } DEFUN("VS",object,fSvs,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { x0 = *get_vs_ptr(x0); RETURN1(x0); } DEFUN("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 */ if (type_of(x1)!=t_fixnum || fix(x1)>ihs_top-ihs_org || fix(x1)<0) RETURN1(Cnil); 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("INTERNAL-SUPER-GO",object,fSinternal_super_go,SI,3,3,NONE,OO,OO,OO,OO,(object tag,object x1,object x2),"") { frame_ptr fr; fixnum vals=(fixnum)fcall.valp; object *base=vs_top; 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("UNIVERSAL-ERROR-HANDLER",object,fSuniversal_error_handler,SI ,1,F_ARG_LIMIT,NONE,OO,OO,OO,OO, (object x0,object x1,object x2,object x3,object x4, object error_fmt_string,...),"") { va_list ap; object z,l,f; ufixnum n=INIT_NARGS(6); /* 5 args */ princ(x0,Cnil); putchar(' '); princ(x1,Cnil); putchar(' '); princ(x2,Cnil); putchar(' '); princ(x3,Cnil); putchar(' '); princ(x4,Cnil); putchar(' '); princ(error_fmt_string,Cnil); putchar(' '); va_start(ap,error_fmt_string); for (l=Cnil,f=OBJNULL;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL;) princ(z,Cnil); flush_stream(symbol_value(sLAstandard_outputA)); va_end(ap); printf("\nLisp initialization failed.\n"); exit(0); 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_socket(object x) { if (type_of(x) != t_stream || x->sm.sm_mode != smm_socket) FEwrong_type_argument(sSsocket,x); } void check_stream(object strm) { if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); } void check_arg_range(fixnum nargs,int n, int m) { if (nargs < n) FEwrong_no_args("Need at least ~D argument(s).",make_fixnum(n)); else if (nargs > m) FEwrong_no_args("Need no more than ~D argument(s).",make_fixnum(m)); } DEF_ORDINARY("TERMINAL-INTERRUPT",sSterminal_interrupt,SI,""); DEF_ORDINARY("WRONG-TYPE-ARGUMENT",sKwrong_type_argument,KEYWORD,""); DEF_ORDINARY("CONTROL-ERROR",sKcontrol_error,KEYWORD,""); DEF_ORDINARY("PROGRAM-ERROR",sKprogram_error,KEYWORD,""); DEF_ORDINARY("TOO-FEW-ARGUMENTS",sKtoo_few_arguments,KEYWORD,""); DEF_ORDINARY("TOO-MANY-ARGUMENTS",sKtoo_many_arguments,KEYWORD,""); DEF_ORDINARY("UNEXPECTED-KEYWORD",sKunexpected_keyword,KEYWORD,""); DEF_ORDINARY("INVALID-FORM",sKinvalid_form,KEYWORD,""); DEF_ORDINARY("UNBOUND-VARIABLE",sKunbound_variable,KEYWORD,""); DEF_ORDINARY("INVALID-VARIABLE",sKinvalid_variable,KEYWORD,""); DEF_ORDINARY("UNDEFINED-FUNCTION",sKundefined_function,KEYWORD,""); DEF_ORDINARY("INVALID-FUNCTION",sKinvalid_function,KEYWORD,""); DEF_ORDINARY("PACKAGE-ERROR",sKpackage_error,KEYWORD,""); DEF_ORDINARY("PARSE-ERROR",sKparse_error,KEYWORD,""); DEF_ORDINARY("READER-ERROR",sKreader_error,KEYWORD,""); 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.7.1/o/PaxHeaders/unixsave.c0000644000000000000000000000013214555557372013632 xustar0030 mtime=1706483450.808392729 30 atime=1744339826.403484968 30 ctime=1744351535.478909254 gcl-2.7.1/o/unixsave.c0000644000175000017500000000567414555557372013244 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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(Lsave)() { check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); coerce_to_filename(vs_base[0], FN1); _cleanup(); memory_save(kcl_self, FN1); exit(0); /* no return */ } #endif /* UNIXSAVE include */ void gcl_init_unixsave(void) { make_si_function("SAVE", siLsave); } gcl-2.7.1/o/PaxHeaders/mapfun.c0000644000000000000000000000013214771143501013237 xustar0030 mtime=1743046465.042889762 30 atime=1744339830.483510459 30 ctime=1744351535.490909147 gcl-2.7.1/o/mapfun.c0000644000175000017500000001261214771143501012637 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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. */ /* mapfun.c Mapping */ #include "include.h" /* Use of VS in mapfunctions: | | |-------| base -> | 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.7.1/o/PaxHeaders/user_init.c0000644000000000000000000000013214542551763013763 xustar0030 mtime=1703597043.344022966 30 atime=1744339830.267509109 30 ctime=1744351535.490909147 gcl-2.7.1/o/user_init.c0000644000175000017500000000007314542551763013361 0ustar00cammcamm#include "include.h" object user_init(void) {return Cnil;} gcl-2.7.1/o/PaxHeaders/usig.c0000644000000000000000000000013214776006046012727 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.306035098 30 ctime=1744351535.482909218 gcl-2.7.1/o/usig.c0000644000175000017500000001634114776006046012332 0ustar00cammcamm/* Copyright (C) 1994 W. Schelter Copyright (C) 2024 Camm Maguire 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 main_signal_handler(int,siginfo_t,void *); 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_sigaction = 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("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 DEFUN("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("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_))&(excepts_))) DEFUN("FPE_CODE",object,fSfpe_code,SI,2,2,NONE,II,IO,OO,OO,(fixnum x87sw,fixnum mxcsr),"") { RETURN1((object)FE_TEST(x87sw,mxcsr,FE_INVALID|FE_DIVBYZERO|FE_OVERFLOW|FE_UNDERFLOW|FE_INEXACT)); } #if defined(__MINGW32__) || defined(__CYGWIN__) DEFUN("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("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,siginfo_t *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)); #ifdef FPE_SET_CTXT_ADDR FPE_SET_CTXT_ADDR(v,FPE_ADDR(i,v)); #endif #ifdef FPE_CLR_CTXT_CWD FPE_CLR_CTXT_CWD(v); #endif } DEFCONST("+FE-LIST+",sSPfe_listP,SI,list(5, list(3,sLfloating_point_invalid_operation,make_fixnum(FPE_FLTINV),make_fixnum(FE_INVALID)), 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))),""); DEF_ORDINARY("FLOATING-POINT-ERROR",sSfloating_point_error,SI,""); static void sigpipe(int s,siginfo_t *a,void *b) { unblock_signals(SIGPIPE,SIGPIPE); perror(""); FEerror("Broken pipe", 0); } void sigint(int s,siginfo_t *a,void *b) { unblock_signals(SIGINT,SIGINT); terminal_interrupt(1); } static void sigalrm(int s,siginfo_t *a,void *b) { 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(int s,siginfo_t *a,void *b) { unblock_signals(SIGUSR1,SIGUSR1); ifuncall1(sSsigusr1_interrupt,Cnil); } static void sigio(int s,siginfo_t *a,void *b) {ifuncall1(sSsigio_interrupt,Cnil);} static void sigterm(int s,siginfo_t *a,void *b) {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.7.1/o/PaxHeaders/list.d0000644000000000000000000000013214773577455012752 xustar0030 mtime=1743716141.673683824 30 atime=1744340056.092936769 30 ctime=1744351535.578908358 gcl-2.7.1/o/list.d0000644000175000017500000001557214773577455012362 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 "num_include.h" #include "page.h" object car(x) object x; { if (x == Cnil) return(x); if (consp(x)) return(x->c.c_car); FEwrong_type_argument(sLlist, x); return(Cnil); } object cdr(x) object x; { if (x == Cnil) return(x); if (consp(x)) return(x->c.c_cdr); FEwrong_type_argument(sLlist, x); return(Cnil); } void stack_cons(void) { object d=vs_pop,a=vs_pop; *vs_top++ = make_cons(a,d); } object on_stack_list_vector_new(fixnum 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; } object on_stack_list(fixnum n,...) { object x,first; va_list ap; va_start(ap,n); first=va_arg(ap,object); x=on_stack_list_vector_new(n,first,ap); va_end(ap); return x; } 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 #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 && !stack_alloc_start) \ _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; } object append(object x, object y) { return n_cons(length(x),({object _t=x->c.c_car;x=x->c.c_cdr;_t;}),y); } object copy_list(x) object x; { object y; if (!consp(x)) return(x); y = make_cons(x->c.c_car, Cnil); vs_push(y); for (x = x->c.c_cdr; consp(x); 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 = x; return(vs_pop); } DEFUN("CONS",object,fLcons,LISP,2,2,NONE,OO,OO,OO,OO,(object a,object d),"") { object x=alloc_object(t_cons); x->c.c_car=a; x->c.c_cdr=d; RETURN1(x); } object make_list(fixnum n) { object x =Cnil ; while (n-- > 0) x = make_cons(Cnil, x); return x; } static fixnum list_count(fixnum nargs,object first,object l,va_list ap) { fixnum n; for (n=0;NEXT_ARG(nargs,ap,l,first,OBJNULL)!=OBJNULL;n++); return n; } DEFUN("LIST",object,fLlist,LISP,0,MAX_ARGS,NONE,OO,OO,OO,OO,(object first,...),"") { object x,l=Cnil; va_list ap; fixnum nargs=INIT_NARGS(0),n; va_start(ap,first); n=list_count(nargs,first,l,ap); va_end(ap); va_start(ap,first); x=n_cons(n,NEXT_ARG(nargs,ap,l,first,Cnil),NEXT_ARG(nargs,ap,l,first,Cnil)); va_end(ap); RETURN1(x); } DEFUN("LIST*",object,fLlistA,LISP,1,MAX_ARGS,NONE,OO,OO,OO,OO,(object first,...),"") { object x,l=Cnil; va_list ap; fixnum nargs=INIT_NARGS(0),n; va_start(ap,first); n=list_count(nargs,first,l,ap); va_end(ap); va_start(ap,first); x=n_cons(n-1,NEXT_ARG(nargs,ap,l,first,Cnil),NEXT_ARG(nargs,ap,l,first,Cnil)); va_end(ap); RETURN1(x); } void stack_list(void) { object *a; a=vs_base; vs_base[0]=n_cons(vs_top-vs_base,*a++,Cnil); 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; } DEFUN("RPLACA",object,fLrplaca,LISP,2,2,NONE,OO,OO,OO,OO,(object o,object c),"") { check_type_cons(&o); o->c.c_car = c; RETURN1(o); } DEFUN("RPLACD",object,fLrplacd,LISP,2,2,NONE,OO,OO,OO,OO,(object o,object d),"") { check_type_cons(&o); o->c.c_cdr = d; RETURN1(o); } void check_proper_list(alist) object alist; { object v; /* if (alist == Cnil) FEwrong_type_argument(sLlist, alist); */ for (v=alist ; consp(v) ; v=v->c.c_cdr); if (v != Cnil) TYPE_ERROR(alist,siLproper_list); } DEFUN("PROPER-LISTP",object,fSproper_listp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_proper_list(x); RETURN1(Ct); } bool member_eq(x, l) object x, l; { for (; consp(l); l = l->c.c_cdr) if (x == l->c.c_car) return(TRUE); return(FALSE); } void delete_eq(x, lp) object x, *lp; { for (; consp(*lp); lp = &(*lp)->c.c_cdr) if ((*lp)->c.c_car == x) { *lp = (*lp)->c.c_cdr; return; } } DEFUN("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"); sKinitial_element = make_keyword("INITIAL-ELEMENT"); } gcl-2.7.1/o/PaxHeaders/makefun.c0000644000000000000000000000013214733440601013376 xustar0030 mtime=1735278977.086650057 30 atime=1744339828.459497812 30 ctime=1744351535.482909218 gcl-2.7.1/o/makefun.c0000644000175000017500000001642114733440601013000 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #include "include.h" #include "funlink.h" #include "page.h" DEFUN("SET-FUNCTION-ENVIRONMENT",object,fSset_function_environment,SI,2,2,NONE,OO,OO,OO,OO, \ (object f,object env),"") { ufixnum n; object x,*p; if (type_of(f)!=t_function) TYPE_ERROR(f,sLcompiled_function); for (n=0,x=env;x!=Cnil;x=x->c.c_cdr,n++); if (n++) { { BEGIN_NO_INTERRUPT; p=(object *)alloc_relblock(n*sizeof(object)); END_NO_INTERRUPT; } *p++=(object)n; f->fun.fun_env=p; for (;env!=Cnil;env=env->c.c_cdr) *p++=env; } RETURN1(f); } #define PADDR(i) ((void *)(((fixnum *)sSPinit->s.s_dbind->a.a_self)[Mfix(i)])) #define POP_BITS(x_,y_) ({ufixnum _t=x_&((1<>=y_;_t;}) static object make_fun(void *addr,object data,object call,object env,ufixnum argd,ufixnum sizes) { object x; x=alloc_object(t_function); x->fun.fun_self=addr; x->fun.fun_data=data; x->fun.fun_argd=argd; x->fun.fun_plist=call;/*FIXME*/ x->fun.fun_minarg=POP_BITS(sizes,6); x->fun.fun_maxarg=POP_BITS(sizes,6); x->fun.fun_neval =POP_BITS(sizes,5); x->fun.fun_vv =POP_BITS(sizes,1); x->fun.fun_env=def_env; if ((void *)x->fun.fun_self==feval_src) x->d.tt=2; FFN(fSset_function_environment)(x,env); return x; } #define GET_DATA(d_,a_) ((d_)!=Cnil ? (d_) : ((a_) && (a_)->s.s_dbind!=OBJNULL && type_of((a_)->s.s_dbind)==t_cfdata ? (a_)->s.s_dbind : 0)) DEFUN("FUNCTION-ENVIRONMENT",object,fSfunction_environment,SI,1,1,NONE,OO,OO,OO,OO,(object f),"") { RETURN1(f->fun.fun_env[0]); } DEFUN("INIT-FUNCTION",object,fSinit_function,SI,7,7,NONE,OO,OO,OI,II, \ (object sc,object addr,object data,object env,\ fixnum key,fixnum argd,fixnum sizes),\ "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.") { object s,d,m,i,fun,c; fixnum z; m=sSPmemory; m=m ? m->s.s_dbind : m; m=m && m!=OBJNULL && type_of(m)==t_cfdata ? m : 0; d=data!=Cnil ? data : m; i=sSPinit; i=i ? i->s.s_dbind : i; if (is_text_addr(addr)||(get_pageinfo(addr)&&!is_bigger_fixnum(addr))||!i||i==OBJNULL) s=addr; else { massert(type_of(addr)==t_fixnum); s=i->v.v_self[fix(addr)]; } z=type_of(sc)==t_cons && sc->c.c_car==sSmacro; /*FIXME limited no. of args.*/ sc=z ? sc->c.c_cdr : sc; sc=type_of(sc)==t_function ? sc->fun.fun_plist : sc; c=type_of(sc)==t_symbol ? Cnil : sc; fun=make_fun(s,d,c,env,argd,sizes); if (i && key>=0 && d) set_key_struct((void *)i->v.v_self[key],d); if (sc!=c) { fSfset(sc,fun); if (z) sc->s.s_mflag=TRUE; } return fun; } #ifdef STATIC_FUNCTION_POINTERS object fSinit_function(object x,object y,object z,object w,fixnum a,fixnum b,fixnum c) { return FFN(fSinit_function)(x,y,z,w,a,b,c); } #endif DEFUN("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, object (*fn) (/* ??? */), unsigned int argd) { object sym = make_si_ordinary(strg); 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); fSinit_function(sym,(void *)fn,Cnil,Cnil,-1, rt | (at<ma? 1 : 0)<<18)); /* fSfset(sym, fSmakefun(sym,fn,argd)); */ put_fn_procls(sym,argd,1,Ct,Ct); } void LISP_makefun(char *strg, object (*fn) (/* ??? */), unsigned int argd) { object sym = make_ordinary(strg); 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); fSinit_function(sym,(void *)fn,Cnil,Cnil,-1, rt | (at<ma? 1 : 0)<<18)); put_fn_procls(sym,argd,1,Ct,Ct); } void GMP_makefunb(char *strg, object (*fn)(),unsigned int argd,object p) { object sym = make_gmp_ordinary(strg); 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); fSinit_function(sym,(void *)fn,Cnil,Cnil,-1, rt | (at<ma? 1 : 0)<<18)); put_fn_procls(sym,argd,1,sLinteger,p); } void SI_makefunm(char *strg, object (*fn) (/* ??? */), unsigned int argd) { object sym = make_si_ordinary(strg); 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); fSinit_function(sym,(void *)fn,Cnil,Cnil,-1, rt | (at<ma? 1 : 0)<<18)); /* fSfset(sym, fSmakefun(sym,fn,argd)); */ put_fn_procls(sym,argd,0,Ct,Ct); } void LISP_makefunm(char *strg, object (*fn) (/* ??? */), unsigned int argd) { object sym = make_ordinary(strg); 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); fSinit_function(sym,(void *)fn,Cnil,Cnil,-1, rt | (at<ma? 1 : 0)<<18)); /* fSfset(sym, fSmakefun(sym,fn,argd)); */ put_fn_procls(sym,argd,0,Ct,Ct); } DEFUN("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.7.1/o/PaxHeaders/multival.c0000644000000000000000000000013214555557372013625 xustar0030 mtime=1706483450.804392729 30 atime=1744339816.919425762 30 ctime=1744351535.462909398 gcl-2.7.1/o/multival.c0000644000175000017500000000565614555557372013237 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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; if (vs_top-vs_base > MULTIPLE_VALUES_LIMIT) FEerror("Too many function call values", 0); } LFD(Lvalues_list)(void) { object x; check_arg(1); x = vs_base[0]; vs_top = vs_base; while (!endp(x)) { vs_push(MMcar(x)); x = MMcdr(x); } if (vs_top == vs_base) vs_base[0] = Cnil; if (vs_top-vs_base > MULTIPLE_VALUES_LIMIT) FEerror("Too many function call values", 0); } 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(1+MULTIPLE_VALUES_LIMIT)); 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.7.1/o/PaxHeaders/bzero.c0000644000000000000000000000013214771064316013100 xustar0030 mtime=1743022286.268134487 30 atime=1744340055.728934445 30 ctime=1744351535.490909147 gcl-2.7.1/o/bzero.c0000755000175000017500000000014714771064316012503 0ustar00cammcamm#include void bzero(void *b, size_t length) { char *c=b; while(length-->0) *c++ = 0; } gcl-2.7.1/o/PaxHeaders/bind.c0000644000000000000000000000013114555557372012703 xustar0029 mtime=1706483450.80039273 30 atime=1744339814.215408895 30 ctime=1744351535.458909434 gcl-2.7.1/o/bind.c0000644000175000017500000006240514555557372012311 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 (stringp(form)) { 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; } /* else if (optional[i].opt_init == v) */ /* 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; } /* else if (keyword[i].key_init == v) */ /* special_processed = TRUE; */ for (i = 0; i < naux; i++) if (aux[i].aux_var == v) { aux[i].aux_spp = Ct; special_processed = TRUE; } /* else if (aux[i].aux_init == v) */ /* 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 (stringp(form)) { 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 (stringp(form)) { 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; 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; }}} 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 ? Cnil : m==-1 ? OBJNULL : 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.7.1/o/PaxHeaders/eval.c0000644000000000000000000000013214760704751012710 xustar0030 mtime=1740868073.423094011 30 atime=1744340055.676934114 30 ctime=1744351535.454909469 gcl-2.7.1/o/eval.c0000644000175000017500000006542714760704751012324 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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; /* for t_sfun,t_gfun with args on vs stack */ #define POP_BITS(x_,y_) ({ufixnum _t=x_&((1<>=y_;_t;}) #define COERCE_ARG(a,type) \ ({enum ftype _t=type;\ _t==f_object ? a : (_t==f_fixnum ? (object)(fixint(a)) : (object)otoi(a));}) #define UNCOERCE_ARG(a,type) \ ({enum ftype _t=type;\ _t==f_object ? a : (_t==f_fixnum ? make_fixnum((fixnum)a) : make_integer((GEN)a));}) #include "apply_n.h" static object quick_call_function_vec(object fun,ufixnum n,object *b) { return c_apply_n_fun(fun,n,b); } static object quick_call_function_vec_coerce(object fun,ufixnum n,object *b) { register object res; ufixnum argd,j; enum ftype restype; object *tmp; argd=fun->fun.fun_argd; restype = POP_BITS(argd,2); if (argd) { static object q[MAX_ARGS+1]; for (tmp=q,j=0;j1) memmove(vals,vs_base+1,(n-1)*sizeof(*vals)); vs_top=(vals-1)+n; } else vs_top=base; return n>0 ? o : Cnil; } object funcall_vec(object fun,fixnum n,object *b) { ufixnum m=labs(n),l=m; object x; if (n<0) for (l=m-1,x=b[l];x!=Cnil;l++,x=x->c.c_cdr); fcall.argd=n; fcall.fun=fun; if (lfun.fun_minarg) { FEtoo_few_arguments(b,b+l); return Cnil; } if (l>fun->fun.fun_maxarg) { FEtoo_many_arguments(b,b+l); return Cnil; } return quick_call_function_vec_coerce(fun,m,b); } static object funcall_ap(object fun,fixnum n,va_list ap) { static object b[MAX_ARGS+1]; object *t=b; ufixnum j=labs(n),i; for (i=j;i--;) *t++=va_arg(ap,object); if (n<0 && fun->fun.fun_minarg>(j-1)) { object x=*--t; for (i=fun->fun.fun_minarg-(j-1);i--;*t++=x->c.c_car,x=x->c.c_cdr,n--) if (x==Cnil) FEtoo_few_arguments(b,t); *t++=x; } return funcall_vec(fun,n,b); } static void quick_call_function(object fun) { ufixnum n; object *base; base=vs_base; n=vs_top-vs_base; if (nfun.fun_minarg) { FEtoo_few_arguments(base,vs_top); return; } if (n>fun->fun.fun_maxarg) { FEtoo_many_arguments(base,vs_top); return; } fcall.argd=n; fcall.valp=(fixnum)(base+1); fcall.fun=fun; base[0]=quick_call_function_vec_coerce(fun,n,vs_base); vs_base=base; if (!fun->fun.fun_neval && !fun->fun.fun_vv) vs_top=base+1; return; } void Iinvoke_c_function_from_value_stack(object (*f)(), ufixnum argd) { static union lispunion fun; extern void quick_call_function(object);/*FIXME*/ set_type_of(&fun,t_function); fun.fun.fun_self=f; fun.fun.fun_data=Cnil; fun.fun.fun_plist=Cnil; fun.fun.fun_argd=F_TYPES(argd); fun.fun.fun_minarg=F_MIN_ARGS(argd); fun.fun.fun_maxarg=F_MAX_ARGS(argd);; if (!(argd&ONE_VAL)) { fun.fun.fun_neval=31; fun.fun.fun_vv=1; } quick_call_function((object)&fun); } static object kar(object x) { if (consp(x)) return(x->c.c_car); FEwrong_type_argument(sLcons, x); return(Cnil); } void funcall(object fun) { /* object VOL sfirst=NULL; */ /* wipe_stack(&sfirst); */ /* { */ object temporary=OBJNULL; object x=OBJNULL; object * VOL top=NULL; object *lex=NULL; bds_ptr old_bds_top=NULL; VOL bool b=0; bool c=0; DEBUG_AVMA TOP: if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { /* case t_cfun: */ /* MMcall(fun); */ /* CHECK_AVMA; return; */ case t_function: {int i=Rset; if (!i) {ihs_check;ihs_push(fun);} quick_call_function(fun); if (!i) ihs_pop(); } return; case t_symbol: { object x = fun->s.s_gfdef; if (x!=OBJNULL) { fun = x; goto TOP;} else FEundefined_function(fun); } /* case t_ifun: */ /* { */ /* object x = fun->ifn.ifn_self; */ /* if (x) { fun = x; /\* ihs_check;ihs_push(fun); *\/break;} */ /* else */ /* FEundefined_function(fun); */ /* } */ case t_cons: if (fun->c.c_car!=sLlambda && fun->c.c_car!=sSlambda_closure && fun->c.c_car!=sSlambda_block && fun->c.c_car!=sSlambda_block_expanded && fun->c.c_car!=sSlambda_block_closure) FEinvalid_function(fun); 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_function: quick_call_function(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; */ 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; */ 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; */ 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; */ 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; */ 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; */ 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 TOP: switch (type_of(fun)) { /* case t_cfun: */ /* (*fun->cf.cf_self)();return;break; */ case t_function: quick_call_function(fun); return;break; 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); fun = fun->s.s_gfdef; goto TOP; } funcall_no_event(fun); } object Ievaln(object form,object *vals) { object *base=vs_top; eval(form); return unwind_vals(vals,base); } 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 (consp(form)) 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]; consp(x); 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 = VLEN(sSAbreak_pointsA->s.s_dbind); 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; ((void (*)())fun->s.s_sfdef)(MMcdr(form)); CHECK_AVMA; ihs_pop(); return; } /* x = lex_fd_sch(fun); */ for (x = lex_env[1]; consp(x); 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 (consp(fun) && 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; } if (consp(fun) && (MMcar(fun) == sSlambda_closure || MMcar(fun) == sSlambda_block || MMcar(fun) == sSlambda_block_closure)) { vs_push(x=fun); goto EVAL_ARGS; } FEinvalid_function(fun); } static void call_applyhook(object fun) { object ah; ah = symbol_value(siVapplyhook); stack_list(); 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); } object coerce_funcall_object_to_function(object fun) { switch (type_of(fun)) { case t_function: break; case t_symbol: if (fun->s.s_mflag || fun->s.s_sfdef!=NOT_SPECIAL || (fun=fun->s.s_gfdef)==OBJNULL) UNDEFINED_FUNCTION(fun); break; default: TYPE_ERROR(fun,list(3,sLor,sLsymbol,sLfunction)); break; } return fun; } static object funcall_apply(object fun,fixnum nargs,va_list ap) { object res,*vals=(object *)fcall.valp; fun=coerce_funcall_object_to_function(fun); res=funcall_ap(fun,nargs,ap); if (type_of(fun)==t_function && !fun->fun.fun_neval && !fun->fun.fun_vv && vals) vs_top=vals; return res; } DEFUNM("FUNCALL",object,fLfuncall,LISP,1,MAX_ARGS,NONE,OO,OO,OO,OO,(object fun,...),"") { va_list ap; object res; va_start(ap,fun); res=funcall_apply(fun,(abs(VFUN_NARGS)-1)*(VFUN_NARGS/abs(VFUN_NARGS)),ap); va_end(ap); return res; } DEFUNM("APPLY",object,fLapply,LISP,1,MAX_ARGS,NONE,OO,OO,OO,OO,(object fun,...),"") { va_list ap; object res; va_start(ap,fun); res=funcall_apply(fun,1-VFUN_NARGS,ap); va_end(ap); return res; } object apply_format_function(object x,object y,object z,object a,object b,object c) { return FFN(fLapply)(x,y,z,a,b,c); } DEFUNM("EVAL",object,fLeval,LISP,1,1,NONE,OO,OO,OO,OO,(object x0),"") { object *lex=lex_env,*base=vs_top; object *vals=(object *)fcall.valp; lex_new(); eval(x0); lex_env=lex; return unwind_vals(vals,base); } #ifdef STATIC_FUNCTION_POINTERS object fLeval(object x) { RETURN1(FFN(fLeval)(x)); } #endif /* DEFUN("EVAL-SRC",object,fSeval_src,SI,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { */ /* object fun=fcall.fun,f,*base=vs_top,*vals=(object *)fcall.valp; */ /* struct cons *p,*p1,*pp,*q,*qq; */ /* fixnum j,narg=VFUN_NARGS; */ /* va_list ap; */ /* f=fun->fun.fun_plist->c.c_cdr->c.c_cdr->c.c_car; */ /* princ(f->c.c_car,Cnil); */ /* if (f->c.c_car==sLlambda_block) {printf(" ");princ(f->c.c_cdr->c.c_car,Cnil);} */ /* printf("\n"); */ /* flush_stream(symbol_value(sLAstandard_outputA)); */ /* j=abs(narg)+1; */ /* if (narg < 0) j--; */ /* p=alloca((j+1)*sizeof(*p)); */ /* p1=p=(void *)p+((unsigned)p%sizeof(*p)); */ /* p->c_car=f; */ /* va_start(ap,first); */ /* for (;j--;first=NULL) { */ /* object x=(j || (narg < 0)) ? (first ? first : va_arg(ap,object)) : Cnil; */ /* if (j) { */ /* pp=p++; */ /* pp->c_cdr=(void *)p; */ /* p->c_car=x;/\* MMcons(sLquote,MMcons(x,Cnil)); *\/ */ /* } else p->c_cdr=x; */ /* } */ /* va_end(ap); */ /* for (j=0,p=p1;p!=(void *)Cnil;j++,p=(void *)p->c_cdr); */ /* q=alloca((2*j+1)*sizeof(*q)); */ /* q=(void *)q+((unsigned)q%sizeof(*q)); */ /* for (p=(void *)p1->c_cdr;p!=(void *)Cnil;p=(void *)p->c_cdr) { */ /* object x=p->c_car; */ /* p->c_car=(void *)(qq=q); */ /* qq->c_car=sLquote; */ /* qq->c_cdr=(void *)++q; */ /* qq=q++; */ /* qq->c_car=x; */ /* qq->c_cdr=Cnil; */ /* } */ /* eval((void *)p1); */ /* return unwind_vals(vals,base); */ /* } */ /* DEFUNM("EVAL-CFUN",object,fSeval_cfun,SI,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { */ /* object fun=fcall.fun,*base=vs_top,*vals=(object *)fcall.valp; */ /* void (*f)(); */ /* fixnum i,j,narg=VFUN_NARGS; */ /* va_list ap; */ /* f=(void *)fix(fun->fun.fun_plist->c.c_cdr->c.c_cdr->c.c_car); */ /* j=abs(narg)+((narg < 0) ? 0 : 1); */ /* va_start(ap,first); */ /* vs_base=vs_top; */ /* for (i=1;j--;) { */ /* object x=(j || (narg < 0)) ? (i ? (i=0,first) : va_arg(ap,object)) : Cnil; */ /* if (j) */ /* vs_push(x); */ /* else for (;x!=Cnil;x=x->c.c_cdr) vs_push(x->c.c_car); */ /* } */ /* va_end(ap); */ /* f(); */ /* return unwind_vals(vals,base); */ /* } */ DEFUNM("EVAL-SRC",object,fSeval_src,SI,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { object fun=fcall.fun,f,*base=vs_top,*vals=(object *)fcall.valp; fixnum i,j,narg=VFUN_NARGS; va_list ap; f=fun->fun.fun_plist->c.c_cdr->c.c_cdr->c.c_car; j=labs(narg)+((narg < 0) ? 0 : 1); va_start(ap,first); vs_base=vs_top; for (i=1;j--;) { object x=(j || (narg < 0)) ? (i ? (i=0,first) : va_arg(ap,object)) : Cnil; if (j) vs_push(x); else for (;x!=Cnil;x=x->c.c_cdr) vs_push(x->c.c_car); } va_end(ap); if (type_of(f)==t_fixnum) ((void (*)())(fix(f)))(); else funcall(f); return unwind_vals(vals,base); } void *feval_src=(void *)FFN(fSeval_src); DEFUN("FSET-IN",object,fSfset_in,SI,3,3,NONE,OO,OO,OO,OO,(object sym,object src,object name),"") { object x; x=fSinit_function(list(6,Cnil,Cnil,src,Cnil,make_fixnum(0),name),(void *)FFN(fSeval_src),Cnil,Cnil,-1,0,(((1<<6)-1)<<6)|(((1<<5)-1)<<12)|(1<<17)); x->fun.fun_env=src_env; if (sym!=Cnil) fSfset(sym,x); RETURN1(x); } #ifdef STATIC_FUNCTION_POINTERS object fSfset_in(object sym,object src,object name) { RETURN1(FFN(fSfset_in)(sym,src,name)); } #endif 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); } DEFUN("CONSTANTP",object,fLconstantp,LISP,1,2,NONE,OO,OO,OO,OO,(object x0,...),"") { enum type tp=type_of(x0); RETURN1((tp==t_cons && x0->c.c_car!=sLquote)|| (tp==t_symbol && x0->s.s_stype!=stp_constant) ? Cnil : Ct); } 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); } object ifuncall4(object fun, object arg1, object arg2, object arg3,object arg4) { 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); vs_push(arg4); 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 > MAX_ARGS+1) FEerror("Call argument linit exceeded",0); frs_push(FRS_CATCH, make_cons(fname, make_fixnum(n))); if (nlj_active) nlj_active = FALSE; else funcall(fun); frs_pop(); } static object fcalln_general(object first,va_list ap) { int i=fcall.argd,n= SFUN_NARGS(i); 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))); } object fcalln1(object first,...) { va_list ap; object fun=fcall.fun; enum type tp; DEBUG_AVMA va_start(ap,first); tp=fun==OBJNULL ? -1 : type_of(fun); /* if(tp==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]); */ /* } */ 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(MAX_ARGS+1)); 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.7.1/o/PaxHeaders/assignment.c0000644000000000000000000000013214776006046014130 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.298035059 30 ctime=1744351535.458909434 gcl-2.7.1/o/assignment.c0000644000175000017500000003523014776006046013531 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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=Ieval1(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] = Ieval1(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); } DEFUN("SET",object,fLset,LISP,2,2,NONE,OO,OO,OO,OO,(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); } DEFUN("FUNCTION-NAME",object,fSfunction_name,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { switch(type_of(x)) { case t_function: x=Cnil; break; default: TYPE_ERROR(x,sLfunction); x=Cnil; break; } return x; } DEFUN("FSET",object,fSfset,SI,2,2,NONE,OO,OO,OO,OO,(object sym,object function),"") { object x; if (type_of(sym)!=t_symbol) sym=ifuncall1(sSfunid_to_sym,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 (type_of(function) == t_function) { 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) { function=function->c.c_cdr; sym->s.s_gfdef = function; sym->s.s_mflag = TRUE; } else { sym->s.s_gfdef = function; sym->s.s_mflag = FALSE; } sym->s.s_sfdef=NOT_SPECIAL;/*FIXME?*/ if (function->fun.fun_plist!=Cnil) { function->fun.fun_plist->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car=sym;/*FIXME*/ x=function->fun.fun_plist->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car; function->fun.fun_plist->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car=x==Cnil ? sLAload_truenameA->s.s_dbind : x; } 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,*vals; 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; vals=ZALLOCA(MULTIPLE_VALUES_LIMIT*sizeof(*vals)); vals[0]=Ievaln(form->c.c_cdr->c.c_car,vals+1); for (i=0,n=vs_top-vals;!endp(vars);i++,vars=vars->c.c_cdr) setq(vars->c.c_car,is.s_stype == stp_constant) FEinvalid_variable("Cannot unbind the constant ~S.", sym); sym->s.s_dbind = OBJNULL; RETURN1(sym); } object sStraced; DEFUN("FMAKUNBOUND",object,fLfmakunbound,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { object rsym; rsym=type_of(sym)==t_symbol ? sym : ifuncall1(sSfunid_to_sym,sym); if (rsym->s.s_sfdef != NOT_SPECIAL) { if (rsym->s.s_mflag) { if (symbol_value(sSAinhibit_macro_specialA) != Cnil) rsym->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) FEerror("~S, a special form, cannot be redefined.", 1, rsym); } remf(&(rsym->s.s_plist),sStraced); clear_compiler_properties(rsym,Cnil); rsym->s.s_gfdef = OBJNULL; rsym->s.s_mflag = FALSE; RETURN1(sym); } static void FFN(Fsetf)(object form) { object result=Cnil,*top=vs_top; for (;!endp(form);form=MMcddr(form)) { vs_top = top; if (endp(MMcdr(form))) FEinvalid_form("No value for ~S.", form->c.c_car); result=setf(MMcar(form), MMcadr(form)); } vs_base=top; vs_base[0]=result; vs_top=vs_base+1; } /* 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); */ /* result = setf(MMcar(form), MMcadr(form)); */ /* form = MMcddr(form); */ /* } while (!endp(form)); */ /* vs_top = vs_base = top; */ /* vs_base[0]=result; */ /* vs_top=vs_base+1; */ /* } */ /* } */ #define eval_push(form) \ { \ object *old_top = vs_top; \ \ *old_top = Ieval1(form); \ vs_top = old_top + 1; \ } static object setf(object place, object form) { object fun; object args; object x,result,y; int i; if (!consp(place)) { setq(place, result=Ieval1(form)); return result; } fun = place->c.c_car; if (type_of(fun) != t_symbol) goto OTHERWISE; args = place->c.c_cdr; { object p=lisp_package; char *s; if (fun->s.s_hpack==p && fun->s.s_name->st.st_self[0]=='C' && fun->s.s_name->st.st_self[VLEN(fun->s.s_name)-1]=='R' && VLEN(fun->s.s_name)!=3) { s=alloca(VLEN(fun->s.s_name)); s[0]='C'; memcpy(s+1,fun->s.s_name->st.st_self+2,VLEN(fun->s.s_name)-2); s[VLEN(fun->s.s_name)-1]=0; fun=fun->s.s_name->st.st_self[1]=='A' ? sLcar : sLcdr; args=MMcons(MMcons(find_symbol(make_simple_string(s),p),MMcons(args->c.c_car,Cnil)),Cnil); } } /*FIXME*/ if (fun == sLget) { object sym,val,key,deflt1; sym = Ieval1(car(args)); key = Ieval1(car(Mcdr(args))); deflt1 = Mcddr(args); if (consp(deflt1)) Ieval1(car(deflt1)); val = Ieval1(form); return putprop(sym,val,key); } if (fun == find_symbol(str("SYMBOL-FUNCTION"),lisp_package)) return Ieval1(MMcons(find_symbol(str("FSET"),system_package),MMcons(MMcar(args),MMcons(form,Cnil)))); if (fun == sLsbit) return Ieval1(MMcons(find_symbol(str("ASET"),system_package),MMcons(form,args))); if (fun == sLaref) return Ieval1(MMcons(find_symbol(str("ASET"),system_package),MMcons(form,args))); if (fun == sLsvref) return Ieval1(MMcons(find_symbol(str("SVSET"),system_package),append(args,MMcons(form,Cnil)))); if (fun == sLelt) return Ieval1(MMcons(find_symbol(str("ELT-SET"),system_package),append(args,MMcons(form,Cnil)))); if (fun == sLchar) return Ieval1(MMcons(find_symbol(str("CHAR-SET"),system_package),append(args,MMcons(form,Cnil)))); if (fun == sLschar) return Ieval1(MMcons(find_symbol(str("SCHAR-SET"),system_package),append(args,MMcons(form,Cnil)))); if (fun == sLfill_pointer) return Ieval1(MMcons(find_symbol(str("FILL-POINTER-SET"),system_package),append(args,MMcons(form,Cnil)))); if (fun == sLgethash) return Ieval1(MMcons(find_symbol(str("HASH-SET"),system_package),append(args,MMcons(form,Cnil)))); if (fun == sLcar) { x = Ieval1(Mcar(args)); result = Ieval1(form); if (!consp(x)) FEerror("~S is not a cons.", 1, x); Mcar(x) = result; return result; } if (fun == sLcdr) { x = Ieval1(Mcar(args)); result = Ieval1(form); if (!consp(x)) 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 || !consp(x)) 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); x = x->c.c_car; y = Ieval1(Mcar(args)); result = Ieval1(form); if (x == sLvector) { if (!TS_MEMBER(type_of(y),TS(t_vector)|TS(t_simple_vector)) || i >= VLEN(y))/*FIXME*/ goto OTHERWISE; y->v.v_self[i] = result; } else if (x == sLlist) { for (x = y; i > 0; --i) x = cdr(x); if (!consp(x)) goto OTHERWISE; x->c.c_car = result; } else { structure_set(y, x, i, result); } return result; 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 Ieval1(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 (!consp(var)) { 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 (!consp(var)) { 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 (!consp(var)) { 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 (!consp(var)) { 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]); } DEF_ORDINARY("CLEAR-COMPILER-PROPERTIES",sSclear_compiler_properties,SI,""); DEFUN("CLEAR-COMPILER-PROPERTIES",object,fSclear_compiler_properties,SI ,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { /* 2 args */ RETURN1(Cnil); } DEFUN("EMERGENCY-FSET",object,fSemergency_fset,SI ,2,2,NONE,OO,OO,OO,OO,(object sym,object function),"") { if (type_of(sym)!=t_symbol || sym->s.s_sfdef!=NOT_SPECIAL || consp(function)) { printf("Emergency fset: skipping %-.*s\n",(int)VLEN(sym->s.s_name),sym->s.s_name->st.st_self); RETURN1(Cnil); } sym->s.s_gfdef=function; sym->s.s_mflag=FALSE; RETURN1(Ct); } 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.7.1/o/PaxHeaders/bcmp.c0000644000000000000000000000013214542551763012703 xustar0030 mtime=1703597043.284022871 30 atime=1744340055.728934445 30 ctime=1744351535.486909183 gcl-2.7.1/o/bcmp.c0000755000175000017500000000026514542551763012307 0ustar00cammcamm#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.7.1/o/PaxHeaders/lastfile.c0000644000000000000000000000013214542551763013565 xustar0030 mtime=1703597043.316022922 30 atime=1744295002.453973093 30 ctime=1744351535.594908214 gcl-2.7.1/o/lastfile.c0000644000175000017500000000361514542551763013170 0ustar00cammcamm/* Mark end 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" /* How this works: Fdump_emacs dumps everything up to my_edata as text space (pure). The files of Emacs are written so as to have no initialized data that can ever need to be altered except at the first startup. This is so that those words can be dumped as sharable text. It is not possible to exercise such control over library files. So it is necessary to refrain from making their data areas shared. Therefore, this file is loaded following all the files of Emacs but before library files. As a result, the symbol my_edata indicates the point in data space between data coming from Emacs and data coming from libraries. */ char my_edata[] = "End of Emacs initialized data"; /* Help unexec locate the end of the .bss area used by Emacs (which isn't always a separate section in NT executables). */ char my_endbss[1]; /* The Alpha MSVC linker globally segregates all static and public bss data, so we must take both into account to determine the true extent of the bss area used by Emacs. */ static char _my_endbss[1]; char * my_endbss_static = _my_endbss; gcl-2.7.1/o/PaxHeaders/block.c0000644000000000000000000000013114555557372013061 xustar0029 mtime=1706483450.80039273 30 atime=1744339816.319422019 30 ctime=1744351535.458909434 gcl-2.7.1/o/block.c0000644000175000017500000000526614555557372012471 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. sLchelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.7.1/o/PaxHeaders/format.c0000644000000000000000000000013014575160702013243 xustar0030 mtime=1710547394.359799474 29 atime=1744339823.87546918 29 ctime=1744351535.47490929 gcl-2.7.1/o/format.c0000644000175000017500000017202614575160702012653 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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" #include "num_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,fixnum,fixnum,fixnum,fixnum,fixnum); 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_function(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_ppnewline(bool,bool); static void fmt_ppindent(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_proc_character(object,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_write(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; \ VOL object old_fmt_iteration_list; \ jmp_bufp VOL old_fmt_jmp_bufp; \ VOL int old_fmt_indents; \ VOL object old_fmt_string ; \ VOL object(*old_fmt_advance)(void) ; \ VOL void (*old_fmt_lt)(volatile bool,bool) ; \ 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_iteration_list = fmt_iteration_list; \ old_fmt_jmp_bufp = fmt_jmp_bufp; \ old_fmt_indents = fmt_indents; \ old_fmt_string = fmt_string ; \ old_fmt_advance=fmt_advance ; \ old_fmt_lt=fmt_lt ; \ 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_iteration_list = old_fmt_iteration_list; \ fmt_end = old_fmt_end; \ fmt_jmp_bufp = old_fmt_jmp_bufp; \ fmt_indents = old_fmt_indents; \ fmt_string = old_fmt_string ; \ fmt_advance=old_fmt_advance ; \ fmt_lt=old_fmt_lt ; \ 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 #define MAX_MINCOL 1024 #define BOUND_MINCOL(a_) ({fixnum _t=a_; _t=_t<0 ? 0 : _t;if (_t>MAX_MINCOL) _t=MAX_MINCOL;_t;}) typedef struct { fixnum fmt_param_type; fixnum fmt_param_value; object fmt_param_object; } format_parameter; format_parameter fmt_param[100]; VOL format_parameter *fmt_paramp; #define FMT_PARAM (fmt_paramp) #undef writec_stream #define writec_stream(a,b) writec_pstream(a,b) #undef writestr_stream #define writestr_stream(a,b) writestr_pstream(a,b) #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" }; fixnum fmt_spare_spaces; fixnum 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_base(void) { if (fmt_index >= fmt_end) fmt_error("arguments exhausted"); return(fmt_base[fmt_index++]); } static object fmt_advance_pprint_pop(void) { object x; if (ifuncall4(sSpprint_quit,fmt_base[0],fmt_base[1],fmt_stream,fmt_base[2])!=Cnil) longjmp(*fmt_jmp_bufp, 1);/*FIXME :*/ fmt_base[2]=number_plus(fmt_base[2],make_fixnum(1)); x=fmt_base[0]->c.c_car; fmt_base[0]=fmt_base[0]->c.c_cdr; return x; } static object (*fmt_advance)(void)=fmt_advance_base; static void (*fmt_lt)(volatile bool,bool)=fmt_justification; static int rd_ex_ch(int f,int *s) { char *p1[]={"Return","Space","Rubout","Page","Tab","Backspace","Linefeed","Newline",0},**p,*ch; int c1[]={'\r',' ','\177','\f','\t','\b','\n','\n',0},*c,i; for (p=p1,c=c1,i=ctl_index;*p && *c;p++,c++) { if (f==(*p)[0] && *s==(*p)[1]) { for (ch=*p+2,ctl_index=i;*ch && *ch==ctl_advance();ch++); if (!*ch) { *s=ctl_advance(); return *c; } } } ctl_index=i; return f; } static void format(object fmt_stream0, int ctl_origin0, int ctl_end0) { int c, n; fixnum i,j,sn; 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': sn=1; DIGIT: i = 0; do { j = i*10 + (c - '0'); i=j>=i ? j : MOST_POSITIVE_FIX; c = ctl_advance(); } while (isDigit(c)); fmt_param[n].fmt_param_type = fmt_int; fmt_param[n].fmt_param_value = sn*i; fmt_param[n].fmt_param_object=make_fixnum(fmt_param[n].fmt_param_value); break; case '+': case '-': sn=c=='+' ? 1 : -1; c = ctl_advance(); if (!isDigit(c)) fmt_error("digit expected"); goto DIGIT; case '\'': fmt_param[n].fmt_param_type = fmt_char; fmt_param[n].fmt_param_value = ctl_advance(); c = ctl_advance(); if (c != ',') fmt_param[n].fmt_param_value=rd_ex_ch(fmt_param[n].fmt_param_value,&c); fmt_param[n].fmt_param_object = code_char(fmt_param[n].fmt_param_value); 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); /* if (fmt_param[n].fmt_param_value==MOST_NEGATIVE_FIX) */ fmt_param[n].fmt_param_object=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; fmt_param[n].fmt_param_object=x; } else if (type_of(x) == t_bignum) { fmt_param[n].fmt_param_type = fmt_int; fmt_param[n].fmt_param_value = MOST_NEGATIVE_FIX; fmt_param[n].fmt_param_object = x; } 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; fmt_param[n].fmt_param_object=make_fixnum(fmt_param[n].fmt_param_value); 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(); if (!colon) if (c == ':') { colon = 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 'w': case 'W': fmt_write(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 '_': fmt_ppnewline(colon, atsign); break; case 'I': case 'i': fmt_ppindent(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_function(colon, atsign); break; case '<': fmt_lt(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(fixnum i, fixnum *p, fixnum t, fixnum 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) { fixnum 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); mincol=BOUND_MINCOL(mincol); 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_write(bool colon, bool atsign) { object x; bds_ptr old_bds_top=bds_top; fmt_max_param(0); x = fmt_advance(); if (colon) bds_bind(sLAprint_prettyA,Ct); if (atsign) { bds_bind(sLAprint_levelA,Cnil); bds_bind(sLAprint_lengthA,Cnil); } fSwrite_int(x,fmt_stream); bds_unwind(old_bds_top); } static void fmt_S_expression(bool colon, bool atsign) { fixnum 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); mincol=BOUND_MINCOL(mincol); 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 (type_of(x)==t_character)/*FIXME*/ return fmt_proc_character(x,0,1); 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) { fixnum mincol=0, padchar=0, commachar=0, commainterval=0; fmt_max_param(4); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_set_param(3, &commainterval, fmt_int, 3); fmt_integer(fmt_advance(), colon, atsign, 10, mincol, padchar, commachar, commainterval); } static void fmt_binary(bool colon, bool atsign) { fixnum mincol=0, padchar=0, commachar=0, commainterval=0; fmt_max_param(4); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_set_param(3, &commainterval, fmt_int, 3); fmt_integer(fmt_advance(), colon, atsign, 2, mincol, padchar, commachar, commainterval); } static void fmt_octal(bool colon, bool atsign) { fixnum mincol=0, padchar=0, commachar=0, commainterval=0;; fmt_max_param(4); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_set_param(3, &commainterval, fmt_int, 3); fmt_integer(fmt_advance(), colon, atsign, 8, mincol, padchar, commachar, commainterval); } static void fmt_hexadecimal(bool colon, bool atsign) { fixnum mincol=0, padchar=0, commachar=0, commainterval=0;; fmt_max_param(4); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_set_param(3, &commainterval, fmt_int, 3); fmt_integer(fmt_advance(), colon, atsign, 16, mincol, padchar, commachar, commainterval); } static void fmt_radix(bool colon, bool atsign) { fixnum radix=0, mincol=0, padchar=0, commachar=0, commainterval=0; object x; int i, j, k; int s, t; bool b; fmt_max_param(5); fmt_set_param(0, &radix, fmt_int, -1); if (radix==-1) { 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, ' ', ',', 3); 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; STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); bds_bind(sLAprint_radixA,Cnil); bds_bind(sLAprint_baseA,make_fixnum(10)); princ(x,fmt_temporary_stream); bds_unwind1; bds_unwind1; 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_set_param(0, &radix, fmt_int, -1); fmt_set_param(1, &mincol, fmt_int, 0); fmt_set_param(2, &padchar, fmt_char, ' '); fmt_set_param(3, &commachar, fmt_char, ','); fmt_set_param(4, &commainterval, fmt_int, 3); 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, commainterval); } static void fmt_integer(object x, bool colon, bool atsign, fixnum radix, fixnum mincol, fixnum padchar, fixnum commachar, fixnum commainterval) { int l, l1; int s; mincol=BOUND_MINCOL(mincol); if (type_of(x) != t_fixnum && type_of(x) != t_bignum) { object fts,ftm;/*FIXME more comprehensive solution here, but this avoids some recursive use of the temporaries*/ ftm=make_string_output_stream(64); fts=ftm->sm.sm_object0; fts->st.st_fillp = 0; /* ftm->sm.sm_int0 = file_column(fmt_stream); */ STREAM_FILE_COLUMN(ftm) = file_column(fmt_stream); bds_bind(sLAprint_baseA,make_fixnum(radix)); princ(x,ftm); bds_unwind1; l = fts->st.st_fillp; mincol -= l; while (mincol-- > 0) writec_stream(padchar, fmt_stream); for (s = 0; l > 0; --l, s++) writec_stream(fts->st.st_self[s], fmt_stream); return; } fmt_temporary_string->st.st_fillp = 0; STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); bds_bind(sLAprint_baseA,make_fixnum(radix)); princ(x,fmt_temporary_stream); bds_unwind1; if (fmt_temporary_string->st.st_fillp>0&& fmt_temporary_string->st.st_self[fmt_temporary_string->st.st_fillp-1]=='.')/*FIXME*/ fmt_temporary_string->st.st_fillp--; 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%(commainterval) == 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_proc_character(object x,bool colon,bool atsign) { if (colon || atsign) { int i=colon ? 2 : 0; fmt_temporary_string->st.st_fillp = 0; STREAM_FILE_COLUMN(fmt_temporary_stream) = 0; if (x->ch.ch_code==' ') writestr_stream("#\\Space",fmt_temporary_stream); else prin1(x, fmt_temporary_stream); for (; i < fmt_temporary_string->st.st_fillp; i++) writec_stream(fmt_tempstr(i), fmt_stream); } else writec_stream(x->ch.ch_code, fmt_stream); } static void fmt_character(bool colon, bool atsign) { object x; fmt_max_param(0); x = fmt_advance(); check_type_character(&x); fmt_proc_character(x,colon,atsign); } static void fmt_fix_float(bool colon, bool atsign) { fixnum 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 = 10;/*FIXME*/ 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) { fixnum 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 = 9; 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) { fixnum 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) { fixnum 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) { fixnum 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) { fixnum 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) { fixnum 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) { fixnum 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_ppnewline(bool colon, bool atsign) { object k=colon ? (atsign ? sKmandatory : sKfill) : (atsign ? sKmiser : sKlinear); object f=get(k,sLfixnum,Cnil); fmt_max_param(0); massert(type_of(f)==t_fixnum); ifuncall2(find_symbol(make_simple_string("PPRINT-NEWLINE"),lisp_package),k,fmt_stream); } static void fmt_ppindent(bool colon, bool atsign) { object k=colon ? sKcurrent : sKblock; object f=get(k,sLfixnum,Cnil); fixnum n; fmt_max_param(1); fmt_set_param(0, &n, fmt_int, 0); massert(type_of(f)==t_fixnum); ifuncall3(find_symbol(make_simple_string("PPRINT-INDENT"),lisp_package),k,make_fixnum(n),fmt_stream); } static void fmt_pptab(bool colon, bool atsign) { object k=colon ? (atsign ? sKsection_relative : sKsection) : (atsign ? sKline_relative : sKline); object f=get(k,sLfixnum,Cnil); fixnum colnum=0, colinc=0,n; fmt_max_param(2); fmt_set_param(0, &n, fmt_int, 0); fmt_set_param(0, &colnum, fmt_int, 1); fmt_set_param(1, &colinc, fmt_int, 1); massert(type_of(f)==t_fixnum); if (colon) ifuncall4(find_symbol(make_simple_string("PPRINT-TAB"),lisp_package),k,make_fixnum(colnum),make_fixnum(colinc),fmt_stream); else { bds_bind(sLAprint_prettyA,Ct); write_codes_pstream(fmt_stream,fix(f),2,colnum,colinc); bds_unwind1; } } static void fmt_tabulate(bool colon, bool atsign) { fixnum colnum=0, colinc=0; fixnum c, i; return fmt_pptab(colon,atsign); 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) { fixnum 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 (!stringp(s)) 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, VLEN(s)); fmt_restore1; /*FIXME restore?*/ } 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, VLEN(s)); 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; fixnum 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 || FMT_PARAM[0].fmt_param_type==fmt_null) { x = fmt_advance(); switch(type_of(x)) { case t_fixnum: n=fix(x);break; case t_bignum: n=MOST_NEGATIVE_FIX;break;/*FIXME*/ default: fmt_error("illegal argument for conditional"); } } 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 object fmt_copy_ctl_string(fixnum i,fixnum j) { object x=alloc_simple_string(j-i); x->sst.sst_self=alloc_relblock(j-i); memcpy(x->sst.sst_self,ctl_string+i,j-i); return x; } static void fmt_function(bool colon, bool atsign) { fixnum i,j,c,n; object x,y,z,s,p=user_package; i=ctl_index; for (;(c=ctl_advance())!='/' && c!=':';); j=ctl_index; if (c==':') { if (ctl_string[ctl_index]==':') ctl_index++; s=fmt_copy_ctl_string(i,j-1); for (i=0;isst.sst_self[i])) s->sst.sst_self[i]=toupper(s->sst.sst_self[i]); p=find_package(s); p=p==Cnil ? user_package : p; i=ctl_index; for (;(c=ctl_advance())!='/';); j=ctl_index; } s=fmt_copy_ctl_string(i,j-1); for (i=0;isst.sst_self[i])) s->sst.sst_self[i]=toupper(s->sst.sst_self[i]); x=find_symbol(s,p); for (y=Cnil,n=fmt_nparam;n;) if (FMT_PARAM[--n].fmt_param_type!=fmt_null) y=MMcons(FMT_PARAM[n].fmt_param_object,y); z=fmt_advance(); VFUN_NARGS=6; apply_format_function(x,fmt_stream,z,colon ? Ct : Cnil,atsign ? Ct : Cnil,y); } static void fmt_proc_iteration(object control,fixnum o,fixnum i,fixnum j) { if (stringp(control)) format(fmt_stream, o + i, j - i); else { object y,*p=ZALLOCA((1+(fmt_end-fmt_index))*sizeof(*p)); *p=fmt_stream; memcpy(p+1,fmt_base+fmt_index,(fmt_end-fmt_index)*sizeof(*p)); y=(fcall.valp=0,funcall_vec(coerce_funcall_object_to_function(control),1+fmt_end-fmt_index,p)); fmt_index=fmt_end-length(y); } } static void fmt_iteration(bool colon, bool atsign) { fixnum i,n=0; VOL int j; int o; bool colon_close = FALSE; object l; VOL object l0,control=fmt_string; 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 (i==j) { switch (type_of(control=fmt_advance())) { case t_string: case t_simple_string: fmt_string=control; i=o=0; j=VLEN(fmt_string); break; case t_symbol: case t_function: i=o=j=0; break; default: fmt_error("control string expected"); } } 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; } fmt_proc_iteration(control,o,i,j); } vs_top = fmt_base; fmt_restore; } else if (colon && !atsign) { l0 = fmt_advance(); fmt_save; fmt_iteration_list=l0; 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; fmt_iteration_list=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; } fmt_proc_iteration(control,o,i,j); 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; } fmt_proc_iteration(control,o,i,j); } fmt_restore1; /*FIXME restore?*/ } else if (colon && atsign) { if (colon_close) goto L4; while (fmt_index < fmt_end) { L4: fmt_iteration_list=fmt_index>=fmt_end-1 ? Cnil : Ct; 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; } fmt_proc_iteration(control,o,i,j); vs_top = fmt_base; fmt_restore; } } } DEFUN("FORMAT-LOGICAL-BLOCK-PREFIX",object,fSformat_logical_block_prefix,SI,2,2,NONE,OO,OO,OO,OO, (object x,object h),"") { if (ifuncall4(sSpprint_quit,x->c.c_cdr,h,fmt_stream,make_fixnum(-1))!=Cnil) RETURN1(Cnil); write_string(x->c.c_car->c.c_car,fmt_stream); RETURN1(Ct); } DEFUN("FORMAT-LOGICAL-BLOCK-BODY",object,fSformat_logical_block_body,SI,2,2,NONE,OO,OO,OO,OO, (object x,object h),"") { jmp_buf fmt_jmp_buf0; int up_colon; fmt_old; vs_mark; fmt_save; fmt_jmp_bufp = &fmt_jmp_buf0; if (!(up_colon = setjmp(*fmt_jmp_bufp))) { fmt_base=vs_top; fmt_index=0; vs_push(x->c.c_cdr); vs_push(h); vs_push(make_fixnum(0)); fmt_end=3; fmt_string=x->c.c_car->c.c_cdr->c.c_car; fmt_advance=fmt_advance_pprint_pop; vs_push(fmt_stream); format(fmt_stream,0,VLEN(fmt_string)); } else if (--up_colon) fmt_error("illegal ~:^"); fmt_restore; vs_reset; RETURN1(Ct); } DEFUN("FORMAT-LOGICAL-BLOCK-SUFFIX",object,fSformat_logical_block_suffix,SI,2,2,NONE,OO,OO,OO,OO, (object x,object h),"") { write_string(x->c.c_car->c.c_cdr->c.c_cdr->c.c_car,fmt_stream); RETURN1(Ct); } static void fmt_logical_block(volatile bool colon, bool atsign) { object per_line_prefix=Cnil,x,prefix,body,suffix; VOL int i,j,j0; int ax=0; VOL int special = 0; bds_ptr old_bds_top=bds_top; if (atsign) { object pp; for (x=pp=OBJNULL;fmt_indexc.c_cdr=p; else x=p; pp=p; } } else x=fmt_advance(); if (atom(x)) { x=list(1,x); ax=1; } i = ctl_index; j0 = j = fmt_skip()-1; while (ctl_string[--j] != '~'); if (ctl_string[j0]==';') { /*prefix*/ int k; for (k=i;k expected"); if (ctl_string[j0-1]=='@') { body=ifuncall1(sSpprint_insert_conditional_newlines,body); j0--; } if (ctl_string[--j0]!=':') fmt_error("Terminating :> expected"); if (ctl_string[--j0]!='~') fmt_error("~ expected"); if (per_line_prefix!=Cnil) bds_bind(sSAprint_line_prefixA,per_line_prefix); fSwrite_int1(MMcons(list(3,prefix,body,suffix),x),fmt_stream,sSformat_logical_block_body, sSformat_logical_block_prefix,sSformat_logical_block_suffix); bds_unwind(old_bds_top); } #define FORMAT_DIRECTIVE_LIMIT 100 static void fmt_justification(volatile bool colon, bool atsign) { fixnum 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); mincol=BOUND_MINCOL(mincol); 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-1] == '@') { j0--; if (ctl_string[j0-1] == ':') j0--; } else if (ctl_string[j0-1] == ':') { j0--; if (ctl_string[j0-1] == '@') j0--; } 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-1] == '@') { j0--; if (ctl_string[j0-1] == ':') j0--; } else if (ctl_string[j0-1] == ':') { j0--; if (ctl_string[j0-1] == '@') j0--; } if (ctl_string[--j0] != '~') fmt_error("~> expected"); break; } else if (ctl_string[j0] != ';') fmt_error("~; expected"); else { if (ctl_string[j0] == '@') --j0; 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] == '@') --j0; 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; l0 = l; l += minpad * m; if (m <= 0 && !colon && !atsign) { m = 0; colon = TRUE; } if (colon) m++; if (atsign) 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 > special || 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) { fixnum j,n; object x[3]; fmt_max_param(3); fmt_not_atsign(atsign); for (n=j=0;j= fmt_end) longjmp(*fmt_jmp_bufp, ++colon); } else { if (fmt_base[0]==Cnil) longjmp(*fmt_jmp_bufp, ++colon); } break; case 1: if (!fix(x[0])) longjmp(*fmt_jmp_bufp, ++colon); break; case 2: if (number_compare(x[0],x[1])==0) longjmp(*fmt_jmp_bufp, ++colon); break; default: if (number_compare(x[0],x[1])<=0 && number_compare(x[1],x[2])<=0) longjmp(*fmt_jmp_bufp, ++colon); break; } } 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); } DEFVAR("*FORMAT-UNUSED-ARGS*",sSAformat_unused_argsA,SI,OBJNULL,""); static object justification_regexp=OBJNULL,logical_block_regexp=OBJNULL; static int fmt_pp_string(object control) { fixnum just,pp; if (justification_regexp==OBJNULL) justification_regexp=fScompile_regexp(make_simple_string("~>")); if (logical_block_regexp==OBJNULL) logical_block_regexp=fScompile_regexp(make_simple_string("~@?:@?>|~[:@]?[:@]?_|~[0-9]*:?[Ii]|~[0-9]+,[0-9]+[:@]?[:@]?[Tt]|~[:@]?[:@]?[Ww]")); VFUN_NARGS=2; just=(fixnum)fSstring_match2(justification_regexp,control); pp=(fixnum)fSstring_match2(logical_block_regexp,control); if (just>=0 && pp>=0) fmt_error("Mixed justification syntax"); return pp>=0; } DEFUN("FORMAT",object,fLformat,LISP,2,F_ARG_LIMIT,NONE,OO,OO,OO,OO,(object strm, object control,...),"") { va_list ap; VOL object x = OBJNULL; jmp_buf fmt_jmp_buf0; bool colon, e; VOL fixnum nargs=INIT_NARGS(2); fmt_old; 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 (stringp(strm)) { 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); */ if (stringp(control)) { fmt_save; va_start(ap,control); frs_push(FRS_PROTECT, Cnil); if (nlj_active) { e = TRUE; goto L; } { object l[MAX_ARGS],ll=Cnil,f=OBJNULL; ufixnum i; for (i=0;(l[i]=NEXT_ARG(nargs,ap,ll,f,OBJNULL))!=OBJNULL;i++); fmt_base = l; fmt_index = 0; fmt_end = i; 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; fmt_lt=fmt_pp_string(control) ? fmt_logical_block : fmt_justification; 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, VLEN(control)); if (sSAformat_unused_argsA->s.s_dbind!=OBJNULL) { int i; for (i=fmt_end-1;i>=fmt_index;i--) sSAformat_unused_argsA->s.s_dbind=MMcons(fmt_base[i],sSAformat_unused_argsA->s.s_dbind); } flush_stream(strm); } e = FALSE; L: va_end(ap); frs_pop(); fmt_restore; if (e) { nlj_active = FALSE; unwind(nlj_fr, nlj_tag); } } else switch (type_of(control)) { /* case t_cfun: */ /* case t_ifun: */ case t_function: case t_symbol: case t_cons: if (nargs >= 64) FEerror("Too many arguments",0); { int i; object Xxvl[MAX_ARGS+1],ll=Cnil,f=OBJNULL; vs_mark; va_start(ap,control); Xxvl[0] = strm; for (i=1;(Xxvl[i]=NEXT_ARG(nargs,ap,ll,f,OBJNULL))!=OBJNULL;i++); va_end(ap); fcall.valp=0,funcall_vec(coerce_funcall_object_to_function(control),i,Xxvl); vs_reset; } break; default: FEwrong_type_argument(sLstring,control); } 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) { fmt_advance=fmt_advance_base;/*FIXME*/ 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; enter_mark_origin(&justification_regexp); enter_mark_origin(&logical_block_regexp); } gcl-2.7.1/o/PaxHeaders/run_process.c0000644000000000000000000000013114755144645014326 xustar0029 mtime=1739901349.94896684 30 atime=1744339827.655492788 30 ctime=1744351535.478909254 gcl-2.7.1/o/run_process.c0000644000175000017500000005215414755144645013734 0ustar00cammcamm/* By Mike Ballantyne */ /* Copyright (C) 1994 W. Schelter Copyright (C) 2024 Camm Maguire 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 #ifndef _WIN32 #include #endif #define IN_RUN_PROCESS #include "include.h" #if defined(__CYGWIN__) #include #include #include #include #endif #ifdef HAVE_SYS_SOCKIO_H #include #endif #include "page.h" #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.tt=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.tt=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 static char *lisp_to_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 res = fcntl(sock,F_SETFL,FASYNC | FNDELAY); #else res = fcntl(sock,F_SETFL,FASYNC); #endif if (res==-1) FEerror("fnctl F_SETFL error",0); 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.tt=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.tt=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.tt=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",VLEN(vs_base[0]),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",VLEN(x->c.c_car),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(); } #define unpack_handle(a_,b_,c_) ({if (!consp(a_))\ TYPE_ERROR(a_,sLcons);\ if (type_of(a_->c.c_car)!=t_fixnum)\ TYPE_ERROR(a_->c.c_car,sLfixnum);\ b_=fix(a_->c.c_car);\ if (type_of(a_->c.c_cdr) != t_fixnum)\ TYPE_ERROR(a_->c.c_cdr,sLfixnum);\ c_=fix(a_->c.c_cdr);}) DEFUN("KILL",object,fSkill,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum err),"") { fixnum k,l; int e,status; unpack_handle(x,k,l); if (l>=0) { ASSERT((e=waitpid(k,&status,WNOHANG))>=0); if (e) { if (!WIFEXITED(status)) { ASSERT(WIFSIGNALED(status)); FEerror("Child %u died with signal %u\n",k,WTERMSIG(status)); } else if ((e=WEXITSTATUS(status))) FEerror("Child %u exited with error status %d\n",k,e); } else { ASSERT(!kill(k,SIGTERM)); ASSERT(waitpid(k,&status,0)==k); if (WIFSIGNALED(status)) { ASSERT(WTERMSIG(status)==SIGTERM); } else { ASSERT(WIFEXITED(status)); if ((e=WEXITSTATUS(status))) FEerror("Child %u exited with error status %d\n",k,e); } } /* ASSERT(!close(l)); */ close(l);/*FIXME*/ x->c.c_cdr=make_fixnum(-1); } return Cnil; } DEFUN("SELECT-READ",object,fSselect_read,SI,2,2,NONE,IO,IO,OO,OO,(object x,fixnum usec),"") { fd_set fds; fixnum max=-1,k,mask,i; object y=x; struct timeval tv={usec/1000000,usec%1000000}; FD_ZERO(&fds); if (x!=Cnil && !consp(x)) TYPE_ERROR(x,sLlist); for (;!endp(x);x=x->c.c_cdr) { unpack_handle(x->c.c_car,i,k); if (k<0) continue;/*closed stream*/ max=maxc.c_cdr,i++) { k=fix(x->c.c_car->c.c_cdr); if (k<0) continue; if (FD_ISSET(k,&fds)) mask|=(1<sm.sm_fp); } return Cnil; } DEFUN("READ-POINTER-OBJECT",object,fSread_pointer_object,SI,1,1,NONE,OO,OO,OO,OO,(object z),"") { object x; fixnum pid,s; unpack_handle(z,pid,s); ASSERT(pid); ASSERT(read(s,&x,sizeof(x))==sizeof(x)); if (x==OBJNULL) { object y; char b[BUFSIZ]; /*FIXME this could be somewhat faster if the malloc induced by fdopen could be avoided.*/ y=make_fd_stream(s,smm_input,"r",b); x=read_object(y); fclose(y->sm.sm_fp); } FFN(fSkill)(z,1); return x; } DEFVAR("*CHILD-STACK-ALLOC*",sSAchild_stack_allocA,SI,make_shortfloat(0.8),""); DEFUN("FORK",object,fSfork,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { int p[2],j=0; pid_t pid; ASSERT(!pipe(p)); ASSERT((pid=fork())>=0); if (!pid) { j=1; close(STDIN_FILENO); close(STDOUT_FILENO); close(STDERR_FILENO); } close(p[1-j]); return MMcons(make_fixnum(pid),make_fixnum(p[j])); } void gcl_init_socket_function() { /* struct sigaction sa; */ /* sa.sa_handler=SIG_IGN; */ /* sa.sa_flags=SA_NOCLDWAIT; */ /* sigemptyset(&sa.sa_mask); */ /* sigaction(SIGCHLD,&sa,NULL); */ 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.7.1/o/PaxHeaders/nsocket.c0000644000000000000000000000013214555557372013436 xustar0030 mtime=1706483450.804392729 30 atime=1744339829.383503585 30 ctime=1744351535.486909183 gcl-2.7.1/o/nsocket.c0000644000175000017500000004004314555557372013035 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ /* the following file compiles under win95 using cygwinb19 */ #include "include.h" #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); 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 = #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) DEFUN("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 = #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("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 = #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("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 (VLEN(bufp) > 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.7.1/o/PaxHeaders/grab_defs.c0000644000000000000000000000013214776006046013674 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.302035078 30 ctime=1744351535.570908429 gcl-2.7.1/o/grab_defs.c0000644000175000017500000000116714776006046013277 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #include #include static char * match(char *c) { char *d; if (!(c=strstr(c,"DEF"))) return NULL; for (d=c;*d && (*d=='_' || (*d>='A'&& *d<='Z'));d++); return *d=='(' ? c : match(d); } int main() { char buf[4096],*c,*d=(void *)-1,*e; for (;fgets(buf,sizeof(buf),stdin);) { if (!strchr(buf,'\n')) { fprintf(stderr,"Line too long, %s\n",buf); return -1; } for (c=buf;(c=!d&&*c!='\n' ? c : match(c));c=e) { d=strstr(c,"\")"); e=d ? d+2 : buf+strlen(buf)-1; printf("%-.*s\n",(int)(e-c),c); } } } gcl-2.7.1/o/PaxHeaders/sequence.d0000644000000000000000000000013214742343573013573 xustar0030 mtime=1737082747.127250665 30 atime=1744340056.108936872 30 ctime=1744351535.578908358 gcl-2.7.1/o/sequence.d0000644000175000017500000002736214742343573013203 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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" #include "page.h" /* I know the following name is not good. */ object alloc_simple_vector(fixnum l) { object x; if (l<0 || l>=ARRAY_DIMENSION_LIMIT) TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil))); x = alloc_object(t_simple_vector); x->sv.sv_hasfillp = FALSE; x->sv.sv_adjustable = FALSE; x->sv.sv_dim = l; x->sv.sv_self = NULL; set_array_elttype(x,aet_object); x->sv.sv_rank = 1; return(x); } object alloc_vector(fixnum l,enum aelttype aet) { object x; if (l<0 || l>=ARRAY_DIMENSION_LIMIT) TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil))); x = alloc_object(t_vector); x->v.v_hasfillp = TRUE; x->v.v_adjustable = TRUE; x->v.v_displaced = Cnil; x->v.v_dim = l; x->v.v_fillp = l; x->v.v_self = NULL; set_array_elttype(x,(short)aet); x->v.v_rank = 1; return(x); } object alloc_simple_bitvector(fixnum l) { object x; if (l<0 || l>=ARRAY_DIMENSION_LIMIT) TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil))); x = alloc_object(t_simple_bitvector); x->sbv.sbv_hasfillp = FALSE; x->sbv.sbv_adjustable = FALSE; x->sbv.sbv_dim = l; x->sbv.sbv_offset = 0; x->sbv.sbv_self = NULL; set_array_elttype(x,aet_bit); x->sbv.sbv_rank = 1; return(x); } object alloc_bitvector(fixnum l) { object x; if (l<0 || l>=ARRAY_DIMENSION_LIMIT) TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil))); x = alloc_object(t_bitvector); x->bv.bv_hasfillp = TRUE; x->bv.bv_adjustable = TRUE; x->bv.bv_displaced = Cnil; x->bv.bv_dim = l; x->bv.bv_fillp = l; x->bv.bv_offset = 0; x->bv.bv_self = NULL; set_array_elttype(x,aet_bit); x->bv.bv_rank = 1; return(x); } @(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 (!consp(sequence)) 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_simple_vector:/*FIXME simple copies to simple*/ case t_vector: if (s > VLEN(sequence)) goto ILLEGAL_START_END; if (e < 0) e = VLEN(sequence); else if (e < s || e > VLEN(sequence)) goto ILLEGAL_START_END; x = sequence->v.v_elttype==aet_object ? alloc_simple_vector(e-s) : alloc_vector(e - s, sequence->v.v_elttype); array_allocself(x, FALSE,OBJNULL); switch (sequence->v.v_elttype) { case aet_object: /*FIXME: memcpy size*/ 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++) ((double *)x->a.a_self)[j] = ((double *)sequence->a.a_self)[i]; break; case aet_sf: for (i = s, j = 0; i < e; i++, j++) ((float *)x->a.a_self)[j] = ((float *)sequence->a.a_self)[i]; break; case aet_nnfix: case aet_fix: for (i = s, j = 0; i < e; i++, j++) ((fixnum *)x->a.a_self)[j] = ((fixnum *)sequence->a.a_self)[i]; break; case aet_int: case aet_nnint: case aet_uint: for (i = s, j = 0; i < e; i++, j++) UINT_GCL(x, j) = UINT_GCL(sequence, i); break; case aet_short: case aet_nnshort: 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_nnchar: 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_simple_string: case t_string: if (s > VLEN(sequence)) goto ILLEGAL_START_END; if (e < 0) e = VLEN(sequence); else if (e < s || e > VLEN(sequence)) 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_simple_bitvector: case t_bitvector: if (s > VLEN(sequence)) goto ILLEGAL_START_END; if (e < 0) e = VLEN(sequence); else if (e < s || e > VLEN(sequence)) goto ILLEGAL_START_END; {BEGIN_NO_INTERRUPT; x = alloc_simple_bitvector(e - s); x->bv.bv_self = alloc_relblock(ceil((e-s),BV_ALLOC)*sizeof(*x->bv.bv_self)); s += sequence->bv.bv_offset; e += sequence->bv.bv_offset; for (i = s, j = 0; i < e; i++, j++) if (BITREF(sequence,i)) SET_BITREF(x,j); else CLEAR_BITREF(x,j); 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) ((!consp(obj))) 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_simple_vector: case t_simple_string: case t_simple_bitvector: case t_vector: case t_string: case t_bitvector: return(VLEN(x)); 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_simple_vector: case t_vector: x = seq; k = VLEN(x); y = x->v.v_elttype==aet_object ? alloc_simple_vector(k) : alloc_vector(k, x->v.v_elttype); vs_push(y); array_allocself(y, FALSE,OBJNULL); switch (x->v.v_elttype) { case aet_object: 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++) ((double *)y->a.a_self)[j] = ((double *)x->a.a_self)[i]; break; case aet_sf: for (j = k - 1, i = 0; j >=0; --j, i++) ((float *)y->a.a_self)[j] = ((float *)x->a.a_self)[i]; break; case aet_fix: case aet_nnfix: for (j = k - 1, i = 0; j >=0; --j, i++) ((fixnum *)y->a.a_self)[j] = ((fixnum *)x->a.a_self)[i]; break; case aet_int: case aet_nnint: case aet_uint: for (j = k - 1, i = 0; j >=0; --j, i++) UINT_GCL(y, j) = UINT_GCL(x, i); break; case aet_short: case aet_nnshort: 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_nnchar: case aet_uchar: goto TYPE_STRING; } return(vs_pop); case t_simple_string: case t_string: x = seq; y = alloc_simple_string(VLEN(x)); TYPE_STRING: {BEGIN_NO_INTERRUPT; vs_push(y); y->st.st_self = alloc_relblock(VLEN(x)); for (j = VLEN(x) - 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_simple_bitvector: case t_bitvector: x = seq; {BEGIN_NO_INTERRUPT; y = alloc_simple_bitvector(VLEN(x)); vs_push(y); y->bv.bv_self=alloc_relblock(ceil(VLEN(x),BV_ALLOC)*sizeof(*y->bv.bv_self)); for (j = VLEN(x) - 1, i = x->bv.bv_offset; j >=0; --j, i++) if (BITREF(x,i)) SET_BITREF(y,j); else CLEAR_BITREF(y,j); 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 /*FIXME boot*/ 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_simple_vector: case t_vector: x = seq; k = VLEN(x); switch (x->v.v_elttype) { case aet_object: 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 = ((double *)x->a.a_self)[i]; ((double *)x->a.a_self)[i] = ((double *)x->a.a_self)[j]; ((double *)x->a.a_self)[j] = y; } return(seq); case aet_sf: for (i = 0, j = k - 1; i < j; i++, --j) { shortfloat y; y = ((float *)x->a.a_self)[i]; ((float *)x->a.a_self)[i] = ((float *)x->a.a_self)[j]; ((float *)x->a.a_self)[j] = y; } return(seq); case aet_fix: case aet_nnfix: for (i = 0, j = k - 1; i < j; i++, --j) { fixnum y; y = ((fixnum *)x->a.a_self)[i]; ((fixnum *)x->a.a_self)[i] = ((fixnum *)x->a.a_self)[j]; ((fixnum *)x->a.a_self)[j] = y; } return(seq); case aet_int: case aet_nnint: case aet_uint: for (i = 0, j = k - 1; i < j; i++, --j) { unsigned int y; y = UINT_GCL(x, i); UINT_GCL(x, i) = UINT_GCL(x, j); UINT_GCL(x, j) = y; } return(seq); case aet_short: case aet_nnshort: 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, j) = y; } return(seq); case aet_char: case aet_nnchar: case aet_uchar: goto TYPE_STRING; } case t_simple_string: case t_string: x = seq; TYPE_STRING: for (i = 0, j = VLEN(x) - 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_simple_bitvector: case t_bitvector: x = seq; for (i = x->bv.bv_offset, j = VLEN(x) + x->bv.bv_offset - 1; i < j; i++, --j) { k = BITREF(x,i); if (BITREF(x,j)) SET_BITREF(x,i); else CLEAR_BITREF(x,i); if (k) SET_BITREF(x,j); else CLEAR_BITREF(x,j); } return(seq); default: FEwrong_type_argument(sLsequence, seq); return(Cnil); } } void gcl_init_sequence_function() { make_function("SUBSEQ", Lsubseq); make_function("COPY-SEQ", Lcopy_seq); make_function("LENGTH", Llength); make_function("REVERSE", Lreverse); make_function("NREVERSE", Lnreverse); } gcl-2.7.1/o/PaxHeaders/structure.c0000644000000000000000000000013214555557372014030 xustar0030 mtime=1706483450.808392729 30 atime=1744339823.259465333 30 ctime=1744351535.470909326 gcl-2.7.1/o/structure.c0000644000175000017500000003070114555557372013427 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.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("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("STRUCTURE-REF",object,structure_ref,SI,3,3,NONE,OO,OI,OO,OO,(object x,object name,fixnum 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_nnfix: 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_nnchar: 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_nnshort: case aet_short: return(make_fixnum(STREF(short,x,s_pos[i]))); case aet_uint: return(make_fixnum(STREF(unsigned int,x,s_pos[i]))); case aet_nnint: case aet_int: return(make_fixnum(STREF(int,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("STRUCTURE-SET",object,structure_set,SI,4,4,NONE,OO,OI,OO,OO,(object x,object name,fixnum 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_nnfix: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_nnchar: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_nnshort:case aet_short: STREF(short,x,s_pos[i])=fix(v); break; case aet_uint: STREF(unsigned int,x,s_pos[i])=fix(v); break; case aet_nnint:case aet_int: STREF(int,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 DEFUN("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("STRUCTURE-SUBTYPE-P",object,fSstructure_subtype_p,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { /* 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) RETURN1(Cnil); x=x->str.str_def; COERCE_DEF(y); RETURN1(structure_subtypep(x,y) ? Ct : Cnil); } 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(intern(car(s->c.c_car),keyword_package),Cnil)); collect(p,make_cons(structure_ref(x,x->str.str_def,i),Cnil)); } *p=Cnil; return make_cons(def->name,v); } DEFUN("MAKE-DUMMY-STRUCTURE",object,fSmake_dummy_structure,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { object x; BEGIN_NO_INTERRUPT; x = alloc_object(t_structure); x->str.str_def=NULL; x->str.str_self=NULL; END_NO_INTERRUPT; return x; } DEFUN("MAKE-STRUCTURE",object,fSmake_structure,SI,1,63,NONE,OO,OO,OO,OO,(object name,...),"") {/*FIXME*/ fixnum narg=INIT_NARGS(1),i,size; object l=Cnil,f=OBJNULL,v,x; struct s_data *def=NULL; va_list ap; unsigned char *s_type; unsigned short *s_pos; { BEGIN_NO_INTERRUPT; x = alloc_object(t_structure); COERCE_DEF(name); if (type_of(name)!=t_structure || (def=S_DATA(name))->length != narg) FEerror("Bad make_structure args for type ~a",1,name); x->str.str_def = name; x->str.str_self = NULL; size=S_DATA(name)->size; 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); s_pos= (&SLOT_POS(x->str.str_def,0)); s_type = (&(SLOT_TYPE(x->str.str_def,0))); va_start(ap,name); for (i=0;(v=NEXT_ARG(narg,ap,l,f,OBJNULL))!=OBJNULL;i++) { switch(s_type[i]) { case aet_object: STREF(object,x,s_pos[i])=v; break; case aet_nnfix: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_nnchar: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_nnshort:case aet_short: STREF(short,x,s_pos[i])=fix(v); break; /*FIXME uint on 32bit really should not be here*/ case aet_uint: STREF(unsigned int,x,s_pos[i])=fix(v); break; case aet_nnint:case aet_int: STREF(int,x,s_pos[i])=fix(v); break; default: bad_raw_type(); } } va_end(ap); END_NO_INTERRUPT; } RETURN1(x); } DEFUN("COPY-STRUCTURE",object,fLcopy_structure,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { object y; struct s_data *def; check_type_structure(x); { BEGIN_NO_INTERRUPT; 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); memcpy(y->str.str_self,x->str.str_self,def->size); END_NO_INTERRUPT; } return y; } 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]->d.tt) 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 (!consp(vs_base[0])) */ /* 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 (!consp(vs_base[1])) */ /* 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; } extern aet_type_struct aet_types[]; static void FFN(siLsize_of)(void) { object x= vs_base[0]; int i; i= aet_types[fix(fSget_aelttype(x))].size; 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_si_function("COPY-STRUCTURE", siLcopy_structure); */ make_si_function("STRUCTURE-NAME", siLstructure_name); make_si_function("STRUCTURE-REF1", siLstructure_ref1); 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.7.1/o/PaxHeaders/num_sfun.c0000644000000000000000000000013214722425025013603 xustar0030 mtime=1732913685.426115449 30 atime=1744339819.927444533 30 ctime=1744351535.466909362 gcl-2.7.1/o/num_sfun.c0000644000175000017500000003731714722425025013214 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 #define NEED_ISFINITE #include "include.h" #include "num_include.h" object imag_unit, minus_imag_unit, imag_two; fixnum fixnum_expt(fixnum x, fixnum y) { fixnum 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 double pexp(double y,object z,int s) { double x=exp(y); if (s) x=(float)x; /* if (!x) */ /* FLOATING_POINT_UNDERFLOW(sLexp,z); */ /* if (!ISFINITE(x) && ISFINITE(y)) */ /* FLOATING_POINT_OVERFLOW(sLexp,z); */ return x; } 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)pexp(number_to_double(x),x,0))); case t_shortfloat: return(make_shortfloat((shortfloat)pexp((double)sf(x),x,1))); case t_longfloat: return(make_longfloat(pexp(lf(x),x,0))); 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 fixnum number_contagion_index(object x) { switch(type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return 0; case t_shortfloat: return 1; case t_longfloat: return 2; case t_complex: return 3+number_contagion_index(x->cmp.cmp_real); } return 0; } static inline object number_zero_expt(object x,fixnum cy) { enum type cx=number_contagion_index(x); if (gcl_is_not_finite(x))/*FIXME, better place?*/ return number_exp(number_times(number_nlog(x),small_fixnum(0))); switch (cxrat.rat_num,fy),number_ui_expt(x->rat.rat_den,fy),1); 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,number_contagion_index(y)) : 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; 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)sqrtf((double)(sf(x))))); case t_longfloat: return(make_longfloat(sqrt(lf(x)))); default: FEwrong_type_argument(sLnumber, x); } COMPLEX: {extern object plus_half; z = number_expt(x, plus_half);} 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,1);} 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]); } DEFUN("EXPT",object,fLexpt,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type_number(&vs_base[0]); check_type_number(&vs_base[1]); RETURN1(number_expt(x,y)); } 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)); } DEFUN("ISNAN",object,fSisnan,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { switch (type_of(x)) { case t_longfloat: return isnan(lf(x)) ? Ct : Cnil; break; case t_shortfloat: return isnan(sf(x)) ? Ct : Cnil; break; default: return Cnil; break; } return Cnil; } DEFUN("ISINF",object,fSisinf,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { switch (type_of(x)) { case t_longfloat: return isinf(lf(x)) ? Ct : Cnil; break; case t_shortfloat: return isinf(sf(x)) ? Ct : Cnil; break; default: return Cnil; break; } return Cnil; } 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("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.7.1/o/PaxHeaders/sfasli.c0000644000000000000000000000013214761577223013245 xustar0030 mtime=1741094547.626220543 30 atime=1744339829.859506559 30 ctime=1744351535.594908214 gcl-2.7.1/o/sfasli.c0000644000175000017500000000700414761577223012644 0ustar00cammcamm/* Copyright William Schelter. All rights reserved. Copyright 2024 Camm Maguire */ #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 */ void *min_text; extern void *data_start; int is_text_addr(void *p) { extern int initializing_boot; if (initializing_boot) return 1;/*FIXME*/ return p>=min_text && p new_bds_top; bds_top--) (bds_top->bds_sym)->s.s_dbind = bds_top->bds_val; } gcl-2.7.1/o/PaxHeaders/unexmacosx.c0000644000000000000000000000013214555557372014162 xustar0030 mtime=1706483450.808392729 30 atime=1744295002.597973722 30 ctime=1744351535.586908286 gcl-2.7.1/o/unexmacosx.c0000644000175000017500000010613414555557372013565 0ustar00cammcamm/* Dump Gcl in Mach-O format for use on Mac OS X. Copyright (C) 2001, 2002, 2003, 2004, 2005, Copyright (C) 2024 Camm Maguire 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 #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 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.7.1/o/PaxHeaders/nfunlink.c0000644000000000000000000000013214542551763013606 xustar0030 mtime=1703597043.320022928 30 atime=1744339827.943494588 30 ctime=1744351535.478909254 gcl-2.7.1/o/nfunlink.c0000644000175000017500000000116214542551763013204 0ustar00cammcamm/* 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; gcl-2.7.1/o/PaxHeaders/clxsocket.c0000644000000000000000000000013214542551763013761 xustar0030 mtime=1703597043.284022871 30 atime=1744339829.239502685 30 ctime=1744351535.486909183 gcl-2.7.1/o/clxsocket.c0000644000175000017500000001060014542551763013354 0ustar00cammcamm/* 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.7.1/o/PaxHeaders/xdrfuns.c0000644000000000000000000000013114555557372013460 xustar0030 mtime=1706483450.808392729 30 atime=1744339826.727486991 29 ctime=1744351535.59090825 gcl-2.7.1/o/xdrfuns.c0000644000175000017500000001031214555557372013054 0ustar00cammcamm/* Copyright (C) 1994 W. Schelter Copyright (C) 2024 Camm Maguire 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 aet_type_struct aet_types[]; DEFUN("XDR-OPEN",object,fSxdr_open,SI,1,1,NONE,OO,OO,OO,OO,(object f),"") { XDR *xdrs; object ar= alloc_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; } DEFUN("XDR-WRITE",object,fSxdr_write,SI,2,2,NONE,OO,OO,OO,OO,(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_simple_vector: 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=VLEN(elt); if (tmp!=VLEN(elt)) goto error; if(xdr_array(xdrp,(void *)&elt->v.v_self, &tmp, elt->v.v_dim, aet_types[elt->v.v_elttype].size, e)) goto error; } break; default: FEerror("unsupported xdr ~a",1,elt); break; } return elt; error: FEerror("bad xdr write",0); return elt; } DEFUN("XDR-READ",object,fSxdr_read,SI,2,2,NONE,OO,OO,OO,OO,(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_simple_vector: 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=VLEN(elt); if (tmp!=VLEN(elt)) goto error; if(xdr_array(xdrp,(void *)&elt->v.v_self, &tmp, elt->v.v_dim, aet_types[elt->v.v_elttype].size, 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.7.1/o/PaxHeaders/file.d0000644000000000000000000000013214776006046012700 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.302035078 30 ctime=1744351535.574908393 gcl-2.7.1/o/file.d0000644000175000017500000020005714776006046012302 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 #define IN_FILE #include "include.h" #ifdef USE_READLINE #include #define kclgetc(FP) rl_getc_em(FP) #define kclungetc(C, FP) rl_ungetc_em(C, FP) #define kclputc(C, FP) rl_putc_em(C, FP) #else #define kclgetc(FP) getc(FP) #define kclungetc(C, FP) ungetc(C, FP) #define kclputc(C, FP) putc(C, 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 (readline_on && fp==rl_instream && rl_line_buffer && *rl_line_buffer==EOF) 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); fp = freopen("/dev/tty", "r", fp); if (fp == NULL) error("can't reopen the console"); return(FALSE); } return(TRUE); } #undef feof #define feof feof1 void end_of_stream(object strm) { END_OF_FILE(strm); } DEFUN("TEMP-STREAM",object,fStemp_stream,SI,2,2,NONE,OO,OO,OO,OO,(object x,object ext),"") { object st; #ifdef _WIN32 DWORD dwRetVal; char lpPathBuffer[MAX_PATH]; check_type_string ( &x ); check_type_string ( &ext ); dwRetVal = GetTempPath ( MAX_PATH, lpPathBuffer ); if ( dwRetVal + VLEN(ext) + VLEN(x) + 2 > MAX_PATH ) { FEerror ( "Length of temporary file path combined with file name is too large.", 0 ); } strcat ( lpPathBuffer, x->st.st_self ); strcat ( lpPathBuffer, "." ); strcat ( lpPathBuffer, ext->st.st_self ); st = make_simple_string ( lpPathBuffer ); x = open_stream ( st, smm_io, sKsupersede, Cnil ); #else char *c, *d; int l; check_type_string(&x); check_type_string(&ext); if (!(c=alloca(VLEN(x)+VLEN(ext)+8))) FEerror("Cannot allocate temp name space",0); if (!(d=alloca(VLEN(x)+VLEN(ext)+8))) FEerror("Cannot allocate temp name space",0); memcpy(c,x->st.st_self,VLEN(x)); memcpy(c+VLEN(x),"XXXXXX",6); c[VLEN(x)+6]=0; l=mkstemp(c); memcpy(d,c,VLEN(x)+6); memcpy(d+VLEN(x)+6,".",1); memcpy(d+VLEN(x)+7,ext->st.st_self,VLEN(ext)); d[VLEN(x)+VLEN(ext)+7]=0; if (rename(c,d)) FEerror("Cannot rename ~s to ~s",2,make_simple_string(c),make_simple_string(d)); st=make_simple_string(d); x=open_stream(st,smm_output,sKsupersede,Cnil); close(l); #endif RETURN1(x); } DEFUN("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(x->sm.sm_fp)) ? Ct : Cnil); } /* 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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); 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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); 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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); 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 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); 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.tt=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("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: if (strm->sm.sm_fp == NULL) break; /*FIXME: review this*/ 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_file_synonym: case smm_synonym: case smm_broadcast: case smm_concatenated: strm->sm.sm_object0=OBJNULL; break; case smm_two_way: case smm_echo: STREAM_INPUT_STREAM(strm)=OBJNULL; STREAM_OUTPUT_STREAM(strm)=OBJNULL; /* close_stream(STREAM_INPUT_STREAM(strm)); */ /* close_stream(STREAM_OUTPUT_STREAM(strm)); */ break; case smm_string_input: case smm_string_output: STRING_STREAM_STRING(strm)=OBJNULL; break; default: error("Illegal stream mode"); } SET_STREAM_FLAG(strm,gcl_sm_closed,1); } DEFUN("INTERACTIVE-STREAM-P",object,fLinteractive_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(object strm),"") { check_type_stream(&strm); while(type_of(strm)==t_stream) 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_file_synonym: 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; } #ifdef STATIC_FUNCTION_POINTERS object fLinteractive_stream_p(object x) { return FFN(fLinteractive_stream_p)(x); } #endif object make_two_way_stream(istrm, ostrm) object istrm, ostrm; { object strm; strm = alloc_object(t_stream); strm->sm.tt=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->d.tt=strm->sm.sm_mode = (short)smm_echo; return(strm); } DEFUN("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; massert(type_of(strng)==t_string); strm = alloc_object(t_stream); strm->sm.tt=strm->sm.sm_mode = (short)smm_string_input; strm->sm.sm_fp = NULL; strm->sm.sm_buffer = 0; strm->sm.sm_flags=0; STRING_STREAM_STRING(strm) = strng; strm->sm.sm_object1 = OBJNULL; STRING_INPUT_STREAM_NEXT(strm)= istart; STRING_INPUT_STREAM_END(strm)= iend; 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 static bool tty_stream_p(object strm) { if (type_of(strm)!=t_stream) return(FALSE); switch (strm->sm.sm_mode) { case smm_input: case smm_output: case smm_io: return(strm->sm.sm_fp && isatty(fileno(strm->sm.sm_fp)) ? TRUE : FALSE); case smm_socket: case smm_probe: case smm_string_input: case smm_string_output: return(FALSE); case smm_broadcast: case smm_concatenated: { object x; for (x=strm->sm.sm_object0;!endp(x);x=x->c.c_cdr) if (!tty_stream_p(x->c.c_car)) return(FALSE); return(TRUE); } case smm_file_synonym: case smm_synonym: return(tty_stream_p(symbol_value(strm->sm.sm_object0))); case smm_two_way: case smm_echo: return(tty_stream_p(STREAM_INPUT_STREAM(strm)) && tty_stream_p(STREAM_OUTPUT_STREAM(strm))); default: FEerror("Illegal stream mode for ~S.",1,strm); return(FALSE); } } DEFUN("TTY-STREAM-P",object,fStty_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { return tty_stream_p(x) ? Ct : Cnil; } DEFUN("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("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_string(line_length); strng->st.st_fillp = 0; strng->st.st_self = alloc_relblock(line_length); strm = alloc_object(t_stream); strm->sm.tt=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)); STREAM_FILE_COLUMN(strm) = 0; 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); c = kclgetc(strm->sm.sm_fp); /* if (c == EOF) { */ /* if (xkclfeof(c,strm->sm.sm_fp)) */ /* end_of_stream(strm); */ /* else c = kclgetc(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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); 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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); } 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); object output_stream(object strm) { switch (strm->sm.sm_mode) { case smm_output: case smm_io: case smm_socket: case smm_string_output: case smm_broadcast: #ifdef USER_DEFINED_STREAMS case smm_user_defined: #endif return strm; case smm_file_synonym: case smm_synonym: return output_stream(symbol_value(strm->sm.sm_object0)); case smm_two_way: case smm_echo: return output_stream(STREAM_OUTPUT_STREAM(strm)); default: cannot_write(strm); return Cnil; } } static void adjust_stream_column(int c,object strm) { 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)++; } static int writec_socket_stream(int c,object strm) { adjust_stream_column(c,strm); if (strm->sm.sm_fd>=0) putCharGclSocket(strm,c); else if (!GET_STREAM_FLAG(strm,gcl_sm_had_error)) closed_stream(strm); return c; } static int writec_output_stream(int c,object strm) { adjust_stream_column(c,strm); if (strm->sm.sm_fp!=NULL) kclputc(c, strm->sm.sm_fp); else if (!GET_STREAM_FLAG(strm,gcl_sm_had_error)) closed_stream(strm); return c; } static int writec_string_output_stream(int c,object strm) { object x=STRING_STREAM_STRING(strm); adjust_stream_column(c,strm); if (x->st.st_fillp >= x->st.st_dim) { ufixnum j=x->st.st_dim * 2 + 16; char *p; 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)(j); memcpy(p,x->st.st_self,x->st.st_dim); x->st.st_dim=j; x->st.st_self=p; adjust_displaced(x); } x->st.st_self[x->st.st_fillp++] = c; return c; } static int writec_broadcast_stream(int c,object strm) { object x; for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) writec_stream(c, x->c.c_car); return c; } void * writec_stream_fun(object strm) { switch (strm->sm.sm_mode) { case smm_output: case smm_io: return writec_output_stream; case smm_socket: return writec_socket_stream; case smm_broadcast: return writec_broadcast_stream; case smm_string_output: return writec_string_output_stream; default: return NULL; } } int writec_stream(int c, object strm) { object x; char *p; 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_file_synonym: 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) { ufixnum j=x->st.st_dim * 2 + 16; 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)(j); memcpy(p,x->st.st_self,x->st.st_dim); x->st.st_dim=j; x->st.st_self=p; adjust_displaced(x); } 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: FEerror("Illegal stream mode for ~S.",1,strm); } return(c); } 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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); } } 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 == 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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); 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 (readline_on && strm->sm.sm_fp==rl_instream) if (rl_line_buffer) return *rl_line_buffer ? TRUE : FALSE; #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_file_synonym: 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: { object x; for (x=strm->sm.sm_object0;!endp(x);x=x->c.c_cdr) if (listen_stream(x->c.c_car)) return TRUE; return FALSE; } break; 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: FEerror("Illegal stream mode for ~S.",1,strm); return(FALSE); } } int file_position(strm) object strm; { BEGIN: switch (strm->sm.sm_mode) { case smm_input: case smm_output: case smm_io: /* return(strm->sm.sm_int0); */ if (strm->sm.sm_fp == NULL) closed_stream(strm); return(ftell(strm->sm.sm_fp)); case smm_broadcast: for (strm=strm->sm.sm_object0;!endp(strm->c.c_cdr);strm=strm->c.c_cdr); if (strm==Cnil) return 0; else { strm=strm->c.c_car; goto BEGIN; } case smm_socket: return -1; case smm_string_output: return(STRING_STREAM_STRING(strm)->st.st_fillp); case smm_file_synonym: 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_probe: case smm_concatenated: case smm_two_way: case smm_echo: case smm_string_input: return(-1); default: FEerror("Illegal stream mode for ~S.",1,strm); return(-1); } } int file_position_set(strm, disp) object strm; int disp; { BEGIN: switch (strm->sm.sm_mode) { case smm_socket: return -1; case smm_input: case smm_output: case smm_io: if (fseek(strm->sm.sm_fp, disp, 0) < 0) return(-1); /* strm->sm.sm_int0 = disp; */ return(0); case smm_string_output: if (disp < STRING_STREAM_STRING(strm)->st.st_dim) { STRING_STREAM_STRING(strm)->st.st_fillp = disp; /* strm->sm.sm_int0 = disp; */ } else { disp -= (STRING_STREAM_STRING(strm)->st.st_fillp= STRING_STREAM_STRING(strm)->st.st_dim); while (disp-- > 0) writec_stream(' ', strm); } return(0); case smm_file_synonym: 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_probe: case smm_broadcast: case smm_concatenated: case smm_two_way: case smm_echo: case smm_string_input: return(-1); default: FEerror("Illegal stream mode for ~S.",1,strm); return(-1); } } static int file_length(strm) object strm; { BEGIN: switch (strm->sm.sm_mode) { case smm_input: case smm_output: case smm_io: case smm_probe: if (strm->sm.sm_fp == NULL) closed_stream(strm); return(file_len(strm->sm.sm_fp)); case smm_broadcast: for (strm=strm->sm.sm_object0;!endp(strm->c.c_cdr);strm=strm->c.c_cdr); if (strm==Cnil) return 0; else { strm=strm->c.c_car; goto BEGIN; } case smm_file_synonym: 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_string_input: case smm_string_output: case smm_concatenated: case smm_two_way: case smm_echo: case smm_socket: return(-1); default: FEerror("Illegal stream mode for ~S.",1,strm); return(-1); } return(-1); } 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_file_synonym: 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: FEerror("Illegal stream mode for ~S.",1,strm); return(-1); } } void load(const char *s) { object filename, tfn, strm, x; vs_mark; if (user_match(s,strlen(s))) return; filename = make_simple_string(s); vs_push(filename); massert(realpath(s,FN2)); tfn = make_simple_string(FN2); bds_bind(sLAload_pathnameA,filename); bds_bind(sLAload_truenameA,tfn); 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); bds_unwind1; bds_unwind1; vs_reset; } static int file_synonym_stream_p(object x) { switch(type_of(x)) { case t_stream: switch(x->sm.sm_mode) { case smm_input: case smm_output: case smm_io: case smm_probe: case smm_file_synonym: return 1; case smm_synonym: return file_synonym_stream_p(x->sm.sm_object0->s.s_dbind); default: return 0; } default: return 0; } } LFD(Lmake_synonym_stream)() { object x; check_arg(1); check_type_sym(&vs_base[0]); x = alloc_object(t_stream); x->sm.tt=x->sm.sm_mode = file_synonym_stream_p(vs_base[0]->s.s_dbind) ? (short)smm_file_synonym : (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])) TYPE_ERROR(vs_base[i], MMcons(sLand,MMcons(sLstream, MMcons(MMcons(sLsatisfies,MMcons(sLoutput_stream_p,Cnil)),Cnil)))); /* cannot_write(vs_base[i]); */ stack_list(); x = alloc_object(t_stream); x->sm.tt=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]); stack_list(); x = alloc_object(t_stream); x->sm.tt=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; } DEFUN("MAKE-TWO-WAY-STREAM", object, fLmake_two_way_stream,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { if (type_of(x) != t_stream || !input_stream_p(x)) TYPE_ERROR(x,sLinput_stream); if (type_of(y) != t_stream || !output_stream_p(y)) TYPE_ERROR(y,sLoutput_stream); RETURN1(make_two_way_stream(x,y)); } LFD(Lmake_echo_stream)() { check_arg(2); if (type_of(vs_base[0]) != t_stream || !input_stream_p(vs_base[0])) TYPE_ERROR(vs_base[0],sLinput_stream); if (type_of(vs_base[1]) != t_stream || !output_stream_p(vs_base[1])) TYPE_ERROR(vs_base[1],sLoutput_stream); vs_base[0] = make_echo_stream(vs_base[0], vs_base[1]); vs_popp; } DEFUN("MAKE-STRING-OUTPUT-STREAM-INT",object,fLmake_string_output_stream_int,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { RETURN1(make_string_output_stream(64)); } DEFUN("GET-OUTPUT-STREAM-STRING",object,fLget_output_stream_string,LISP, 1,1,NONE,OO,OO,OO,OO,(object stream),"") { if (type_of(stream) != t_stream || (enum smmode)stream->sm.sm_mode != smm_string_output) FEerror("~S is not a string-output stream.", 1, stream); stream = get_output_stream_string(stream); RETURN1(stream); } /* 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_file_synonym: return file_stream(x->sm.sm_object0->s.s_dbind); default: break; } return Cnil; } DEFUN("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("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("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("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("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("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) @) DEFUN("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); } static fixnum /*FIXME, this duplicates code in gcl_iolib.lsp somwhat */ chars_per_write(object s) {/*s already a file-stream*/ fixnum i; s=s->sm.sm_object0; if (consp(s)) { s=s->c.c_cdr->c.c_car; i=fix(s); return ((i/CHAR_SIZE) + (i%CHAR_SIZE ? 1 : 0)); } else return 1; } @(defun file_position (file_stream &o position) fixnum i=0; @ check_type_stream(&file_stream); if (position == Cnil) { i = file_position(file_stream); if (i < 0) @(return Cnil) i/=chars_per_write(file_stream); @(return `make_fixnum(i)`) } else { if (position == sKstart) i = 0; else if (position == sKend) i = file_length(file_stream); else if (type_of(position) != t_fixnum || (i = fix((position))) < 0) FEerror("~S is an illegal file position~%\ for the file-stream ~S.", 2, position, file_stream); if (file_position_set(file_stream, i) < 0) @(return Cnil) @(return Ct) } @) LFD(Lfile_length)() { int i; check_arg(1); check_type_stream(&vs_base[0]); i = file_length(vs_base[0]); if (i < 0) FEwrong_type_argument(sLfile_stream,vs_base[0]); else { i/=chars_per_write(vs_base[0]); vs_base[0] = make_fixnum(i); } } LFD(siLfile_column)() { int i; check_arg(1); check_type_stream(&vs_base[0]); i = file_column(vs_base[0]); if (i < 0) FEwrong_type_argument(sLfile_stream,vs_base[0]); else vs_base[0] = make_fixnum(i); } DEFVAR("*COLLECT-BINARY-MODULES*",sSAcollect_binary_modulesA,SI,sLnil,""); DEFVAR("*BINARY-MODULES*",sSAbinary_modulesA,SI,Cnil,""); DEFVAR("*DISABLE-RECOMPILE*",sSAdisable_recompile,SI,Ct,""); DEFUN("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) { princ(x,symbol_value(sLAstandard_outputA)); princ(make_simple_string("\n"),symbol_value(sLAstandard_outputA)); } } RETURN1(Ct); } #ifdef STATIC_FUNCTION_POINTERS object fSload_stream(object strm,object print) { return FFN(fSload_stream)(strm,print); } #endif DEFUN("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) { object strm=symbol_value(sLAstandard_outputA); if (file_column(strm)!=0) princ(make_simple_string("\n"),strm); princ(make_simple_string(";; Fasload successfully ended.\n"),strm); } RETURN1(make_fixnum(i)); } static void FFN(siLget_string_input_stream_index)() { check_arg(1); check_type_stream(&vs_base[0]); if ((enum smmode)vs_base[0]->sm.sm_mode != smm_string_input) FEerror("~S is not a string-input stream.", 1, vs_base[0]); vs_base[0] = make_fixnum(STRING_INPUT_STREAM_NEXT(vs_base[0])); } LFD(siLmake_string_output_stream_from_string)() { object strng, strm; check_arg(1); strng = vs_base[0]; if (!stringp(strng) || !strng->st.st_hasfillp) FEerror("~S is not a string with a fill-pointer.", 1, strng); strm = alloc_object(t_stream); strm->sm.tt=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;/*FIXME*/ 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 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_file_synonym: 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_string_output: if (!out) cannot_read(strm); return (strm); break; case smm_input: if (out) cannot_write(strm); break; case smm_string_input: if (out) cannot_write(strm); return (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); } DEFUN("FWRITE",object,fSfwrite,SI,4,4,NONE,OO,OO,OO,OO, (object vector,object start,object count,object stream),"") { unsigned char *p; int n,beg; stream=coerce_stream(stream,1); if (stream==Cnil) RETURN1(Cnil); p = vector->ust.ust_self; beg = ((type_of(start)==t_fixnum) ? fix(start) : 0); n = ((type_of(count)==t_fixnum) ? fix(count) : (VLEN(vector) - beg)); if (fwrite(p+beg,1,n,stream->sm.sm_fp)) RETURN1(Ct); RETURN1(Cnil); } DEFUN("FREAD",object,fSfread,SI,4,4,NONE,OO,OO,OO,OO, (object vector,object start,object count,object stream),"") { char *p; int n,beg; stream=coerce_stream(stream,0); if (stream==Cnil) RETURN1(Cnil); p = vector->st.st_self; beg = ((type_of(start)==t_fixnum) ? fix(start) : 0); n = ((type_of(count)==t_fixnum) ? fix(count) : (VLEN(vector) - beg)); if ((n=SAFE_FREAD(p+beg,1,n,stream->sm.sm_fp))) RETURN1(make_fixnum(n)); RETURN1(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.tt=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_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; struct sockaddr_in addr; unsigned n=sizeof(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); memset(&addr,0,sizeof(addr)); 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) || defined(FREE_BSD) #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 (stringp(host)) { 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: 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 fresh_synonym_stream_to_terminal_io(void) { object x = alloc_object(t_stream); x->sm.tt=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; return x; } /* object standard_io; */ object standard_error; DEFVAR("*TERMINAL-IO*",sLAterminal_ioA,LISP,(gcl_init_file(),terminal_io),""); DEFVAR("*STANDARD-INPUT*",sLAstandard_inputA,LISP,fresh_synonym_stream_to_terminal_io(),""); DEFVAR("*STANDARD-OUTPUT*",sLAstandard_outputA,LISP,fresh_synonym_stream_to_terminal_io(),""); DEFVAR("*ERROR-OUTPUT*",sLAerror_outputA,LISP,standard_error,""); DEFVAR("*QUERY-IO*",sLAquery_ioA,LISP,fresh_synonym_stream_to_terminal_io(),""); DEFVAR("*DEBUG-IO*",sLAdebug_ioA,LISP,fresh_synonym_stream_to_terminal_io(),""); DEFVAR("*TRACE-OUTPUT*",sLAtrace_outputA,LISP,fresh_synonym_stream_to_terminal_io(),""); void gcl_init_file(void) { object standard_input; object standard_output; object standard; standard_input = alloc_object(t_stream); standard_input->sm.tt=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 = make_simple_string("stdin"); standard_input->sm.sm_int = 0; /* unused */ standard_input->sm.sm_flags = 0; standard_output = alloc_object(t_stream); standard_output->sm.tt=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 = make_simple_string("stdout"); standard_output->sm.sm_int = 0; /* unused */ standard_output->sm.sm_flags=0; standard_error = alloc_object(t_stream); standard_error->sm.tt=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 = make_simple_string("stderr"); 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); } DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,""); DEFVAR("*LOAD-PATHNAME*",sLAload_pathnameA,LISP,Cnil,""); DEFVAR("*LOAD-TRUENAME*",sLAload_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("FILE-ERROR",sKfile_error,KEYWORD,""); DEF_ORDINARY("PATHNAME-ERROR",sKpathname_error,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,""); DEFUN("STREAM-OBJECT0",object,fSstream_object0,SI,1,1,NONE,OO,OO,OO,OO,(object strm),"") { object x; if (type_of(strm)!=t_stream) TYPE_ERROR(strm,sLstream); x=strm->sm.sm_object0; x=x==OBJNULL ? Cnil : x; RETURN1(x); } DEFUN("STREAM-OBJECT1",object,fSstream_object1,SI,1,1,NONE,OO,OO,OO,OO,(object strm),"") { object x; if (type_of(strm)!=t_stream) TYPE_ERROR(strm,sLstream); x=strm->sm.sm_object1; x=x==OBJNULL ? Cnil : x; RETURN1(x); } 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("OPEN1", Lopen1); */ make_function("FILE-POSITION", Lfile_position); make_function("FILE-LENGTH", Lfile_length); make_si_function("FILE-COLUMN", siLfile_column); /* make_function("READ-SEQUENCE", Lread_sequence); */ /* make_function("WRITE-SEQUENCE", Lwrite_sequence); */ /* make_si_function("LOAD1", Lload1); */ make_si_function("GET-STRING-INPUT-STREAM-INDEX", siLget_string_input_stream_index); 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.7.1/o/PaxHeaders/firstfile.c0000644000000000000000000000013214542551763013751 xustar0030 mtime=1703597043.288022878 30 atime=1744295002.689974124 30 ctime=1744351535.594908214 gcl-2.7.1/o/firstfile.c0000644000175000017500000000230014542551763013342 0ustar00cammcamm/* 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.7.1/o/PaxHeaders/backq.c0000644000000000000000000000012714555557372013055 xustar0029 mtime=1706483450.80039273 29 atime=1744339823.72346823 29 ctime=1744351535.47490929 gcl-2.7.1/o/backq.c0000644000175000017500000001611014555557372012446 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 sSXB; 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 (consp(x) || TS_MEMBER(type_of(x),TS(t_vector)|TS(t_simple_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 (consp(x) || TS_MEMBER(type_of(x),TS(t_vector)|TS(t_simple_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 (!consp(x)) { 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 (consp(vs_head) && 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; if (!consp(vs_head) || (vs_head->c.c_car!=siScomma_at && vs_head->c.c_car!=siScomma_dot)) return(EVAL); vs_push(Cnil); } kwote_cdr(); make_list; return(APPEND); case NCONC: if (vs_head == Cnil) { vs_popp; if (!consp(vs_head) || (vs_head->c.c_car!=siScomma_at && vs_head->c.c_car!=siScomma_dot)) return(EVAL); vs_push(Cnil); } 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 (!consp(x)) { 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) READER_ERROR(in,"A comma has appeared out of a backquote."); 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,ONE_VAL,ARGTYPES(OO,OO,OO,OO)),0); */ #define MAKE_AFUN(addr,n) fSinit_function(Cnil,(object)addr,Cnil,Cnil,-1,0,2|(2<<6)) /* DEF_ORDINARY("Y",sSY,SI,""); */ DEF_ORDINARY("XB",sSXB,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.7.1/o/PaxHeaders/num_comp.c0000644000000000000000000000013214756111241013565 xustar0030 mtime=1740149409.710008086 30 atime=1744339819.007438791 30 ctime=1744351535.466909362 gcl-2.7.1/o/num_comp.c0000644000175000017500000002104714756111241013167 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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) { double dx; static double dy; object q; enum type tx,ty; tx=type_of(x); ty=type_of(y); switch (tx) { case t_fixnum: switch (ty) { case t_fixnum: { fixnum fx=fix(x),fy=fix(y); return fxrat.rat_den); y = y->rat.rat_num; return(number_compare(x, y)); case t_shortfloat: { volatile float fx=fix(x); dx = fx; dy = sf(y); } goto LONGFLOAT; case t_longfloat: dx = fix(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto Y_COMPLEX; default: wrong_type_argument(sLnumber, y); } case t_bignum: switch (ty) { case t_fixnum: return big_sign(x) < 0 ? -1 : 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; return(number_compare(x, y)); case t_shortfloat: if ((float)number_to_double((q=double_to_integer((double)sf(y))))==sf(y)) return(number_compare(x,q)); dx=number_to_double(x); dy=sf(y); goto LONGFLOAT; case t_longfloat: if (number_to_double((q=double_to_integer(lf(y))))==lf(y)) return(number_compare(x,q)); 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 (ty) { case t_fixnum: case t_bignum: y = number_times(y, x->rat.rat_den); x = x->rat.rat_num; return(number_compare(x, y)); case t_ratio: { object x1,y1; x1=number_times(x->rat.rat_num,y->rat.rat_den); y1=number_times(y->rat.rat_num,x->rat.rat_den); return(number_compare(x1,y1)); } case t_shortfloat: return(number_compare(x,double_to_rational(sf(y)))); case t_longfloat: return(number_compare(x,double_to_rational(lf(y)))); case t_complex: goto Y_COMPLEX; default: wrong_type_argument(sLnumber, y); } case t_shortfloat: dx = sf(x); goto LONGFLOAT0; case t_longfloat: dx = lf(x); LONGFLOAT0: switch (ty) { case t_fixnum: if (tx==t_shortfloat) { volatile float fy=fix(y); dy=fy; } else dy=fix(y); goto LONGFLOAT; case t_bignum: if (number_to_double((q=double_to_integer(dx)))==dx) return(number_compare(q,y)); dy=number_to_double(y); goto LONGFLOAT; case t_ratio: return(number_compare(double_to_rational(dx),y)); case t_shortfloat: dy = sf(y); goto LONGFLOAT; case t_longfloat: dy = lf(y); goto LONGFLOAT; case t_complex: goto Y_COMPLEX; default: break; } LONGFLOAT: return(dx < dy ? -1 : (dx == dy) ? 0 : 1); Y_COMPLEX: if (number_zerop(y->cmp.cmp_imag)) return(number_compare(x, y->cmp.cmp_real) ? 1 : 0); else return(1); case t_complex: if (ty != t_complex) { if (number_zerop(x->cmp.cmp_imag)) return(number_compare(x->cmp.cmp_real, y) ? 1 : 0); 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; } DEFUN("<2",object,fSl2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(!gcl_isnan(x) && !gcl_isnan(y) && number_compare(x,y)<0 ? Ct : Cnil); } DEFUN("<=2",object,fSle2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(!gcl_isnan(x) && !gcl_isnan(y) && number_compare(x,y)<1 ? Ct : Cnil); } DEFUN(">2",object,fSg2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(!gcl_isnan(x) && !gcl_isnan(y) && number_compare(x,y)>0 ? Ct : Cnil); } DEFUN(">=2",object,fSge2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(!gcl_isnan(x) && !gcl_isnan(y) && number_compare(x,y)>-1 ? Ct : Cnil); } DEFUN("=2",object,fSe2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(!gcl_isnan(x) && !gcl_isnan(y) && number_compare(x,y)==0 ? Ct : Cnil); } DEFUN("/=2",object,fSne2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(gcl_isnan(x) || gcl_isnan(y) || number_compare(x,y)!=0 ? Ct : Cnil); } DEFUN("MAX2",object,fSx2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { object z=fixnum_float_contagion(x,y); y=fixnum_float_contagion(y,z); RETURN1(number_compare(z,y)<0 ? y : z); } DEFUN("MIN2",object,fSm2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { object z=fixnum_float_contagion(x,y); y=fixnum_float_contagion(y,z); RETURN1(number_compare(z,y)>0 ? y : z); } 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++) { object x=fixnum_float_contagion(vs_base[i],max); max=fixnum_float_contagion(max,vs_base[i]); max = number_compare(max,x) < 0 ? x : max; } 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++) { object x=fixnum_float_contagion(vs_base[i],min); min=fixnum_float_contagion(min,vs_base[i]); min = number_compare(min,x) > 0 ? x : min; } 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.7.1/o/PaxHeaders/character.d0000644000000000000000000000013214763573237013724 xustar0030 mtime=1741616799.681591281 30 atime=1744340056.056936539 30 ctime=1744351535.574908393 gcl-2.7.1/o/character.d0000644000175000017500000003606114763573237013330 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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" #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 */ @(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: x=coerce_to_string(x); case t_simple_string: case t_string: if (VLEN(x) == 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); b=make_fixnum(0);/*FIXME*/ check_type_non_negative_integer(&b); f=make_fixnum(0);/*FIXME*/ 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)`)) object x,f; int dw; @ check_type_non_negative_integer(&w); check_type_non_negative_integer(&r); f=make_fixnum(0);/*FIXME*/ 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) } if (char_code(c)<' ' || char_code(c) >='\177') { object x=make_simple_string(" "); x->st.st_self[0]=char_code(c); @(return x) } @(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')`) if (VLEN(s)==1) @(return `code_char(s->st.st_self[0])`) if (VLEN(s)==2 && s->st.st_self[0]=='^') { int ch=s->st.st_self[1]-'A'+1; @(return `code_char(ch)`) } if (VLEN(s)==3 && s->st.st_self[0]=='^' && s->st.st_self[1]=='\\' && s->st.st_self[2]=='\\') { int ch=s->st.st_self[1]-'A'+1; @(return `code_char(ch)`) } if (VLEN(s)==4 && s->st.st_self[0]=='\\') { int ch=(s->st.st_self[1]-'0')*8*8+(s->st.st_self[2]-'0')*8+(s->st.st_self[3]-'0'); @(return `code_char(ch)`) } @(return Cnil) @) void gcl_init_character() { int i; for (i = 0; i < CHCODELIM; i++) { object x=(object)(character_table+i),y=(object)(character_name_table+i); set_type_of(x,t_character); x->ch.ch_code = i; x->ch.tt=((' ' <= i && i < '\177') || i == '\n'); x->ch.ch_font = 0; x->ch.ch_bits = 0; x->ch.ch_name=y; set_type_of(y,t_simple_string); y->sst.sst_hasfillp = FALSE; y->sst.sst_adjustable = FALSE; set_array_elttype(y,aet_ch); y->sst.sst_rank = 1; y->sst.sst_dim = 1; y->sst.sst_self = (void *)&x->ch.ch_code; } 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.7.1/o/PaxHeaders/save.c0000644000000000000000000000013114763154757012726 xustar0030 mtime=1741478383.168857563 30 atime=1744339826.499485567 29 ctime=1744351535.59090825 gcl-2.7.1/o/save.c0000644000175000017500000000105114763154757012322 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #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) { extern char *kcl_self; check_arg(1); gcl_cleanup(1); coerce_to_filename(vs_base[0], FN1); #ifdef MEMORY_SAVE MEMORY_SAVE(kcl_self,FN1); #else memory_save(kcl_self, FN1); #endif /* no return */ exit(0); } gcl-2.7.1/o/PaxHeaders/sockets.c0000644000000000000000000000013114566141714013431 xustar0029 mtime=1708704716.16221807 30 atime=1744339828.871500386 30 ctime=1744351535.482909218 gcl-2.7.1/o/sockets.c0000644000175000017500000003316514566141714013040 0ustar00cammcamm/* Copyright (C) 1994 Rami el Charif, W. Schelter Copyright (C) 2024 Camm Maguire 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.h" #ifdef HAVE_NSOCKET #include "sheader.h" #include #ifndef __MINGW32__ # include # include # include #else # include # include #endif #ifdef __STDC__ #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("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("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("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("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_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("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 = #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("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("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 = #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("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("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("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("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 = VLEN(str); 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(!stringp(str)) 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 (stringp_tp(t)) { 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('-');} x=x->s.s_name; case t_simple_string:/*FIXME?*/ case t_string: {int len = VLEN(x); 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("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("RESET-STRING-INPUT-STREAM",object,fSreset_string_input_stream,SI,4,4,NONE,OO,OI,IO,OO,(object strm,object string,fixnum start,fixnum end), "Reuse a string output STREAM by setting its output to STRING \ and positioning the ouput/input to start at START and end at END") { massert(type_of(string)==t_string); strm->sm.sm_object0 = string; STRING_INPUT_STREAM_NEXT(strm) = start; STRING_INPUT_STREAM_END(strm) = end; return strm; } DEFUN("CHECK-STATE-INPUT",object,fScheck_state_input,SI,2,2,NONE,IO,IO,OO,OO,(object osfd,fixnum timeout), "") { return (object)fScheck_dsfd_for_input(OBJ_TO_CONNECTION_STATE(osfd),timeout); } DEFUN("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.7.1/o/PaxHeaders/num_rand.c0000644000000000000000000000013214566152355013565 xustar0030 mtime=1708709101.982540163 30 atime=1744339821.903456867 30 ctime=1744351535.470909326 gcl-2.7.1/o/num_rand.c0000644000175000017500000001235214566152355013166 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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); BLOCK_EXCEPTIONS(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 reinit_gmp() { #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 } 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.7.1/o/PaxHeaders/gcl_readline.d0000644000000000000000000000013214763573237014400 xustar0030 mtime=1741616799.681591281 30 atime=1744340056.076936668 30 ctime=1744351535.574908393 gcl-2.7.1/o/gcl_readline.d0000644000175000017500000001613314763573237014002 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 2000 Tuukka Toivonen Copyright (C) 2024 Camm Maguire 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 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 (stringp(sSAreadline_prefixA->s.s_dbind)) { pref=fpref=sSAreadline_prefixA->s.s_dbind->st.st_self; prefl=fprefl=VLEN(sSAreadline_prefixA->s.s_dbind); 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 { package=find_package(str((char *)temp1)); } } package=(package!=OBJNULL && package!=Cnil) ? 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; 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]; } while (tp != OBJNULL && tp != Cnil) { while (1) { while (consp(l)) { struct symbol sym=l->c.c_car->s; ufixnum prf=0; l=l->c.c_cdr; if (pref) { if (VLEN(sym.s_name)st.st_self,prefl)) continue; prf=prefl; } if (VLEN(sym.s_name)-prf>=len && !strncasecmp(wtext,sym.s_name->st.st_self+prf,len)) { static char *c; c=malloc((wtext-ftext)+VLEN(sym.s_name)-prf+1); memcpy(c,ftext,wtext-ftext); memcpy(c+(wtext-ftext),sym.s_name->st.st_self+prf,VLEN(sym.s_name)-prf); c[(wtext-ftext)+VLEN(sym.s_name)-prf]=0; return c; } } if (++i>=size) break; l=base[i]; } tp=use->c.c_car; use=use->c.c_cdr; base=tp==Cnil ? NULL : (internal ? tp->p.p_internal : tp->p.p_external); size=tp==Cnil ? 0 : (internal ? tp->p.p_internal_size : tp->p.p_external_size); i=0; l=base==NULL ? Cnil : 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) { 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 int rl_getc_em(FILE *f) { static char *line = NULL; static int linepos = 0; 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; } if (line==NULL) { if (readline_on==1) { putc('\r', stdout); line = readline(rl_putc_em_line); rl_putc_em('\r', stdout); if (line==NULL) return *rl_line_buffer=EOF; if (line[0] != 0) add_history(line); } else { return getc(f); } } if (line[linepos]==0) { free(line); line = NULL; linepos = 0; if (rl_line_buffer) *rl_line_buffer=0; return '\n'; } return line[linepos++]; } 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.7.1/o/PaxHeaders/sfaslelf.c0000644000000000000000000000013114776006046013556 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.302035078 29 ctime=1744351535.59090825 gcl-2.7.1/o/sfaslelf.c0000644000175000017500000003150114776006046013155 0ustar00cammcamm/* Copyright (C) 1994 W. Schelter Copyright (C) 2024 Camm Maguire 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 LOCAL_SYM(sym) ELF_ST_BIND(sym->st_info)==STB_LOCAL #define EXT_SYM(sym,st1) (ELF_ST_BIND(sym->st_info)==STB_GLOBAL|| \ ELF_ST_BIND(sym->st_info)==STB_WEAK|| \ GCC_SYM(sym,st1)|| \ PSPEC_SYM(sym,st1)) /*e.g. arm soft float functions*/ #define GCC_SYM(sym,st1) (ELF_ST_BIND(sym->st_info)==STB_LOCAL && \ ELF_ST_TYPE(sym->st_info)==STT_FUNC && \ st1[sym->st_name]=='_') /*e.g. parisc millicode*/ #define PSPEC_SYM(sym,st1) (ELF_ST_BIND(sym->st_info)==STB_LOCAL && \ ELF_ST_TYPE(sym->st_info)>=STT_LOPROC) #define MASK(n) ((ul)(~(~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("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); else bzero((void *)sec->sh_addr,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)); memory->cfd.cfd_name=faslfile->sm.sm_object1; 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 if(symbol_value(sLAload_verboseA)!=Cnil) { coerce_to_filename(memory->cfd.cfd_name,FN1); printf(";; start address for %s %p\n",FN1,memory->cfd.cfd_start); fflush(stdout); } init_address-=(ul)memory->cfd.cfd_start; call_init(init_address,memory,faslfile); return(memory->cfd.cfd_size); } #include "sfasli.c" gcl-2.7.1/o/PaxHeaders/msbrk.c0000644000000000000000000000013214766555457013114 xustar0030 mtime=1742396207.146952854 30 atime=1744339830.115508159 30 ctime=1744351535.486909183 gcl-2.7.1/o/msbrk.c0000644000175000017500000000210314766555457012506 0ustar00cammcamm#define _GNU_SOURCE #include #include "include.h" static void *m; static ufixnum sz,mps; int msbrk_end(void) { sz+=(ufixnum)m; mps=sz; m=NULL; return 0; } #if !defined(DARWIN) && !defined(__CYGWIN__) && !defined(__MINGW32__) && !defined(__MINGW64__)/*FIXME*/ static void * new_map(void *v,ufixnum s) { return mmap(v,s,PROT_READ|PROT_WRITE|PROT_EXEC,MAP_PRIVATE|MAP_ANON|MAP_FIXED,-1,0); } int msbrk_init(void) { if (!m) { extern int gcl_alloc_initialized; extern fixnum _end; void *v; v=gcl_alloc_initialized ? core_end : (void *)ROUNDUP((void *)&_end,getpagesize()); m=(void *)ROUNDUP((ufixnum)v,PAGESIZE); massert(!gcl_alloc_initialized || v==m); if (v!=m) massert(new_map(v,m-v)!=(void *)-1); mps=sz=0; } return 0; } void * msbrk(intptr_t inc) { size_t p2=ROUNDUP(sz+inc,PAGESIZE); if (mps #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("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) { useconds_t um=-1,ul=um/1000000; double d; 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]); d=number_to_double(vs_base[0]); d=d<1 ? 0 : d; usleep(d>ul ? um : d*1000000); vs_top = vs_base; vs_push(Cnil); } DEFUNM("GET-INTERNAL-RUN-TIMES",object,fSget_internal_run_times,SI,0,0,NONE,OO,OO,OO,OO,(),"") { object *base=vs_top; #ifdef USE_INTERNAL_REAL_TIME_FOR_RUNTIME RETURN2(fLget_internal_real_time(),small_fixnum(0)); #else struct tms buf; fixnum vals=(fixnum)fcall.valp; times(&buf); RETURN4(make_fixnum(buf.tms_utime),make_fixnum(buf.tms_cutime),make_fixnum(buf.tms_stime),make_fixnum(buf.tms_cstime)); #endif } DEFUN("GET-INTERNAL-RUN-TIME",object,fLget_internal_run_time,LISP ,0,0,NONE,OO,OO,OO,OO,(void),"") { object x=(fcall.valp=0,FFN(fSget_internal_run_times)()); RETURN1(x); } DEFUN("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; } #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 } #ifdef STATIC_FUNCTION_POINTERS object fSgettimeofday() { return FFN(fSgettimeofday)(); } #endif DEFUN("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); } #ifdef __MINGW32__ int usleep1 ( unsigned int microseconds ) { unsigned int milliseconds = microseconds / 1000; return ( SleepEx ( milliseconds, TRUE ) ); } #endif DEFUN("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("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 } 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("LOCALTIME",object,fSlocaltime,SI,1,1,NONE,OO,OO,OO,OO,(object t),"") { fixnum vals=(fixnum)fcall.valp; object *base=vs_top; #if defined NO_SYSTEM_TIME_ZONE /*solaris*/ return Cnil; #else time_t i=object_to_time_t(t); struct tm *lt; object zn; #if defined(__MINGW32__) struct tm *gt; fixnum gmt_hour; massert(gt=gmtime(&i)); gmt_hour=gt->tm_hour; #endif massert(lt=localtime(&i)); zn=make_simple_string(lt->tm_zone); 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(zn)/*make_simple_string(lt->tm_zone)*/ #endif )); #endif } DEFUNM("GMTIME",object,fSgmtime,SI,1,1,NONE,OO,OO,OO,OO,(object t),"") { fixnum vals=(fixnum)fcall.valp; object *base=vs_top; #if defined NO_SYSTEM_TIME_ZONE /*solaris*/ return Cnil; #else time_t i=object_to_time_t(t); struct tm *gt; object zn; massert(gt=gmtime(&i)); zn=make_simple_string(gt->tm_zone); 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(zn)/*make_simple_string(gt->tm_zone)*/ #endif )); #endif } DEFUNM("MKTIME",object,fSmktime,SI,7,7,NONE,OI,II,II,II, (fixnum s,fixnum n,fixnum h,fixnum d,fixnum m,fixnum y,fixnum isdst),"") { struct tm lt; time_t t; fixnum vals=(fixnum)fcall.valp; object *base=vs_top; 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=isdst; massert((t=mktime(<))!=-1); RETURN(2,object,time_t_to_object(t),(RV(make_fixnum(lt.tm_isdst)))); } gcl-2.7.1/o/PaxHeaders/regexp.c0000644000000000000000000000013214555557372013262 xustar0030 mtime=1706483450.804392729 30 atime=1744339822.879462961 30 ctime=1744351535.586908286 gcl-2.7.1/o/regexp.c0000644000175000017500000011014714555557372012664 0ustar00cammcamm/* original regexp.c file written by Henry Spencer. many changes made [see below] made by W. Schelter. These changes Copyright (c) 1994 W. Schelter These changes Copyright (c) 2024 Camm Maguire 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 "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(*p)] = matches; result[toupper(*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(prog->regstart); while (*s) { if (tolower(*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(*opnd) != tolower(*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(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(*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(*opnd); while (ch == tolower(*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(*ss)],n); MINIMIZE(buf[toupper(*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.7.1/o/PaxHeaders/num_arith.c0000644000000000000000000000013214555557372013756 xustar0030 mtime=1706483450.804392729 30 atime=1744339819.343440888 30 ctime=1744351535.466909362 gcl-2.7.1/o/num_arith.c0000644000175000017500000006643314555557372013370 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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. */ /* Arithmetic operations */ #define NEED_MP_H #define NEED_ISFINITE #include "include.h" #include "num_include.h" object fixnum_add(fixnum i, fixnum j) { if (i>=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 (j <= (i-MOST_NEGATIVE_FIX)) { return make_fixnum(i-j); } MPOP(return,subss,i,j); } } inline 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); } } static object integer_exact_quotient(object r,object x,object y) { if (y==small_fixnum(1) || x==small_fixnum(0)) return x; if (type_of(x)==t_fixnum) /* no in_place for fixnums as could be small */ return make_fixnum((type_of(y)==t_fixnum ? fix(x)/fix(y) : -1)); /* Only big dividing a fix is most-negative-fix/abs(most-negative-fix)*/ if (type_of(y)==t_fixnum) mpz_divexact_ui(MP(r),MP(x),fix(y)); else mpz_divexact(MP(r),MP(x),MP(y)); return normalize_big(r); } static object fixnum_abs(object x) { if (type_of(x)==t_fixnum) { fixnum f=fix(x); return f==MOST_NEGATIVE_FIX ? sSPminus_most_negative_fixnumP->s.s_dbind : (f<0 ? make_fixnum(-f) : x); } return x; } static object get_gcd_r_abs(object r,object x,object y) { if (x==small_fixnum(1) || y==small_fixnum(1)) return small_fixnum(1); switch(type_of(x)) { case t_fixnum: switch(type_of(y)) { case t_fixnum: return make_fixnum(fixnum_gcd(fix(x),fix(y))); default: mpz_gcd_ui(MP(r),MP(y),fix(x)); return normalize_big(r); } default: switch(type_of(y)) { case t_fixnum: mpz_gcd_ui(MP(r),MP(x),fix(y)); return normalize_big(r); default: mpz_gcd(MP(r),MP(x),MP(y)); return normalize_big(r); } } } static object get_gcd_r(object r,object x,object y) { return get_gcd_r_abs(r,fixnum_abs(x),fixnum_abs(y)); } object get_gcd(object x,object y) { x=get_gcd_r(big_fixnum1,x,y); return x==big_fixnum1 ? replace_big(x) : x; } static object get_gcd_abs(object x,object y) { x=get_gcd_r_abs(big_fixnum1,x,y); return x==big_fixnum1 ? replace_big(x) : x; } static object integer_times(object r,object a,object b) { if (a==small_fixnum(1)) return b; if (b==small_fixnum(1)) return a; if (type_of(a)==t_fixnum) if (type_of(b)==t_fixnum) return fixnum_times(fix(a),fix(b)); else { mpz_mul_si(MP(r),MP(b),fix(a)); return normalize_big(r); } else if (type_of(b)==t_fixnum) { mpz_mul_si(MP(r),MP(a),fix(b)); return normalize_big(r); } else { mpz_mul(MP(r),MP(a),MP(b)); return normalize_big(r); } } #define mneg(a_) ((a_)==MOST_NEGATIVE_FIX ? (ufixnum)(a_) : (ufixnum)(-(a_))) #define mpz_add_si(a_,b_,c_) ((c_)<0 ? mpz_sub_ui(a_,b_,mneg(c_)) : mpz_add_ui(a_,b_,c_)) #define mpz_sub_si(a_,b_,c_) ((c_)<0 ? mpz_add_ui(a_,b_,mneg(c_)) : mpz_sub_ui(a_,b_,c_)) static object integer_add(object r,object a,object b) { if (a==small_fixnum(0)) return b; if (b==small_fixnum(0)) return a; if (type_of(a)==t_fixnum) if (type_of(b)==t_fixnum) return fixnum_add(fix(a),fix(b)); else { mpz_add_si(MP(r),MP(b),fix(a)); return normalize_big(r); } else if (type_of(b)==t_fixnum) { mpz_add_si(MP(r),MP(a),fix(b)); return normalize_big(r); } else { mpz_add(MP(r),MP(a),MP(b)); return normalize_big(r); } } static object integer_sub(object r,object a,object b) { /* if (a==small_fixnum(0)) */ /* return b; */ if (b==small_fixnum(0)) return a; if (type_of(a)==t_fixnum) if (type_of(b)==t_fixnum) return fixnum_sub(fix(a),fix(b)); else { mpz_sub_si(MP(r),MP(b),fix(a)); mpz_neg(MP(r),MP(r)); return normalize_big(r); } else if (type_of(b)==t_fixnum) { mpz_sub_si(MP(r),MP(a),fix(b)); return normalize_big(r); } else { mpz_sub(MP(r),MP(a),MP(b)); return normalize_big(r); } } static object ratio_mult_with_cancellation(object a,object b,object c,object d) { object gad,gbc; gad=get_gcd_r(big_fixnum2,a,d); gbc=get_gcd_r(big_fixnum5,b,c); a=integer_exact_quotient(big_fixnum3,a,gad); c=integer_exact_quotient(big_fixnum4,c,gbc); a=integer_times(big_fixnum3,a,c);/*integer_times can clobber big_fixnum1*/ if (a==big_fixnum3 || a==big_fixnum4) a=replace_big(a); b=integer_exact_quotient(big_fixnum3,b,gbc); d=integer_exact_quotient(big_fixnum4,d,gad); b=integer_times(big_fixnum3,b,d);/*integer_times can clobber big_fixnum1*/ if (b==big_fixnum3 || b==big_fixnum4) b=replace_big(b); return make_ratio(a,b,1); } static object ratio_op_with_cancellation(object a,object b,object c,object d,object (*op)(object,object,object)) { object b0,d0,g,t,g1; b0=b; d0=d; g=get_gcd_r(big_fixnum2,b,d); b=integer_exact_quotient(big_fixnum3,b,g); d=integer_exact_quotient(big_fixnum4,d,g); c=integer_times(big_fixnum3,b,c);/*integer_times can clobber big_fixnum1*/ a=integer_times(big_fixnum5,a,d);/*integer_times can clobber big_fixnum1*/ t=op(big_fixnum3,a,c); g1=get_gcd_r(big_fixnum2,t,g); t=integer_exact_quotient(big_fixnum3,t,g1); if (t==big_fixnum3 || t==big_fixnum4 || t==big_fixnum5) t=replace_big(t); b=integer_exact_quotient(big_fixnum2,b0,g1); b=integer_times(big_fixnum2,b,d);/*integer_times can clobber big_fixnum1*/ if (b==big_fixnum2 || b==big_fixnum4) b=replace_big(b); return make_ratio(t,b,1); } 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: return ratio_op_with_cancellation(x,small_fixnum(1), y->rat.rat_num,y->rat.rat_den, integer_add); 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: return ratio_op_with_cancellation(x,small_fixnum(1), y->rat.rat_num,y->rat.rat_den, integer_add); 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: return ratio_op_with_cancellation(x->rat.rat_num,x->rat.rat_den, y,small_fixnum(1), integer_add); case t_ratio: return ratio_op_with_cancellation(x->rat.rat_num,x->rat.rat_den, y->rat.rat_num,y->rat.rat_den, integer_add); 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);/*FPE*/ 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: return ratio_op_with_cancellation(x->rat.rat_num,x->rat.rat_den, small_fixnum(1),small_fixnum(1), integer_add); 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: return ratio_op_with_cancellation(x,small_fixnum(1), y->rat.rat_num,y->rat.rat_den, integer_sub); 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: return ratio_op_with_cancellation(x,small_fixnum(1), y->rat.rat_num,y->rat.rat_den, integer_sub); 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: return ratio_op_with_cancellation(x->rat.rat_num,x->rat.rat_den, y,small_fixnum(1), integer_sub); case t_ratio: return ratio_op_with_cancellation(x->rat.rat_num,x->rat.rat_den, y->rat.rat_num,y->rat.rat_den, integer_sub); 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);/*FPE*/ 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: return ratio_op_with_cancellation(x->rat.rat_num,x->rat.rat_den, small_fixnum(1),small_fixnum(1), integer_sub); 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; switch (type_of(x)) { case t_fixnum: if(fix(x) == MOST_NEGATIVE_FIX) return sSPminus_most_negative_fixnumP->s.s_dbind; /* fixnum_add(1,MOST_POSITIVE_FIX); */ else return(make_fixnum(-fix(x))); case t_bignum: return big_minus(x); case t_ratio: return make_ratio(number_negate(x->rat.rat_num),x->rat.rat_den,1); 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)); case t_bignum: MPOP(return,mulsi,fix(x),MP(y)); case t_ratio: return ratio_mult_with_cancellation(x,small_fixnum(1), y->rat.rat_num,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,mulsi,fix(y),MP(x)); case t_bignum: MPOP(return,mulii,MP(y),MP(x)); case t_ratio: return ratio_mult_with_cancellation(x,small_fixnum(1), y->rat.rat_num,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: return ratio_mult_with_cancellation(x->rat.rat_num,x->rat.rat_den, y,small_fixnum(1)); case t_ratio: return ratio_mult_with_cancellation(x->rat.rat_num,x->rat.rat_den, y->rat.rat_num,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_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);/*FPE*/ /* if (number_zerop(z) && dx && dy) FLOATING_POINT_UNDERFLOW(sLA,list(2,x,y)); */ /* if (!ISFINITE(sf(z)) && ISFINITE(dx) && ISFINITE(dy)) FLOATING_POINT_OVERFLOW(sLA,list(2,x,y)); */ 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;/*FPE*/ /* if (number_zerop(z) && dx && dy) FLOATING_POINT_UNDERFLOW(sLA,list(2,x,y)); */ /* if (!ISFINITE(lf(z)) && ISFINITE(dx) && ISFINITE(dy)) FLOATING_POINT_OVERFLOW(sLA,list(2, x,y));*/ 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, 0); */ return(make_ratio(x, y, 0)); case t_ratio: /* if(number_zerop(y->rat.rat_num)) DIVISION_BY_ZERO(sLD,list(2,x,y)); */ return ratio_mult_with_cancellation(x,small_fixnum(1),y->rat.rat_den,y->rat.rat_num); 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)) DIVISION_BY_ZERO(sLD,list(2,x,y)); */ return ratio_mult_with_cancellation(x->rat.rat_num,x->rat.rat_den, small_fixnum(1),y); case t_ratio: return ratio_mult_with_cancellation(x->rat.rat_num,x->rat.rat_den, y->rat.rat_den,y->rat.rat_num); 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) DIVISION_BY_ZERO(sLD,list(2,x,y)); */ sf(z) = (shortfloat)(dx / dy);/*FPE ?*/ 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) DIVISION_BY_ZERO(sLD,list(2,x,y)); */ 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); z3 = number_plus(z1, z2); /* if (number_zerop(z3 = number_plus(z1, z2))) DIVISION_BY_ZERO(sLD,list(2,x,y)); */ 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 number_recip(object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: return(make_ratio(small_fixnum(1), x, 1)); case t_ratio: return(make_ratio(x->rat.rat_den,x->rat.rat_num, 1)); case t_shortfloat: return make_shortfloat(1.0/sf(x)); case t_longfloat: return make_longfloat(1.0/lf(x)); case t_complex: return number_divide(make_complex(x->cmp.cmp_real,number_negate(x->cmp.cmp_imag)), number_plus(number_times(x->cmp.cmp_real,x->cmp.cmp_real), number_times(x->cmp.cmp_imag,x->cmp.cmp_imag))); 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); } DEFUN("P2",object,fSp2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_plus(x,y)); } DEFUN("M2",object,fSs2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_minus(x,y)); } DEFUN("*2",object,fSt2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_times(x,y)); } DEFUN("/2",object,fSd2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_divide(x,y)); } DEFUN("NUMBER-PLUS",object,fSnumber_plus,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_plus(x,y)); } DEFUN("NUMBER-MINUS",object,fSnumber_minus,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_minus(x,y)); } DEFUN("NUMBER-NEGATE",object,fSnumber_negate,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(number_negate(x)); } DEFUN("NUMBER-TIMES",object,fSnumber_times,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_times(x,y)); } DEFUN("NUMBER-DIVIDE",object,fSnumber_divide,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(number_divide(x,y)); } DEFUN("NUMBER-RECIP",object,fSnumber_recip,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(number_recip(x)); } 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]); vs_top = vs_base+1; 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;i */ /* #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("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[VLEN(x)]; x->st.st_self[VLEN(x)]=0; a=find_sym_ptable(x->st.st_self); x->st.st_self[VLEN(x)]=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.7.1/o/PaxHeaders/main.c0000644000000000000000000000013214776006046012704 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.302035078 30 ctime=1744351535.454909469 gcl-2.7.1/o/main.c0000644000175000017500000007633414776006046012317 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 static void init_main(void); static void initlisp(void); static int multiply_stacks(int); void install_segmentation_catcher(void); #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); #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 int cstack_dir=0; int get_cstack_dir(VOL fixnum j) { static fixnum n; fixnum q=n; n=1-n; return q ? ((fixnum)&j(void *)&l) bzero((void *)&l,l-(void *)&l); } else { l+=sizeof(l); if ((void *)&l>l) bzero((void *)l,(void *)&l-l); } } void clear_c_stack(VOL unsigned n) { void *v=OBJNULL; alloca(n); wipe_stack(&v); } static fixnum log_maxpage_bound=sizeof(fixnum)*8-1; static fixnum mem_bound=sizeof(fixnum)*8-1; int mbrk(void *v) { ufixnum uv=(ufixnum)v,uc=(ufixnum)sbrk(0),ux,um; fixnum m=((1UL<<(sizeof(fixnum)*8-1))-1); if (uv=0); *s+=i; if (!(p=memchr(FN1,'\n',*s))) return NULL; *p=0; return FN1; } static void parse_meminfo_decimal(char *c,char *h,ufixnum *t) { ufixnum n=strlen(h); if (memcmp(h,c,n)) return; massert(sscanf(c+n,"%ld kB",t)==1); *t<<=10; *t>>=PAGEWIDTH; } static void parse_proc_meminfo(ufixnum *t,ufixnum *f,ufixnum *st,ufixnum *sf) { int l; ufixnum r=0; char *s="/proc/meminfo",*c; *t=*f=*st=*sf=0; massert((l=open(s,O_RDONLY))>=0); for (;(c=next_line(l,&r));) { parse_meminfo_decimal(c,"MemTotal:",t); parse_meminfo_decimal(c,"MemFree:",f); parse_meminfo_decimal(c,"SwapTotal:",st); parse_meminfo_decimal(c,"SwapFree:",sf); } massert(!close(l)); } #if defined(__CYGWIN__)||defined(__MINGW32__) #include static ufixnum get_phys_pages_no_malloc(char n,char ramp) { 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,char ramp) { 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__) static ufixnum get_phys_pages_no_malloc(char n,char ramp) { return sysconf(_SC_PHYS_PAGES); } #elif defined(FREEBSD) #include #include static ufixnum get_phys_pages_no_malloc(char n,char ramp) { size_t i,len=sizeof(i); return (sysctlbyname("hw.physmem",&i,&len,NULL,0) ? 0 : i)>>PAGEWIDTH; } #else /*Linux*/ static ufixnum get_phys_pages_no_malloc(char freep,char ramp) { ufixnum t,f,st,sf; parse_proc_meminfo(&t,&f,&st,&sf); return (freep ? (ramp ? f : f+sf) : (ramp ? t : t+st)); } #endif static ufixnum get_phys_pages1(char freep,char ramp) { ufixnum p=get_phys_pages_no_malloc(freep,ramp); #if defined(__GNU__)/*FIXME -- no mmap overcommit as of yet*/ p>>=1; #endif return p; } static int acceptable_log_maxpage_bound(ufixnum l) { ufixnum max=(sizeof(fixnum)<<3)-1; return l>max ? 0 : (l==max ? 1 : (void *)heap_end-data_start+CEI(rb_pointer-rb_begin(),PAGESIZE) < (1UL<<(l+1))); } 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); } mem_bound=sizeof(fixnum)*8-1; if ((e=getenv("GCL_MEM_BOUND"))) { ufixnum f; massert(sscanf(e,"%lud",&f)==1); if (acceptable_log_maxpage_bound(f)) { mem_bound=f; mem_multiple=1.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=getenv("GCL_MULTIPROCESS_MEMORY_POOL"); if (multiprocess_memory_pool && (*multiprocess_memory_pool=='t' || *multiprocess_memory_pool=='T'))/*GCL 2.6 compatability*/ multiprocess_memory_pool=getenv("HOME"); 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; } static void * next_shared_lib_map_no_malloc(void) { #if !defined(DARWIN) && !defined(__CYGWIN__) && !defined(__MINGW32__) && !defined(__MINGW64__)/*FIXME*/ char *c,rwx[4]; ufixnum a,e,s=(ufixnum)sbrk(0),r; int l; massert((l=open("/proc/self/maps",O_RDONLY))!=-1); for (a=r=0;(a<=s || !memcmp(rwx,"---",3)) && (c=next_line(l,&r));) sscanf(c,"%lx-%lx %3s",&a,&e,rwx); massert(!close(l)); return (void *)(c ? a : -1); #else return (void *)-1; #endif } static void *stack_map_base=(void *)-1; void *shared_lib_start=(void *)-1; static int set_real_maxpage(void *beg) { void *end,*cp; ufixnum mp,sz; end=(void *)ROUNDDN((void *)-1,PAGESIZE); mp=page(end-beg); mp=ufmin(mp,get_phys_pages1(0,0)); sz=ufmin(mem_bound,log_maxpage_bound); sz=(1UL< size_t dir_name_length(const char *s) { size_t m; const char *z; for (m=strlen(s),z=kcl_self+m;z>s && z[-1]!='/';z--,m--); return m; } int initializing_boot=0; void init_boot(void) { char *sysd=getenv("GCL_SYSDIR"),*d=sysd ? sysd : kcl_self; #ifndef __CYGWIN__ void *v,*q; #endif char *z,*s="libboot.so"; size_t m=sysd ? strlen(sysd) : dir_name_length(kcl_self),n=m+strlen(s)+1; object omp=sSAoptimize_maximum_pagesA->s.s_dbind; sSAoptimize_maximum_pagesA->s.s_dbind=Cnil; z=alloca(n); snprintf(z,n,"%-*.*s%s",(int)m,(int)m,d,s); #ifndef __CYGWIN__ if (!(v=dlopen(z,RTLD_LAZY|RTLD_GLOBAL))) printf("%s\n",dlerror()); if (!(q=dlsym(v,"gcl_init_boot"))) printf("%s\n",dlerror()); #endif initializing_boot=1; #ifdef __CYGWIN__ { extern void gcl_init_boot(void); gcl_init_boot(); } #else ((void (*)())q)(); #endif initializing_boot=0; sSAoptimize_maximum_pagesA->s.s_dbind=omp; } int in_pre_gcl=0; object def_env1[2]={(object)1,Cnil},*def_env=def_env1+1; object src_env1[2]={(object)1,Cnil},*src_env=src_env1+1; #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 #ifdef USE_GPROF gprof_cleanup(); #endif if (gc) { saving_system=TRUE; GBC(t_other); saving_system=FALSE; minimize_image(); raw_image=FALSE; cs_org=0; msbrk_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 DEFUN("KCL-SELF",object,fSkcl_self,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { return make_simple_string(kcl_self); } int main(int argc, char **argv, char **envp) { GET_FULL_PATH_SELF(kcl_self); *argv=kcl_self; vs_top = vs_base = vs_org; ihs_top = ihs_org-1; bds_top = bds_org-1; frs_top = frs_org-1; #include "cstack.h" 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; ENVP = envp; if (raw_image) { printf("GCL (GNU Common Lisp) %s %ld pages\n",LISP_IMPLEMENTATION_VERSION,real_maxpage); fflush(stdout); initlisp(); ihs_top++;lex_new();/*FIXME*/ 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 if (in_pre_gcl) init_boot(); } #ifdef _WIN32 detect_wine(); #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]: ~a",1,str(s)); } } printf("\nUnrecoverable error: %s.\n", s); fflush(stdout); #ifdef UNIX gcl_abort(); #endif } 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->s.s_dbind = Cnil; Cnil->s.s_sfdef = NOT_SPECIAL; Cnil->s.s_name = make_simple_string("NIL"); Cnil->s.s_gfdef = OBJNULL; Cnil->s.s_plist = Cnil; Cnil->s.s_hpack = Cnil; Cnil->s.s_stype = (short)stp_constant; Cnil->s.s_mflag = FALSE; Cnil->s.s_hash = ihash_equal1(Cnil,0); Ct->fw=0; set_type_of(Ct,t_symbol); Ct->s.s_dbind = Ct; Ct->s.tt=1; Ct->s.s_sfdef = NOT_SPECIAL; Ct->s.s_name = make_simple_string("T"); Ct->s.s_gfdef = OBJNULL; Ct->s.s_plist = Cnil; Ct->s.s_hpack = Cnil; Ct->s.s_stype = (short)stp_constant; Ct->s.s_mflag = FALSE; Ct->s.s_hash = ihash_equal1(Ct,0); 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(); init_boot(); 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 gcl_init_safety(); } 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, long code, void *scp, char *addr) { #if !defined(_WIN32) && !defined(__CYGWIN__) void *faddr; faddr=GET_FAULT_ADDR(sig,code,scp,addr); if ((cstack_dir==-1 && faddr < (void *)cs_limit && (void *)cs_limit-faddr <= PAGESIZE) || (cstack_dir==1 && faddr > (void *)cs_limit && faddr-(void *)cs_limit <= PAGESIZE)) FEerror("Control stack overflow.",0); /*FIXME -- provide getrlimit here.*/ else printf("Segmentation violation: c stack ok:signalling error"); #endif error("Segmentation violation."); } DEFUN("BYE",object,fSbye,SI,0,1,NONE,OI,OO,OO,OO,(fixnum exit_code,...),"") { if (!INIT_NARGS(0)) exit_code=0; #ifdef UNIX exit(exit_code); #else RETURN(1,int,exit_code, 0); #endif } DEFUN("QUIT",object,fSquit,SI,0,1,NONE,OI,OO,OO,OO,(fixnum exitc),"") { return FFN(fSbye)(exitc); } 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 (VLEN(vs_base[0]) >= 256) FEerror("Too long name: ~S.", 1, vs_base[0]); for (i = 0; i < VLEN(vs_base[0]); i++) name[i] = vs_base[0]->st.st_self[i]; name[i] = '\0'; if ((value = getenv(name)) != NULL) { #ifdef _WIN32 fix_filename(NULL, value); #endif 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; } DEFUN("CATCH-FATAL",object,fScatch_fatal,SI,1,1,NONE,OI,OO,OO,OO,(fixnum i),"") { catch_fatal=i; return Cnil; } DEFUN("RESET-STACK-LIMITS",object,fSreset_stack_limits,SI,0,1,NONE,OO,OO,OO,OO,(object cs_org_reset,...),"") { if (!INIT_NARGS(0)) cs_org_reset=Cnil; 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_org_reset!=Cnil) { cs_org=alloca(1); #ifdef __ia64__ { extern void * GC_save_regs_in_stack(); cs_org2=GC_save_regs_in_stack(); } #endif /* reset_cstack_limit(i); */ } RETURN1(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); massert(!((vs+bd+frs+ihs)%sizeof(fixnum))); stack_space=fSmake_vector(make_fixnum(aet_fix),(vs+bd+frs+ihs)/sizeof(fixnum),Cnil,Cnil,Cnil,0,Ct,OBJNULL); p=stack_space->v.v_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; vs_top=vs_base+1; } static void FFN(siLuser_init)(void) { check_arg(0); sLApackageA->s.s_dbind = user_package; user_init(); vs_base[0] = Cnil; } DEFUN("NANI",object,fSnani,SI,1,1,NONE,OI,OO,OO,OO,(fixnum address),"") { RETURN1((object)address); } DEFUN("ADDRESS",object,fSaddress,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1(x); } static void FFN(siLinitialization_failure)(void) { check_arg(0); printf("lisp initialization failed\n"); do_gcl_abort(); } DEFUN("IDENTITY",object,fLidentity,LISP,1,1,NONE,OO,OO,OO,OO,(object x0),"") { RETURN1 (x0); } DEFUN("LISP-IMPLEMENTATION-VERSION",object,fLlisp_implementation_version,LISP,0,0,NONE,OO,OO,OO,OO,(void),"") { 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,Cnil,""); 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_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("INIT-SYSTEM", siLinit_system); make_si_function("USER-INIT", siLuser_init); 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 #if defined ( DARWIN ) ADD_FEATURE("DARWIN"); #endif #if defined ( _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 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 #ifndef NO_C99 ADD_FEATURE("C99"); #endif #ifdef STATIC_LINKING ADD_FEATURE("STATIC"); #endif #if SIZEOF_LONG==8 ADD_FEATURE("64BIT"); #endif ADD_FEATURE("INTDIV"); ADD_FEATURE("DYNAMIC-EXTENT"); #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); */ } #if defined(HAVE_DIS_ASM_H) && defined(OUTPUT_ARCH) #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("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 defined(OUTPUT_MACH) i.mach=OUTPUT_MACH; #endif 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("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_function),{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->fun.fun_self)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(sSdefmacro_lambda, 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); } { top[0]=fSfset_in(Cnil,top[0],name);/*FIXME fSfset ?*/ } /* { */ /* object x=alloc_object(t_ifun); */ /* x->ifn.ifn_self=top[0]; */ /* x->ifn.ifn_name=x->ifn.ifn_call=Cnil; */ /* top[0]=x; */ /* } */ clear_compiler_properties(name,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 = 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) { /* pp(form->c.c_car);printf("\n"); */ object b[3]={exp_fun,form,MACRO_EXPAND_ENV}; fcall.valp=0; return funcall_vec(coerce_funcall_object_to_function(sLAmacroexpand_hookA->s.s_dbind),3,b); } /* 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. */ object macro_def_int(object sym) { object fd; if (type_of(sym) != t_symbol) return(Cnil); fd = lex_fd_sch(sym); if (MMnull(fd)) if (sym->s.s_mflag) return(sym->s.s_gfdef); else return(Cnil); else if (MMcadr(fd) == sSmacro) return(MMcaddr(fd)); else return(Cnil); } static object macro_def(object form) { if (!consp(form)) return(Cnil); return macro_def_int(MMcar(form)); } DEFUNM("MACROEXPAND",object,fLmacroexpand,LISP,1,2,NONE,OO,OO,OO,OO,(object form,...),"") { object envir; object exp_fun,l=Cnil,f=OBJNULL; object *lex=lex_env; object buf[3]; va_list ap; fixnum n=INIT_NARGS(1); fixnum vals=(fixnum)fcall.valp; object *base=vs_top; va_start(ap,form); envir=NEXT_ARG(n,ap,l,f,Cnil); va_end(ap); lex_env = buf; buf[0]=car(envir); envir=Mcdr(envir); buf[1]=car(envir); envir=Mcdr(envir); buf[2]=car(envir); 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 (!consp(form)) 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 (!consp(form)) 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,""); */ DEF_ORDINARY("DEFMACRO-LAMBDA",sSdefmacro_lambda,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.7.1/o/PaxHeaders/sfaslcoff.c0000644000000000000000000000013214776006046013726 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.302035078 30 ctime=1744351535.594908214 gcl-2.7.1/o/sfaslcoff.c0000644000175000017500000002434714776006046013336 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #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); else bzero((void *)memory->cfd.cfd_start+sec->s_paddr,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 if(symbol_value(sLAload_verboseA)!=Cnil) { printf("start address -T %p ", memory->cfd.cfd_start); fflush(stdout); } call_init(init_address,memory,faslfile); return(memory->cfd.cfd_size); } #include "sfasli.c" gcl-2.7.1/o/PaxHeaders/reference.c0000644000000000000000000000013214555557372013726 xustar0030 mtime=1706483450.804392729 30 atime=1744340055.684934165 30 ctime=1744351535.458909434 gcl-2.7.1/o/reference.c0000644000175000017500000001667314555557372013341 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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" /* DEFUN("TP0",fixnum,fStp0,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp0(x);} */ /* DEFUN("TP1",fixnum,fStp1,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp1(x);} */ /* DEFUN("TP2",fixnum,fStp2,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp2(x);} */ /* DEFUN("TP3",fixnum,fStp3,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp3(x);} */ /* DEFUN("TP4",fixnum,fStp4,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp4(x);} */ /* DEFUN("TP5",fixnum,fStp5,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp5(x);} */ /* DEFUN("TP6",fixnum,fStp6,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp6(x);} */ /* DEFUN("TP7",fixnum,fStp7,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp7(x);} */ /* DEFUN("TP8",fixnum,fStp8,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return tp8(x);} */ /* DEFUN("TT3",fixnum,fStt3,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { */ /* return fto(x); */ /* } */ /* DEFUN("TT30",object,fStt30,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { */ /* return fto0(x)?Cnil:Ct; */ /* } */ DEFUN("CFUN-CALL",object,fScfun_call,SI,1,1,NONE,OO,OO,OO,OO,(object fun),"") { if (!functionp(fun)) TYPE_ERROR(fun,sLfunction); RETURN1(fun->fun.fun_plist); } DEFUN("SET-CFUN-CALL",object,fSset_cfun_call,SI,2,2,NONE,OO,OO,OO,OO,(object call,object fun),"") { if (!functionp(fun)) TYPE_ERROR(fun,sLfunction); RETURN1(fun->fun.fun_plist=call); } DEFUN("FBOUNDP-SYM",object,fSfboundp_sym,SI,1,1,NONE,OO,OO,OO,OO,(object sym),"") { if (type_of(sym) != t_symbol) { not_a_symbol(sym); RETURN1(Cnil); } RETURN1(sym->s.s_sfdef!=NOT_SPECIAL || sym->s.s_gfdef!=OBJNULL ? Ct : Cnil); } /* DEFUN("FBOUNDP-CONS",object,fSfboundp_cons,SI,1,1,NONE,OO,OO,OO,OO,(object sym),"") { */ /* if (!setf_fn_form(sym)) { */ /* not_a_symbol(sym);/\*FIXME*\/ */ /* RETURN1(Cnil); */ /* } */ /* RETURN1(get(MMcadr(sym),sSsetf_function,Cnil)==Cnil ? Cnil : Ct); */ /* } */ DEFUN("FBOUNDP",object,fLfboundp,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { if (type_of(sym) != t_symbol) sym=ifuncall1(sSfunid_to_sym,sym); RETURN1(FFN(fSfboundp_sym)(sym)); /* else */ /* RETURN1(FFN(fSfboundp_cons)(sym)); */ } /* FIXME find out where this is called and if it needs to handle setf functions */ 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. */ static object symbol_function_internal(object sym,int allow_setf) { if (allow_setf && type_of(sym)!=t_symbol) sym=ifuncall1(sSfunid_to_sym,sym); if (type_of(sym)!=t_symbol) { not_a_symbol(sym); return Cnil; } if (sym->s.s_sfdef != NOT_SPECIAL) return make_cons(sLspecial,make_fixnum((long)(sym->s.s_sfdef))); if (sym->s.s_gfdef==OBJNULL) FEundefined_function(sym); if (sym->s.s_mflag) return make_cons(sSmacro,sym->s.s_gfdef); return sym->s.s_gfdef; } DEFUN("SYMBOL-FUNCTION",object,fLsymbol_function,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { RETURN1(symbol_function_internal(sym,0)); } /* FIXME add setf expander for fdefinition */ DEFUN("FDEFINITION",object,fLfdefinition,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { RETURN1(symbol_function_internal(sym,1)); } 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); AGAIN: 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 (consp(fun) && 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]); { vs_base[0]=fSfset_in(Cnil,vs_base[0],Cnil); } /* { */ /* object x=alloc_object(t_ifun); */ /* x->ifn.ifn_self=vs_base[0]; */ /* x->ifn.ifn_name=x->ifn.ifn_call=Cnil; */ /* vs_base[0]=x; */ /* } */ } else { fun=ifuncall1(sSfunid_to_sym,fun); /* if (fun==Cnil) */ /* FEundefined_function(sff); */ goto AGAIN; } } DEFUN("SYMBOL-VALUE",object,fLsymbol_value,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_dbind == OBJNULL) FEunbound_variable(sym); else RETURN1(sym->s.s_dbind); RETURN1(Cnil); } DEFUN("BOUNDP",object,fLboundp,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { if (type_of(sym) != t_symbol) not_a_symbol(sym); RETURN1(sym->s.s_dbind == OBJNULL ? Cnil : Ct); } /* DEFUN("MACRO-FUNCTION",object,fLmacro_function,SI,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { */ /* object */ LFD(Lmacro_function)(void) { object envir; object *lex=lex_env; object buf[3]; int n; n=vs_top-vs_base; if (n== 1) { buf[0]=sLnil; buf[1]=sLnil; buf[2]=sLnil; } else if (n==2) { envir=vs_base[1]; buf[0]=car(envir); envir=Mcdr(envir); buf[1]=car(envir); envir=Mcdr(envir); buf[2]=car(envir); } else check_arg_range(n,1,2); lex_env = buf; if (type_of(vs_base[0]) != t_symbol) not_a_symbol(vs_base[0]); vs_base[0]=macro_def_int(vs_base[0]); vs_top=vs_base+1; lex_env = lex; } 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; } DEFUN("LEXICAL-BINDING-ENVIRONMENT",object,fSlexical_binding_environment,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { RETURN1(list(3,lex_env[0],lex_env[1],lex_env[2])); } DEFUN("LEX-ENV",object,fSlex_env,SI,0,0,NONE,OI,OO,OO,OO,(fixnum i),"") { RETURN1(i>=0 && i<=3 ? lex_env[i] : Cnil); } void gcl_init_reference(void) { sLquote=make_special_form("QUOTE", Fquote); sLfunction = make_special_form("FUNCTION", Ffunction); make_function("MACRO-FUNCTION", Lmacro_function); make_function("SPECIAL-OPERATOR-P", Lspecial_operator_p); } gcl-2.7.1/o/PaxHeaders/bcopy.c0000644000000000000000000000013214542551763013076 xustar0030 mtime=1703597043.284022871 30 atime=1744340055.728934445 30 ctime=1744351535.486909183 gcl-2.7.1/o/bcopy.c0000755000175000017500000000022414542551763012475 0ustar00cammcamm#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.7.1/o/PaxHeaders/utils.c0000644000000000000000000000013214555557372013130 xustar0030 mtime=1706483450.808392729 30 atime=1744339828.343497087 30 ctime=1744351535.482909218 gcl-2.7.1/o/utils.c0000644000175000017500000000214014555557372012523 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #include #include "include.h" /* The functions IisProp check the property holds, and return the argument. They may in future allow resetting the argument. */ /* object CEerror(char *error_str, char *cont_str, int num, object arg1, */ /* object arg2, object arg3, object arg4); */ object IisSymbol(object f) { if (type_of(f) != t_symbol) FEwrong_type_argument(sLsymbol, 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)| TS(t_simple_array)|TS(t_simple_vector)|TS(t_simple_bitvector)|TS(t_simple_string))) FEwrong_type_argument(sLarray, f); return f; } object Iis_fixnum(object f) { if (type_of(f) != t_fixnum) FEwrong_type_argument(sLfixnum, f); return f; } char *lisp_copy_to_null_terminated(object string, char *buf, int n) { string=coerce_to_string(string); if (VLEN(string) + 1 > n) { buf = (void *) malloc(VLEN(string) + 1); } bcopy(string->st.st_self, buf, VLEN(string)); buf[VLEN(string)] = 0; return buf; } gcl-2.7.1/o/PaxHeaders/ntheap.h0000644000000000000000000000013114542551763013245 xustar0030 mtime=1703597043.320022928 30 atime=1744295002.865974894 29 ctime=1744351535.52290886 gcl-2.7.1/o/ntheap.h0000755000175000017500000000747614542551763012665 0ustar00cammcamm/* 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.7.1/o/PaxHeaders/cmpaux.c0000644000000000000000000000013214776006046013255 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.298035059 30 ctime=1744351535.462909398 gcl-2.7.1/o/cmpaux.c0000644000175000017500000003510114776006046012653 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 #define NEED_MP_H #include "include.h" #define dcheck_type(a,b) check_type(a,b) #include "page.h" DEFUN("SPECIALP",object,fSspecialp,SI,1,1,NONE,OO,OO,OO,OO,(object sym),"") { RETURN1((type_of(sym) == t_symbol && (enum stype)sym->s.s_stype == stp_special) ? Ct : Cnil); } DEFUN("BIG-TO-DOUBLE",object,fSbig_to_double,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (type_of(x)!=t_bignum) TYPE_ERROR(x,sLbignum); RETURN1(make_longfloat(big_to_double(x))); } DEFUN("LONG-TO-SHORT",object,fSlong_to_short,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (type_of(x)!=t_longfloat) TYPE_ERROR(x,sLlong_float); RETURN1(make_shortfloat((float)lf(x))); } DEFUN("COMPLEX-REAL",object,fScomplex_real,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (type_of(x)!=t_complex) TYPE_ERROR(x,sLcomplex); RETURN1(x->cmp.cmp_real); } DEFUN("COMPLEX-IMAG",object,fScomplex_imag,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (type_of(x)!=t_complex) TYPE_ERROR(x,sLcomplex); RETURN1(x->cmp.cmp_imag); } DEFUN("RATIO-NUMERATOR",object,fSratio_numerator,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (type_of(x)!=t_ratio) TYPE_ERROR(x,sLratio); RETURN1(x->rat.rat_num); } DEFUN("RATIO-DENOMINATOR",object,fSratio_denominator,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (type_of(x)!=t_ratio) TYPE_ERROR(x,sLratio); RETURN1(x->rat.rat_den); } DEFUN("C-TYPE",object,fSc_type,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(make_fixnum(type_of(x))); } DEFCONST("C-TYPE-MAX", sSc_type_max,SI,make_fixnum(t_end-1),""); DEF_ORDINARY("DEBUGGER",sSdebugger,SI,""); DEFUN("DEFVAR1",object,fSdefvar1,SI ,2,3,NONE,OO,OO,OO,OO,(object sym,object val,...),"") { object doc,l=Cnil,f=OBJNULL; va_list ap; fixnum n=INIT_NARGS(2); va_start(ap,val); doc=NEXT_ARG(n,ap,l,f,Cnil); va_end(ap); if (sym->s.s_dbind==OBJNULL && 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("DEBUGGER",object,fSdebugger,SI ,2,2,NONE,OO,OO,OO,OO,(object sym,object val),"") { /* 2 args */ putprop(sym,val,sSdebugger); RETURN1(sym); } DEFUN("SETVV",object,fSsetvv,SI,2,2,NONE,OO,OO,OO,OO,(object index,object val),"") { 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); } DEFVAR("%MEMORY",sSPmemory,SI,OBJNULL,""); DEFVAR("%INIT",sSPinit,SI,OBJNULL,""); /* 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 */ dcomplex object_to_dcomplex(object x) { dcomplex d=0; switch(type_of(x)) { case t_fixnum: d=fix(x); break; case t_bignum: d=mpz_get_si(MP(x)); break; case t_character: d=char_code(x); break; case t_ratio: d=number_to_double(x); break; case t_shortfloat: d=sf(x); break; case t_longfloat: d=lf(x); break; case t_complex: d=(double)object_to_dcomplex(x->cmp.cmp_real)+I*(double)object_to_dcomplex(x->cmp.cmp_imag); break; default: FEcannot_coerce(sLfloat,x); break; } return d; } void * object_to_pointer(object x) { void *d=0; switch(type_of(x)) { case t_simple_vector: case t_simple_bitvector: case t_vector: case t_bitvector: case t_symbol: case t_simple_string: case t_string: case t_array: case t_character: d=x->v.v_self; break; default: FEcannot_coerce(sLfloat,x); break; } return d; } char object_to_char(object x) { int c=0; switch (type_of(x)) { case t_fixnum: c = fix(x); break; case t_bignum: { fixnum fx; fx=mpz_get_si(MP(x)); c=fx&0xff; 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 = mpz_get_si(MP(x)); break; 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: FEcannot_coerce(sLinteger,x); } return(i); } fixnum object_to_long(object x) {return object_to_fixnum(x);} fixnum object_to_short(object x) {return object_to_fixnum(x);} 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); } object make_fcomplex(fcomplex x) { return make_complex(make_shortfloat(creal(x)),make_shortfloat(cimag(x))); } fcomplex object_to_fcomplex(object x) { fcomplex 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; case t_complex: f = object_to_float(x->cmp.cmp_real)+object_to_float(x->cmp.cmp_imag)*I; break; default: FEcannot_coerce(sLfloat,x); } return(f); } object make_dcomplex(dcomplex x) { return make_complex(make_longfloat(creal(x)),make_longfloat(cimag(x))); } dcomplex object_to_dcomplex1(object x) { dcomplex 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; case t_complex: f = object_to_double(x->cmp.cmp_real)+I*object_to_double(x->cmp.cmp_imag); break; default: FEcannot_coerce(sLfloat,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 (!stringp(x)) FEwrong_type_argument(sLstring,x);/*FIXME check_type*/ leng= VLEN(x); /* 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; } 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. */ static int set_min_cfd_self=0; 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->sv.sv_self; n=fix(fd->table_length); fd->table->sv.sv_self=alloca(n*sizeof(object)); memset(fd->table->sv.sv_self,0,n*sizeof(object)); fd->table->sv.sv_dim=faslfile->sv.sv_self[1]->sv.sv_dim=n; } n=fix(READ_STREAM_OR_FASD(faslfile)); sSPinit->s.s_dbind=fasl_vec=fSmake_vector(Ct,n,Ct,Cnil,Cnil,0,Cnil,Cnil); /* switch SPinit to point to a vector of function addresses */ set_array_elttype(fasl_vec,aet_fix); /* swap the entries */ for (i=0,p=fasl_vec->v.v_self,q=statVV;icfd.cfd_self = statVV; if (set_min_cfd_self && (!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("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; memory->cfd.cfd_dlist=Cnil; memory->cfd.cfd_name=Cnil; return memory; } void gcl_init_or_load1(void (*fn)(void),const char *file) { if (file[strlen(file)-1]=='o') { object memory; object faslfile; object lpn,ltn; printf("Initializing %s\n",file);fflush(stdout); lpn=make_simple_string(file); massert(realpath(file,FN1)); ltn=make_simple_string(FN1); memory=new_cfdata(); memory->cfd.cfd_name=ltn; memory->cfd.cfd_start=(char *)fn; faslfile=open_stream(ltn,smm_input,Cnil,sKerror); SEEK_TO_END_OFILE(faslfile->sm.sm_fp); set_min_cfd_self=1; bds_bind(sLAload_pathnameA,lpn); bds_bind(sLAload_truenameA,ltn); call_init(0,memory,faslfile); bds_unwind1; bds_unwind1; set_min_cfd_self=0; close_stream(faslfile); } else { printf("loading %s\n",file); fflush(stdout); load(file); } } 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 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("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("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.7.1/o/PaxHeaders/num_co.c0000644000000000000000000000013114723146010013223 xustar0030 mtime=1733086216.524025797 29 atime=1744339820.31944698 30 ctime=1744351535.466909362 gcl-2.7.1/o/num_co.c0000644000175000017500000004150714723146010012631 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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; #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; } } DEFUN("ISFINITE",object,fSisfinite,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { switch (type_of(x)) { case t_longfloat: return lf(x)==0.0 || ISFINITE(lf(x)) ? Ct : Cnil; break; case t_shortfloat: return sf(x)==0.0 || ISFINITE(sf(x)) ? Ct : Cnil; break; default: return Cnil; break; } return Cnil; } DEFUN("ISNORMAL",object,fSisnormal,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { switch (type_of(x)) { case t_longfloat: return ISNORMAL(lf(x)) ? Ct : Cnil; case t_shortfloat: return ISNORMAL(sf(x)) ? Ct : Cnil; default: return Cnil; } } 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); } object double_to_rational(double d) { object x; int h,l,e,s; integer_decode_double(d,&h,&l,&e,&s); x=number_times((h!=0 || l<0) ? bignum2(h,l) : make_fixnum(l), number_expt(make_fixnum(2),make_fixnum(e))); if (s<0) x=number_negate(x); return x; } static void integer_decode_float(float f, int *mp, int *ep, int *sp) { int m; union {float f;int i;} u; 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); } inline 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) DIVISION_BY_ZERO(sLtruncate,list(2,x,y)); 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; } DEFUN("INTDIVREM",object,fSintdivrem,SI,3,3,NONE,OO,OI,OO,OO,(object x,object y,fixnum d),"") { intdivrem(x,y,d,&x,&y); RETURN1(MMcons(x,y)); } object number_ldb(object x,object y) { object (*foo)(object,object)=(void *)sLldb->s.s_gfdef->fun.fun_self; return foo(x,y); } object number_ldbt(object x,object y) { object (*foo)(object,object)=(void *)sLldb_test->s.s_gfdef->fun.fun_self; return foo(x,y); } object number_dpb(object x,object y,object z) { object (*foo)(object,object,object)=(void *)sLdpb->s.s_gfdef->fun.fun_self; return foo(x,y,z); } object number_dpf(object x,object y,object z) { object (*foo)(object,object,object)=(void *)sLdeposit_field->s.s_gfdef->fun.fun_self; return foo(x,y,z); } DEFUNM("FLOOR",object,fLfloor,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { fixnum nargs=INIT_NARGS(1); object f=OBJNULL,l=Cnil,y; fixnum vals=(fixnum)fcall.valp; object *base=vs_top; va_list ap; va_start(ap,x); y=NEXT_ARG(nargs,ap,l,f,make_fixnum(1)); va_end(ap); intdivrem(x,y,-1,&x,&y); RETURN2(x,y); } DEFUNM("CEILING",object,fLceiling,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { fixnum nargs=INIT_NARGS(1); object f=OBJNULL,l=Cnil,y; fixnum vals=(fixnum)fcall.valp; object *base=vs_top; va_list ap; va_start(ap,x); y=NEXT_ARG(nargs,ap,l,f,make_fixnum(1)); va_end(ap); intdivrem(x,y,1,&x,&y); RETURN2(x,y); } DEFUNM("TRUNCATE",object,fLtruncate,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { fixnum nargs=INIT_NARGS(1); object f=OBJNULL,l=Cnil,y; fixnum vals=(fixnum)fcall.valp; object *base=vs_top; va_list ap; va_start(ap,x); y=NEXT_ARG(nargs,ap,l,f,make_fixnum(1)); va_end(ap); intdivrem(x,y,0,&x,&y); RETURN2(x,y); } DEFUNM("ROUND",object,fLround,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { fixnum nargs=INIT_NARGS(1); object f=OBJNULL,l=Cnil,y,q,q1,r; fixnum vals=(fixnum)fcall.valp; object *base=vs_top; double d; int c; enum type tp; va_list ap; va_start(ap,x); y=NEXT_ARG(nargs,ap,l,f,make_fixnum(1)); va_end(ap); check_type_or_rational_float(&x); check_type_or_rational_float(&y); q = eql(y,small_fixnum(1)) ? x : number_divide(x, y); switch ((tp=type_of(q))) { case t_fixnum: case t_bignum: RETURN2(q,small_fixnum(0)); case t_ratio: q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den,0);/*FIXME*/ r = number_minus(q, q1); 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); RETURN2(q1,num_remainder(x, y, q1)); case t_shortfloat: case t_longfloat: d = number_to_double(q); q1 = double_to_integer(d + (d >= 0.0 ? 0.5 : -0.5)); d -= number_to_double(q1); if (d == 0.5 && number_oddp(q1)) { q1 = one_plus(q1); d=-0.5; } if (d == -0.5 && number_oddp(q1)) { q1 = one_minus(q1); d=+0.5; } RETURN2(q1,tp==t_shortfloat ? make_shortfloat((shortfloat)d) : make_longfloat(d)); default: TYPE_ERROR(q,sLreal); } } DEFUN("MOD",object,fLmod,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { intdivrem(x,y,-1,NULL,&y); RETURN1(y); } DEFUN("REM",object,fLrem,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { intdivrem(x,y,0,NULL,&y); RETURN1(y); } DEFUNM("DECODE-FLOAT",object,fLdecode_float,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { int e,s; fixnum vals=(fixnum)fcall.valp; double d; object *base=vs_top; check_type_float(&x); 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); RETURN3(type_of(x) == t_shortfloat ? make_shortfloat((shortfloat)d) : make_longfloat(d), make_fixnum(e), type_of(x) == t_shortfloat ? make_shortfloat((shortfloat)s) : make_longfloat((double)s)); } DEFUN("SCALE-FLOAT",object,fLscale_float,LISP,2,2,NONE,OO,IO,OO,OO,(object x,fixnum k),"") { double d; int e; if (type_of(x) == t_shortfloat) d = sf(x); else d = lf(x); e = double_exponent(d) + k; /* 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 */))) { for (;k>0;d*=2.0,k--); for (;k<0;d*=0.5,k++); } else d = set_exponent(d, e); RETURN1(type_of(x) == t_shortfloat ? make_shortfloat((shortfloat)d) : make_longfloat(d)); } DEFUNM("INTEGER-DECODE-FLOAT",object,fLinteger_decode_float,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { int h,l,e,s; fixnum vals=(fixnum)fcall.valp; object *base=vs_top; check_type_float(&x); h=0; if (type_of(x) == t_longfloat) integer_decode_double(lf(x), &h, &l, &e, &s); else integer_decode_float(sf(x), &l, &e, &s); RETURN3((h || l<0) ? bignum2(h, l) : make_fixnum(l),make_fixnum(e),make_fixnum(s)); } 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; uf.i=1; u.i[HIND]=0; u.i[LIND]=1; smallest_float=uf.f; smallest_double=u.d; uf.i=0x7f7fffff; u.i[HIND]=0x7fefffff; u.i[LIND]=0xffffffff; biggest_float=uf.f; biggest_double=u.d; biggest_double = DBL_MAX; smallest_norm_double = DBL_MIN; smallest_norm_float = FLT_MIN; biggest_float = FLT_MAX; { 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;i #include "include.h" object sKstart1; object sKend1; object sKstart2; object sKend2; object sKinitial_element; object sKelement_type; object alloc_string(fixnum l) {/*FIXME consolidate these through fSmake_vector*/ object x; if (l<0 || l>=ARRAY_DIMENSION_LIMIT) TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil))); x = alloc_object(t_string); x->st.st_hasfillp = TRUE; x->st.st_adjustable = TRUE; set_array_elttype(x,aet_ch); x->st.st_rank = 1; x->st.st_displaced=Cnil; x->st.st_dim = l; x->st.st_fillp = l; x->st.st_self = NULL; return(x); } object alloc_simple_string(fixnum l) { object x; if (l<0 || l>=ARRAY_DIMENSION_LIMIT) TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil))); x = alloc_object(t_simple_string); x->sst.sst_hasfillp = FALSE; x->sst.sst_adjustable = FALSE; set_array_elttype(x,aet_ch); x->sst.sst_rank = 1; x->sst.sst_dim = l; x->sst.sst_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); } object make_string(s) char *s; { int l, i; char *p; object x; vs_mark; {BEGIN_NO_INTERRUPT; for (l = 0; s[l] != '\0'; l++) ; x = alloc_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 (!stringp(x) || !stringp(y)) error("string expected"); i = VLEN(x); j = VLEN(y); 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 = VLEN(x); j = VLEN(y); 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); {BEGIN_NO_INTERRUPT; y = alloc_object(t_simple_string); y->st.st_hasfillp = FALSE; y->st.st_adjustable = FALSE; y->st.st_dim = VLEN(x); set_array_elttype(y,aet_ch); y->st.st_rank = 1; y->st.st_self = NULL; vs_push(y); y->st.st_self = alloc_relblock(VLEN(x)); for (i = 0; i < VLEN(x); i++) y->st.st_self[i] = x->st.st_self[i]; vs_reset; END_NO_INTERRUPT;} return(y); } object copy_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_hasfillp = TRUE; y->st.st_adjustable = TRUE; y->st.st_dim = VLEN(x); VSET_MAX_FILLP(y); set_array_elttype(y,aet_ch); /* y->st.st_eltsize = elt_size(aet_ch); */ y->st.st_rank = 1; SET_ADISP(y,Cnil); y->st.st_self = NULL; vs_push(y); y->st.st_self = alloc_relblock(VLEN(x)); for (i = 0; i < VLEN(x); 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; vs_mark; switch (type_of(x)) { case t_symbol: return(x->s.s_name); 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_simple_string: case t_string: return(x); default: break; } vs_push(x); x=wrong_type_argument(sLstring,x); vs_popp; return(Cnil); } void get_string_start_end(str, start, end, ps, pe) object str, 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 = VLEN(str); if (*pe < *ps) goto E; } else if (type_of(end) != t_fixnum) goto E; else { *pe = fix(end); if (*pe < *ps || *pe > VLEN(str)) goto E; } return; E: FEerror("~S and ~S are illegal as :START and :END~%\ for the str ~S.", 3, start, end, str); } @(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_simple_vector: case t_vector: for (i = 0, f = VLEN(char_bag); 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_simple_string: case t_string: for (i = 0, f = VLEN(char_bag); i < f; i++) { if (c == char_bag->st.st_self[i]) return(TRUE); } return(FALSE); case t_simple_bitvector: 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 = VLEN(strng) - 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("STRING-CONCATENATE",object,fLstring_concatenate,SI,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { fixnum i,l,m,narg=INIT_NARGS(0); object x,ll=Cnil,z; va_list ap; va_start(ap,first); vs_base=vs_top; for (l=i=0;(z=NEXT_ARG(narg,ap,ll,first,OBJNULL))!=OBJNULL;i++) { vs_push(coerce_to_string(z)); l += VLEN(vs_head); } 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;p=0;p++,l+=m) memcpy(x->st.st_self+l,(*p)->st.st_self,m); END_NO_INTERRUPT; } RETURN1(x); } /* static void */ /* FFN(siLstring_concatenate)() */ /* { */ /* int narg, i, l, m; */ /* object *v; */ /* narg = vs_top - vs_base; */ /* for (i = 0, l = 0; i < narg; i++) { */ /* vs_base[i] = coerce_to_string(vs_base[i]); */ /* l += vs_base[i]->st.st_fillp; */ /* } */ /* v = vs_top; */ /* {BEGIN_NO_INTERRUPT; */ /* vs_push(alloc_simple_string(l)); */ /* (*v)->st.st_self = alloc_relblock(l); */ /* for (i = 0, l = 0; i < narg; i++) */ /* for (m = 0; m < vs_base[i]->st.st_fillp; m++) */ /* (*v)->st.st_self[l++] */ /* = vs_base[i]->st.st_self[m]; */ /* vs_base[0] = *v; */ /* vs_top = vs_base + 1; */ /* END_NO_INTERRUPT;} */ /* } */ 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("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.7.1/o/PaxHeaders/gmp_num_log.c0000644000000000000000000000013114555557372014272 xustar0029 mtime=1706483450.80039273 30 atime=1744339820.799449976 30 ctime=1744351535.582908322 gcl-2.7.1/o/gmp_num_log.c0000644000175000017500000000443614555557372013700 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ /* 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 int big_bitp(object x, ufixnum p) { return mpz_tstbit(MP(x),p); } static int mpz_bitcount(__mpz_struct *x) { if (mpz_sgn(x) >= 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.7.1/o/PaxHeaders/usig2.c0000644000000000000000000000013214776006046013011 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.306035098 30 ctime=1744351535.482909218 gcl-2.7.1/o/usig2.c0000644000175000017500000002643114776006046012415 0ustar00cammcamm/* Copyright (C) 1994 W. Schelter Copyright (C) 2024 Camm Maguire 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.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[t_end]; object free2[t_end]; object altfree1[t_end]; object altfree2[t_end]; union lispunion buf[t_end]; 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; safety_required[SIGUSR1]=sig_normal; } DEFUN("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 main_signal_handler(int signo,siginfo_t *a,void *b) { 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,0,0); 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) { /* all this must be run in no interrupts mode */ if ( allowed < sig_safe) { int i; /* save tht tops of the free stacks */ for (i=0;ifree1[i]=ad->tm_free)) { void *beg=p->free1[i]; object x=beg; int amt=ad->tm_size; memcpy(p->buf+i,beg,amt); bzero(beg+sizeof(struct freelist),amt-sizeof(struct freelist));/*FIXME t_free -> struct freelist **/ ad->tm_nfree--; make_unfree(x); if ((p->free2[i]=OBJ_LINK(p->free1[i]))) { beg=p->free2[i]; x=beg; bzero(beg+sizeof(struct freelist),amt-sizeof(struct freelist)); ad->tm_nfree--; make_unfree(x); ad->tm_free=OBJ_LINK(p->free2[i]); } else ad->tm_free=p->free2[i]; } } } p->fcall=fcall; p->vs_top=vs_top; p->vs_topVAL=*vs_top; p->vs_base=vs_base; p->bds_top=bds_top; p->bds_topVAL=*bds_top; p->ihs_top=ihs_top; 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); #include "usig2_aux.c" if (pp-p->save_objects>=(sizeof(p->save_objects)/sizeof(void *))) gcl_abort(); } p->token_st_dim=tok_leng+1; if (token->st.st_dimtoken_st_dim) p->token_st_dim=token->st.st_dim; if (p->token_st_dimtoken_buf)) p->token_bufp=p->token_buf; else p->token_bufp=(void *)ZALLOCA(p->token_st_dim); memcpy(p->token_bufp,token->st.st_self,p->token_st_dim); } static void after_interrupt(struct save_for_interrupt *p,int allowed) { /* all this must be run in no interrupts mode */ if ( allowed < sig_safe) { int i; for(i=0; i < t_end ; i++) { struct typemanager *ad = &tm_table[i]; object current_fl = ad->tm_free; if ((ad->tm_free=p->free1[i])) { void *beg=p->free1[i]; object x=beg; int amt=ad->tm_size; if (is_marked_or_free(x)) error("should not be free"); memcpy(beg,p->buf+i,amt); if ((p->free1[i]=p->free2[i])) { x=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; } } fcall=p->fcall; vs_top=p->vs_top; *vs_top=p->vs_topVAL; vs_base=p->vs_base; bds_top=p->bds_top; *bds_top=p->bds_topVAL; ihs_top=p->ihs_top; *ihs_top=p->ihs_topVAL; { void **pp=p->save_objects; #undef XS #undef XSI #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" } memcpy(token->st.st_self,p->token_bufp,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("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.7.1/o/PaxHeaders/gmp.c0000644000000000000000000000013114555557372012552 xustar0029 mtime=1706483450.80039273 30 atime=1744339817.891431827 30 ctime=1744351535.582908322 gcl-2.7.1/o/gmp.c0000644000175000017500000000122514555557372012151 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #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)) 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); return new; } static void gcl_gmp_free(void *old, size_t oldsize) { } gcl-2.7.1/o/PaxHeaders/cfun.c0000644000000000000000000000013214767050343012712 xustar0030 mtime=1742491875.172628319 30 atime=1744339817.211427584 30 ctime=1744351535.462909398 gcl-2.7.1/o/cfun.c0000644000175000017500000001411314767050343012310 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 */ #define _GNU_SOURCE 1 #include "include.h" #include #include "page.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) { 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 fSinit_function(list(6,Cnil,Cnil,make_fixnum((fixnum)self),Cnil,make_fixnum(0),name), feval_src,data,Cnil,-1,0,(((1<<6)-1)<<6)|(((1<<5)-1)<<12)|(1<<17)); } DEFUN("CFDL",object,fScfdl,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { struct typemanager *tm=tm_of(t_cfdata); int j; object x; void *p; struct pageinfo *v; for (v=cell_list_head;v;v=v->next) { if (tm!=tm_of(v->type)) continue; for (p=pagetochar(page(v)),j=tm->tm_nppage;j>0;--j,p+=tm->tm_size) { x=(object)p; if (type_of(x)!=t_cfdata || is_marked_or_free(x)) continue; for (x=x->cfd.cfd_dlist;x!=Cnil;x=x->c.c_cdr) { fixnum j=fix(x->c.c_car->c.c_cdr),k=fix(x->c.c_car->c.c_car->s.s_dbind); if (*(fixnum *)j!=k) *(fixnum *)j=k; } } } RETURN1(Cnil); } DEFUN("DLSYM",object,fSdlsym,SI,2,2,NONE,OI,OO,OO,OO,(fixnum h,object name),"") { void *ad; dlerror(); name=coerce_to_string(name); massert(snprintf(FN1,sizeof(FN1),"%-.*s",VLEN(name),name->st.st_self)>0); #ifndef __CYGWIN__ ad=dlsym(h ? (void *)h : RTLD_DEFAULT,FN1); ad=ad ? ad : dlsym(RTLD_DEFAULT,FN1); ad=is_text_addr(ad) ? dlsym(RTLD_NEXT,FN1) : ad; #else ad=0; if (h) ad=dlsym((void *)h,FN1); { static void *n,*u,*c; n=n ? n : dlopen("ntdll.dll",RTLD_LAZY|RTLD_GLOBAL); u=u ? u : dlopen("ucrtbase.dll",RTLD_LAZY|RTLD_GLOBAL); c=c ? c : dlopen("cygwin1.dll",RTLD_LAZY|RTLD_GLOBAL); ad=ad ? ad : dlsym(n,FN1); ad=ad ? ad : dlsym(u,FN1); ad=ad ? ad : dlsym(c,FN1); ad=ad ? ad : dlsym(RTLD_DEFAULT,FN1); } #endif if (!ad) { char *er=dlerror(); FEerror("dlsym lookup failure on ~s: ~s",2,name,make_simple_string(er ? er : "")); } RETURN1(make_fixnum((fixnum)ad)); } DEFUN("DLADDR",object,fSdladdr,SI,2,2,NONE,OI,OO,OO,OO,(fixnum ad,object n),"") { Dl_info info; unsigned long u; const char *c; char *d,*de; dlerror(); dladdr((void *)ad,&info); if (dlerror()) FEerror("dladdr lookup failure on ~s",1,make_fixnum(ad)); u=(unsigned long)info.dli_fbase; c=info.dli_fname; if (n!=Cnil) { d=alloca(strlen(c)+1); strcpy(d,c); for (de=d+strlen(d);de>d && de[-1]!='/';de--) if (*de=='.') *de=0; c=de; } if (u>=(ufixnum)data_start && u<(unsigned long)core_end) c=""; RETURN1(make_simple_string(c)); } DEFUN("DLOPEN",object,fSdlopen,SI,1,1,NONE,OO,OO,OO,OO,(object name),"") { char *err; void *v; dlerror(); name=coerce_to_string(name); if (!strncmp("libc.so",name->st.st_self,VLEN(name)) || !strncmp("libm.so",name->st.st_self,VLEN(name))) v=dlopen(0,RTLD_LAZY|RTLD_GLOBAL); else { massert(snprintf(FN1,sizeof(FN1),"%-.*s",VLEN(name),name->st.st_self)>0); v=dlopen(FN1,RTLD_LAZY|RTLD_GLOBAL); } if ((err=dlerror())) FEerror("dlopen failure on ~s: ~s",2,name,make_simple_string(err)); update_real_maxpage(); RETURN1(make_fixnum((fixnum)v)); } DEFUN("DLADDR-SET",object,fSdladdr_set,SI,2,2,NONE,OI,IO,OO,OO,(fixnum adp,fixnum ad),"") { *(void **)adp=(void *)ad; RETURN1(Cnil); } DEFUN("DLLIST-PUSH",object,fSdllist_push,SI,3,3,NONE,OO,OI,OO,OO,(object cfd,object sym,fixnum adp),"") { cfd->cfd.cfd_dlist=MMcons(MMcons(sym,make_fixnum(adp)),cfd->cfd.cfd_dlist); RETURN1(Cnil); } /* sym->s.s_sfdef = NOT_SPECIAL; */ object make_function_internal(char *s, void (*f)()) { object x; vs_mark; x = make_ordinary(s); if (x->s.s_gfdef!=OBJNULL) { printf("Skipping redefinition of %-.*s\n",(int)VLEN(x->s.s_name),x->s.s_name->st.st_self); return(x); } 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_function_internal(char *s, void (*f)()) { object x; vs_mark; x = make_si_ordinary(s); if (x->s.s_gfdef!=OBJNULL) { printf("Skipping redefinition of %-.*s\n",(int)VLEN(x->s.s_name),x->s.s_name->st.st_self); return(x); } 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 = (fixnum)f; return(x); } object make_si_special_form_internal(char *s,void *f) { object x; x = make_si_ordinary(s); x->s.s_sfdef = (fixnum)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("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_function: fun=Cnil; break; /* case t_cfun: */ /* fun = fun->cf.cf_name; */ /* break; */ default: FEerror("~S is not a compiled-function.", 1, fun); }RETURN1(fun); } void gcl_init_cfun(void) { } gcl-2.7.1/o/PaxHeaders/prelink.c0000644000000000000000000000013214555557372013434 xustar0030 mtime=1706483450.804392729 30 atime=1744339829.583504835 30 ctime=1744351535.486909183 gcl-2.7.1/o/prelink.c0000644000175000017500000000221414555557372013031 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #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.7.1/o/PaxHeaders/boot.c0000644000000000000000000000013214760704751012724 xustar0030 mtime=1740868073.407093905 30 atime=1744340056.168937254 30 ctime=1744351535.598908178 gcl-2.7.1/o/boot.c0000644000175000017500000005002414760704751012323 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #include "include.h" DEFUN("TP0",object,fStp0,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp0(x);} DEFUN("TP1",object,fStp1,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp1(x);} DEFUN("TP2",object,fStp2,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp2(x);} DEFUN("TP3",object,fStp3,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp3(x);} DEFUN("TP4",object,fStp4,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp4(x);} DEFUN("TP5",object,fStp5,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp5(x);} DEFUN("TP6",object,fStp6,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp6(x);} DEFUN("TP7",object,fStp7,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp7(x);} DEFUN("TP8",object,fStp8,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {return (object)(fixnum)tp8(x);} DEFUN("C-OBJECT-==",object,fSc_object_eq,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { RETURN1(x==y?Ct:Cnil); } DEFUN("C-FIXNUM-==",object,fSc_fixnum_eq,SI,2,2,NONE,OI,IO,OO,OO,(fixnum x,fixnum y),"") { RETURN1(x==y?Ct:Cnil); } DEFUN("C-FLOAT-==",object,fSc_float_eq,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type(x,t_shortfloat); check_type(y,t_shortfloat); RETURN1(sf(x)==sf(y)?Ct:Cnil); } DEFUN("C-DOUBLE-==",object,fSc_double_eq,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type(x,t_longfloat); check_type(y,t_longfloat); RETURN1(lf(x)==lf(y)?Ct:Cnil); } DEFUN("C-FCOMPLEX-==",object,fSc_fcomplex_eq,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type(x,t_complex); check_type(y,t_complex); check_type(x->cmp.cmp_real,t_shortfloat); check_type(y->cmp.cmp_real,t_shortfloat); RETURN1(sfc(x)==sfc(y)?Ct:Cnil); } DEFUN("C-DCOMPLEX-==",object,fSc_dcomplex_eq,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type(x,t_complex); check_type(y,t_complex); check_type(x->cmp.cmp_real,t_longfloat); check_type(y->cmp.cmp_real,t_longfloat); RETURN1(lfc(x)==lfc(y)?Ct:Cnil); } DEFUN("C+",object,fScp,SI,2,2,NONE,II,IO,OO,OO,(fixnum x,fixnum y),"") { RETURN1((object)(x+y)); } DEFUN("&",object,fSand,SI,2,2,NONE,II,IO,OO,OO,(fixnum x,fixnum y),"") { RETURN1((object)(x&y)); } DEFUN("|",object,fSor,SI,2,2,NONE,II,IO,OO,OO,(fixnum x,fixnum y),"") { RETURN1((object)(x|y)); } DEFUN("^",object,fSxor,SI,2,2,NONE,II,IO,OO,OO,(fixnum x,fixnum y),"") { RETURN1((object)(x^y)); } DEFUN("~",object,fSnot,SI,1,1,NONE,II,OO,OO,OO,(fixnum x),"") { RETURN1((object)~x); } DEFUN("<<",object,fSlshft,SI,2,2,NONE,II,IO,OO,OO,(fixnum x,fixnum y),"") { RETURN1((object)(x<>",object,fSrshft,SI,2,2,NONE,II,IO,OO,OO,(fixnum x,fixnum y),"") { RETURN1((object)(x>>y)); } static inline bool TESTA(object x_,object y_,object key,object test,object test_not) { object _y=key==Cnil ? y_ : ifuncall1(key,y_); if (test!=Cnil) return ifuncall2(test,x_,_y)!=Cnil; else if (test_not!=Cnil) return ifuncall2(test_not,x_,_y)==Cnil; else return eql(x_,_y); } #define MTEST(y_) TESTA(x,y_,key,test,test_not) #define DEFKTFUN(n_,s_,p_,code_) \ DEFUN(n_,object,s_,p_,2,63,NONE,OO,OO,OO,OO,(object x,object y,...),"") { \ \ fixnum n=INIT_NARGS(2); \ object l=Cnil,f=OBJNULL,*base=vs_top,z,key,test,test_not; \ va_list ap; \ va_start(ap,y); \ for (;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL;) \ vs_push(z); \ va_end(ap); \ \ parse_key(base,FALSE,FALSE,3,sKtest,sKtest_not,sKkey); \ key=base[2];test=base[0];test_not=base[1];vs_top=base; \ \ RETURN1(code_); \ \ } #define DEFPFUN(n_,s_,p_,test_,call_) \ DEFUN(n_,object,s_,p_,2,63,NONE,OO,OO,OO,OO,(object x,object y,...),"") { \ \ fixnum n=INIT_NARGS(2); \ object l=Cnil,f=OBJNULL,*base=vs_top,z; \ va_list ap; \ \ va_start(ap,y); \ for (;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL;) \ vs_push(z); \ va_end(ap); \ \ parse_key(base,FALSE,FALSE,1,sKkey); \ \ vs_top=base; \ RETURN1((VFUN_NARGS=6,FFN(call_)(x,y,test_,sLfuncall,sKkey,base[0]))); \ } #define DEFKTPFUN(n_,s_,p_,code_) \ DEFKTFUN(n_,s_,p_,code_)\ DEFPFUN(n_ "-IF",Mjoin(s_,_if),p_,sKtest,s_) \ DEFPFUN(n_ "-IF-NOT",Mjoin(s_,_if_not),p_,sKtest_not,s_) DEFKTPFUN("MEMBER",fLmember,LISP,({for (;!endp(y) && !MTEST(y->c.c_car);y=y->c.c_cdr);y;})) DEFKTFUN("ASSOC",fLassoc,LISP,({for (;!endp(y) && (y->c.c_car==Cnil || !MTEST(y->c.c_car->c.c_car));y=y->c.c_cdr);y->c.c_car;})) DEFKTFUN("RASSOC",fLrassoc,LISP,({for (;!endp(y) && (y->c.c_car==Cnil || !MTEST(y->c.c_car->c.c_cdr));y=y->c.c_cdr);y->c.c_car;})) DEFKTFUN("ADJOIN",fLadjoin,LISP, \ ({object z,q=x; \ x=base[2]==Cnil ? x : ifuncall1(base[2],x); \ for (z=y;!endp(z) && !MTEST(z->c.c_car);z=z->c.c_cdr); \ z==Cnil ? MMcons(q,y) : y;})) DEFUN("TAILP",object,fLtailp,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { for (;consp(y) && y!=x;y=y->c.c_cdr); RETURN1(eql(x,y) ? Ct : Cnil); } static inline object subst(object tree,object new,object x,object key,object test,object test_not) { if (TESTA(x,tree,key,test,test_not)) return new; else if (consp(tree)) { object a=subst(tree->c.c_car,new,x,key,test,test_not),d=subst(tree->c.c_cdr,new,x,key,test,test_not); return a==tree->c.c_car && d==tree->c.c_cdr ? tree : MMcons(a,d); } else return tree; } DEFUN("SUBST",object,fLsubst,LISP,3,63,NONE,OO,OO,OO,OO,(object new,object x,object y,...),"") { fixnum n=INIT_NARGS(3); object l=Cnil,f=OBJNULL,*base=vs_top,z,key,test,test_not; va_list ap; va_start(ap,y); for (;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL;) vs_push(z); va_end(ap); parse_key(base,FALSE,FALSE,3,sKtest,sKtest_not,sKkey); key=base[2];test=base[0];test_not=base[1];vs_top=base; RETURN1(subst(y,new,x,key,test,test_not)); } DEFUN("LDIFF",object,fLldiff,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { object first=Cnil,last=Cnil,z; if (!listp(x))/*FIXME checktype*/ TYPE_ERROR(x,sLlist); for (;consp(x) && x!=y;x=x->c.c_cdr) if (first==Cnil) first=last=MMcons(x->c.c_car,Cnil); else { last->c.c_cdr=(z=MMcons(x->c.c_car,Cnil)); last=z; } if (first!=Cnil) last->c.c_cdr=eql(x,y) ? Cnil : x; RETURN1(first); } DEFUN("SUBSETP",object,fLsubsetp,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { if (!listp(x))/*FIXME checktype*/ TYPE_ERROR(x,sLlist); if (!listp(y))/*FIXME checktype*/ TYPE_ERROR(y,sLlist); for (;consp(x);x=x->c.c_cdr) if (FFN(fLmember)(x->c.c_car,y)==Cnil) RETURN1(Cnil); RETURN1(Ct); } DEFUN("CAR",object,fLcar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_list(&x); RETURN1(x->c.c_car); } DEFUN("CDR",object,fLcdr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_list(&x); RETURN1(x->c.c_cdr); } DEFUN("CAAR",object,fLcaar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcar)(x))); } DEFUN("CADR",object,fLcadr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcdr)(x))); } DEFUN("CDAR",object,fLcdar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcar)(x))); } DEFUN("CDDR",object,fLcddr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcdr)(x))); } DEFUN("CAAAR",object,fLcaaar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcar)(FFN(fLcar)(x)))); } DEFUN("CAADR",object,fLcaadr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcar)(FFN(fLcdr)(x)))); } DEFUN("CADAR",object,fLcadar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcdr)(FFN(fLcar)(x)))); } DEFUN("CADDR",object,fLcaddr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcdr)(FFN(fLcdr)(x)))); } DEFUN("CDAAR",object,fLcdaar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcar)(FFN(fLcar)(x)))); } DEFUN("CDADR",object,fLcdadr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcar)(FFN(fLcdr)(x)))); } DEFUN("CDDAR",object,fLcddar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcar)(x)))); } DEFUN("CDDDR",object,fLcdddr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcdr)(x)))); } DEFUN("CAAAAR",object,fLcaaaar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcar)(FFN(fLcar)(FFN(fLcar)(x))))); } DEFUN("CAAADR",object,fLcaaadr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcar)(FFN(fLcar)(FFN(fLcdr)(x))))); } DEFUN("CAADAR",object,fLcaadar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcar)(FFN(fLcdr)(FFN(fLcar)(x))))); } DEFUN("CAADDR",object,fLcaaddr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcar)(FFN(fLcdr)(FFN(fLcdr)(x))))); } DEFUN("CADAAR",object,fLcadaar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcdr)(FFN(fLcar)(FFN(fLcar)(x))))); } DEFUN("CADADR",object,fLcadadr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcdr)(FFN(fLcar)(FFN(fLcdr)(x))))); } DEFUN("CADDAR",object,fLcaddar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcar)(x))))); } DEFUN("CADDDR",object,fLcadddr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcar)(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcdr)(x))))); } DEFUN("CDAAAR",object,fLcdaaar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcar)(FFN(fLcar)(FFN(fLcar)(x))))); } DEFUN("CDAADR",object,fLcdaadr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcar)(FFN(fLcar)(FFN(fLcdr)(x))))); } DEFUN("CDADAR",object,fLcdadar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcar)(FFN(fLcdr)(FFN(fLcar)(x))))); } DEFUN("CDADDR",object,fLcdaddr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcar)(FFN(fLcdr)(FFN(fLcdr)(x))))); } DEFUN("CDDAAR",object,fLcddaar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcar)(FFN(fLcar)(x))))); } DEFUN("CDDADR",object,fLcddadr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcar)(FFN(fLcdr)(x))))); } DEFUN("CDDDAR",object,fLcdddar,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcar)(x))))); } DEFUN("CDDDDR",object,fLcddddr,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcdr)(FFN(fLcdr)(x))))); } DEFUN("COPY-LIST",object,fLcopy_list,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { object y=Cnil,ly=Cnil; for (;consp(x);x=x->c.c_cdr) { object z=MMcons(x->c.c_car,Cnil); if (y==Cnil) y=ly=z; else { ly->c.c_cdr=z; ly=z; } } RETURN1(y); } DEFUN("LAST",object,fLlast,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { fixnum n=INIT_NARGS(1); object l=Cnil,f=OBJNULL,s,t; va_list ap; enum type tp; va_start(ap,x); s=NEXT_ARG(n,ap,l,f,make_fixnum(1)); if (endp(x)) RETURN1(Cnil); tp=type_of(s); if ((tp!=t_fixnum && tp!=t_bignum)|| number_minusp(s)) TYPE_ERROR(s,list(2,sLinteger,make_fixnum(0))); n=tp==t_fixnum ? fix(s) : fix(sLarray_dimension_limit->s.s_dbind); t=x; if (!n) while (consp(t)) t=t->c.c_cdr; else { while (consp(x->c.c_cdr) && --n) x = x->c.c_cdr; while (consp(x->c.c_cdr)) { t=t->c.c_cdr; x = x->c.c_cdr; } } RETURN1(t); } DEFUN("BUTLAST",object,fLbutlast,LISP,1,2,NONE,OO,OO,OO,OO,(object lis,...),"") { fixnum n=INIT_NARGS(1); object l=Cnil,f=OBJNULL,nn; va_list ap; va_start(ap,lis); nn=NEXT_ARG(n,ap,l,f,make_fixnum(1)); RETURN1(FFN(fLldiff)(lis,(VFUN_NARGS=2,FFN(fLlast)(lis,nn)))); } DEFUN("APPEND",object,fSappend,LISP,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { fixnum n=INIT_NARGS(0); object l=Cnil,f=first,z,y=Cnil,r=Cnil,rp=Cnil; va_list ap; va_start(ap,first); for (;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL;) { if (z==Cnil) continue; y=FFN(fLcopy_list)(y); if (r==Cnil) r=rp=y; else rp->c.c_cdr=y; rp=(VFUN_NARGS=1,FFN(fLlast)(rp)); y=z; } va_end(ap); if (r==Cnil) r=rp=y; else rp->c.c_cdr=y; RETURN1(r); } DEFUN("ENDP",object,fSendp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (x==Cnil) RETURN1(Ct); if (!consp(x)) FEwrong_type_argument(sLlist,x); RETURN1(Cnil); } DEFUN("LIST-LENGTH",object,fSlist_length,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { fixnum n; object fast, slow; for (n=0,fast=slow=x;;) { if (endp(fast)) RETURN1(make_fixnum(n)); if (endp(fast->c.c_cdr)) RETURN1(make_fixnum(n+1)); if (fast == slow && n > 0) RETURN1(Cnil); n += 2; fast = fast->c.c_cdr->c.c_cdr; slow = slow->c.c_cdr; } } DEFUN("MAKE-LIST",object,fSmake_list,LISP,1,63,NONE,OI,OO,OO,OO,(fixnum x,...),"") { fixnum n=INIT_NARGS(1); object l=Cnil,f=OBJNULL,*base=vs_top,z,r=Cnil; va_list ap; va_start(ap,x); for (;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL;) vs_push(z);/*FIXME do this on C stack, or better, do a parse_key taking on arg at a time*/ va_end(ap); parse_key(base,FALSE,FALSE,1,sKinitial_element); for (;x--;) r=MMcons(base[0],r); vs_top=base; RETURN1(r); } static inline object copy_tree(object x) { return consp(x) ? MMcons(copy_tree(x->c.c_car),copy_tree(x->c.c_cdr)) : x; } DEFUN("COPY-TREE",object,fScopy_tree,LISP,1,2,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(copy_tree(x)); } DEFUN("NCONC",object,fSnconc,LISP,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { fixnum n=INIT_NARGS(0); object l=Cnil,f=first,z,y=Cnil,r=Cnil,rp=Cnil; va_list ap; va_start(ap,first); for (;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL;) { if (z==Cnil) continue; if (r==Cnil) r=rp=y; else rp->c.c_cdr=y; rp=(VFUN_NARGS=1,FFN(fLlast)(rp)); y=z; } va_end(ap); if (r==Cnil) r=rp=y; else rp->c.c_cdr=y; RETURN1(r); } DEFUN("NRECONC",object,fSnreconc,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { object r=Cnil; for (;consp(x);x=x->c.c_cdr) { if (r!=Cnil) { r->c.c_cdr=y; y=r; } r=x; } if (r!=Cnil) { r->c.c_cdr=y; y=r; } RETURN1(y); } DEFUN("NTH",object,fLnth,LISP,2,2,NONE,OO,OO,OO,OO,(object i,object lst),"") { object x = lst; fixnum index=fixint(i); if (index < 0) FEerror("Negative index: ~D.", 1, make_fixnum(index)); while (1) {if (consp(x)) { if (index == 0) RETURN1(Mcar(x)); else {x = Mcdr(x); index--;}} else if (x == sLnil) RETURN1(sLnil); else FEwrong_type_argument(sLlist, lst);} } DEFUN("NTHCDR",object,fLnthcdr,LISP,2,2,NONE,OO,OO,OO,OO,(object i,object lst),"") { object x = lst; fixnum index=fixint(i); if (index < 0) FEerror("Negative index: ~D.", 1, make_fixnum(index)); while (1) {if (consp(x)) { if (index == 0) RETURN1(x); else {x = Mcdr(x); index--;}} else if (x == sLnil) RETURN1(sLnil); else FEwrong_type_argument(sLlist, lst);} } DEFUN("FIRST",object,fLfirst,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(car(x)) ;} DEFUN("SECOND",object,fLsecond,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(1),x);} DEFUN("THIRD",object,fLthird,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(2),x);} DEFUN("FOURTH",object,fLfourth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(3),x);} DEFUN("FIFTH",object,fLfifth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(4),x);} DEFUN("SIXTH",object,fLsixth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(5),x);} DEFUN("SEVENTH",object,fLseventh,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(6),x);} DEFUN("EIGHTH",object,fLeighth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(7),x);} DEFUN("NINTH",object,fLninth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(8),x);} DEFUN("TENTH",object,fLtenth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return FFN(fLnth)(make_fixnum(9),x);} static inline object sublis(object alist,object tree,object key,object test,object test_not) { object z; for (z = alist; !endp(z); z = z->c.c_cdr) { object w=z->c.c_car; if (TESTA(w->c.c_car,tree,key,test,test_not)) return w->c.c_cdr; } if (consp(tree)) { object a=sublis(alist,tree->c.c_car,key,test,test_not),d=sublis(alist,tree->c.c_cdr,key,test,test_not); return a==tree->c.c_car && d==tree->c.c_cdr ? tree : MMcons(a,d); } else return tree; } DEFKTFUN("SUBLIS",fLsublis,LISP,sublis(x,y,key,test,test_not)) DEFUN("WILD-PATHNAME-P",object,fLwild_pathname_p,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { return Cnil; } DEFUN("SET-DIFFERENCE",object,fLset_difference,LISP,2,8,NONE,OO,OO,OO,OO, (object x,object y,...),"") { object z=Cnil,yy; for (;x!=Cnil;x=x->c.c_cdr) { for (yy=y;yy!=Cnil && x->c.c_car!=yy->c.c_car;yy=yy->c.c_cdr); if (yy==Cnil) z=MMcons(x->c.c_car,z); } RETURN1(z); } DEFUN("UNION",object,fLunion,LISP,2,8,NONE,OO,OO,OO,OO, (object x,object y,...),"") { object z=y,yy; for (;x!=Cnil;x=x->c.c_cdr) { for (yy=z;yy!=Cnil && x->c.c_car!=yy->c.c_car;yy=yy->c.c_cdr); if (yy==Cnil) z=MMcons(x->c.c_car,z); } RETURN1(z); } DEFUN("NUNION",object,fLnunion,LISP,2,8,NONE,OO,OO,OO,OO, (object x,object y,...),"") { object z=Cnil,zp=z,yy; for (;x!=Cnil;x=x->c.c_cdr) { for (yy=y;yy!=Cnil && x->c.c_car!=yy->c.c_car;yy=yy->c.c_cdr); if (yy==Cnil) { if (zp!=Cnil) zp->c.c_cdr=x; else z=x; zp=x; } } if (zp!=Cnil) zp->c.c_cdr=y; RETURN1(z!=Cnil ? z : y); } DEFUN("INTERSECTION",object,fLintersection,LISP,2,8,NONE,OO,OO,OO,OO, (object x,object y,...),"") { object z=Cnil,yy; for (;x!=Cnil;x=x->c.c_cdr) { for (yy=y;yy!=Cnil && x->c.c_car!=yy->c.c_car;yy=yy->c.c_cdr); if (yy!=Cnil) z=MMcons(x->c.c_car,z); } RETURN1(z); } DEFUN("SBIT",object,fLsbit,LISP,2,2,NONE,IO,IO,OO,OO,(object x,fixnum i),"") { RETURN1((object)fix(fLrow_major_aref(x,i))); } DEFUNM("GETHASH",object,fLgethash,LISP,2,3,NONE,OO,OO,OO,OO,(object x,object y,...),"") { fixnum nargs=INIT_NARGS(2),vals=(fixnum)fcall.valp; object *base=vs_top,l=Cnil,f=OBJNULL,z; va_list ap; struct cons *e; check_type_hash_table(&y); e=gethash(x,y); if (e->c_cdr != OBJNULL) RETURN2(e->c_car,Ct); else { va_start(ap,y); z=NEXT_ARG(nargs,ap,l,f,Cnil); va_end(ap); RETURN2(z,Cnil); } } DEFUN("HASH-SET",object,fShash_set,SI,3,3,NONE,OO,OO,OO,OO,(object x,object y,object z),"") { check_type_hash_table(&y); sethash(x,y,z); RETURN1(z); } DEFUN("COMPLEX",object,fLcomplex,LISP,1,2,NONE,OO,OO,OO,OO,(object r,...),"") { fixnum nargs=INIT_NARGS(1); object l=Cnil,f=OBJNULL,i; va_list ap; va_start(ap,r); i=NEXT_ARG(nargs,ap,l,f,make_fixnum(0)); va_end(ap); check_type_or_rational_float(&r); check_type_or_rational_float(&i); RETURN1(make_complex(r,i)); } DEFUN("FLOAT",object,fLfloat,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") { fixnum nargs=INIT_NARGS(1); object l=Cnil,f=OBJNULL,y; va_list ap; double d; enum type t; va_start(ap,x); y=NEXT_ARG(nargs,ap,l,f,(t=type_of(x))==t_shortfloat || t==t_longfloat ? x : make_longfloat(0.0)); va_end(ap); /* check_type_float(&x); */ check_type_float(&y); t=type_of(y); switch (type_of(x)) { case t_fixnum: if (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 (t == t_shortfloat) x = make_shortfloat((shortfloat)d); else x = make_longfloat(d); break; case t_shortfloat: if (t == t_longfloat) x = make_longfloat((double)(sf(x))); break; case t_longfloat: if (t == t_shortfloat) x = make_shortfloat((shortfloat)(lf(x))); break; default: FEwrong_type_argument(TSor_rational_float, x); } RETURN1(x); } #ifndef NO_BOOT_H #include "boot.h" #endif gcl-2.7.1/o/PaxHeaders/big.c0000644000000000000000000000013114555557372012530 xustar0029 mtime=1706483450.80039273 30 atime=1744339817.679430505 30 ctime=1744351535.466909362 gcl-2.7.1/o/big.c0000644000175000017500000000760514555557372012137 0ustar00cammcamm /* Copyright William F. Schelter 1991 Copyright 2024 Camm Maguire 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.h" #include "num_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("INTEGER-QUOTIENT-REMAINDER_1",object,fSinteger_quotient_remainder_1,SI,4,4,NONE,OO,OO,IO,OO,(object r,object x,object y,fixnum d),"") { integer_quotient_remainder_1(x,y,&r->c.c_car,&r->c.c_cdr,d); RETURN1(r); } DEFUN("MBIGNUM2",object,fSbignum2,SI,2,2,NONE,OI,IO,OO,OO,(fixnum h,fixnum l),"") { object x = new_bignum(); mpz_set_si(MP(x),h); mpz_mul_2exp(MP(x),MP(x),8*sizeof(x)); mpz_add_ui(MP(x),MP(x),l); RETURN1(normalize_big(x)); } DEFUN("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); } #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 = ZALLOCA(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); return ans; } #endif gcl-2.7.1/o/PaxHeaders/num_pred.c0000644000000000000000000000013214555557372013601 xustar0030 mtime=1706483450.804392729 30 atime=1744339818.407435047 30 ctime=1744351535.466909362 gcl-2.7.1/o/num_pred.c0000644000175000017500000001011314555557372013173 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.7.1/o/PaxHeaders/unixfasl.c0000644000000000000000000000013114542551763013612 xustar0030 mtime=1703597043.344022966 30 atime=1744339825.399478697 29 ctime=1744351535.47490929 gcl-2.7.1/o/unixfasl.c0000644000175000017500000000154014542551763013211 0ustar00cammcamm/* 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" void gcl_init_unixfasl(void) { } gcl-2.7.1/o/PaxHeaders/sgbc.c0000644000000000000000000000013214762341024012667 xustar0030 mtime=1741275668.208171739 30 atime=1744339837.383553596 30 ctime=1744351535.582908322 gcl-2.7.1/o/sgbc.c0000644000175000017500000006216014762341024012272 0ustar00cammcamm/* Copyright William Schelter. All rights reserved. Copyright 2024 Camm Maguire 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_vector(sLbit,(page(heap_end)-first_data_page),Ct,Cnil,Cnil,0,Ct,Cnil); 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_writable) for (i=page(x->c.c_car->st.st_self);i<=page(x->c.c_car->st.st_self+VLEN(x->c.c_car)-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; 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(sig,code,scp,addr); } 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 #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; } #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); else bzero((void *)sec->sh_addr,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; } *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)); memory->cfd.cfd_name=faslfile->sm.sm_object1; 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)); if(symbol_value(sLAload_verboseA)!=Cnil) { printf(";; start address for %.*s %p\n", (int)VLEN(memory->cfd.cfd_name),memory->cfd.cfd_name->st.st_self, memory->cfd.cfd_start); fflush(stdout); } init_address-=(ul)memory->cfd.cfd_start; call_init(init_address,memory,faslfile); return(memory->cfd.cfd_size); } #include "sfasli.c" gcl-2.7.1/o/PaxHeaders/symbol.d0000644000000000000000000000013214555557372013276 xustar0030 mtime=1706483450.808392729 30 atime=1744340056.112936897 30 ctime=1744351535.582908322 gcl-2.7.1/o/symbol.d0000644000175000017500000003606614555557372012707 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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; object make_symbol(st) object st; { object x; {BEGIN_NO_INTERRUPT; x = alloc_object(t_symbol); x->s.s_dbind = OBJNULL; x->s.s_sfdef = NOT_SPECIAL; x->s.s_name=copy_simple_string(st);/*FIXME*/ 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); x->s.s_hash = ihash_equal1(x,0); 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; j = pack_hash(str(s)); ep = &P_EXTERNAL(lisp_package,j); for (l = *ep; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car->s.s_name, str(s))) return(l->c.c_car); x = make_symbol(str(s)); 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; j = pack_hash(str(s)); ep = & P_EXTERNAL(system_package,j); for (l = *ep; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car->s.s_name, str(s))) return(l->c.c_car); for (l = P_EXTERNAL(lisp_package,j); consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car->s.s_name, str(s))) error("name conflict --- can't make_si_ordinary"); x = make_symbol(str(s)); vs_push(x); x->s.s_hpack = system_package; system_package->p.p_external_fp ++; *ep = make_cons(x, *ep); vs_reset; return(x); } object make_gmp_ordinary(s) char *s; { int i,j; object x, l, *ep; vs_mark; char *ss=alloca(strlen(s)+1); for (i=0;s[i];i++) ss[i]=toupper(s[i]); ss[i]=0; j = pack_hash(str(ss)); ep = & P_EXTERNAL(gmp_package,j); for (l = *ep; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car->s.s_name, str(ss))) return(l->c.c_car); for (l = P_EXTERNAL(lisp_package,j); consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car->s.s_name, str(ss))) error("name conflict --- can't make_si_ordinary"); x = make_symbol(str(ss)); vs_push(x); x->s.s_hpack = gmp_package; gmp_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; j = pack_hash(str(s)); ep = &P_EXTERNAL(keyword_package,j); for (l = *ep; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car->s.s_name, str(s))) return(l->c.c_car); x = make_symbol(str(s)); vs_push(x); x->s.s_hpack = keyword_package; x->s.tt=2; 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) ((!consp(obj))) 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; FEinvalid_form("Bad plist ~a",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); } DEFUN("SPUTPROP",object,fSsputprop,SI,3,3,NONE,OO,OO,OO,OO,(object s,object p,object v),"") { 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 fSsputprop(object x,object y,object z) { return FFN(fSsputprop)(x,y,z); } #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; } DEFUN("SYMBOL-PLIST",object,fLsymbol_plist,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { check_type_sym(&sym); RETURN1(sym->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) @) DEFUN("SYMBOL-STRING",object,fSsymbol_string,SI,1,1,NONE,OO,OO,OO,OO,(object sym),"") { RETURN1(sym->s.s_name); } object symbol_name(x) object x; { if (type_of(x)!=t_symbol) FEwrong_type_argument(sLsymbol,x); return(x->s.s_name); } DEFUN("SYMBOL-NAME",object,fLsymbol_name,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { /* LFD(Lsymbol_name)() */ RETURN1(symbol_name(sym)); } DEFUN("MAKE-SYMBOL",object,fLmake_symbol,LISP,1,1,NONE,OO,OO,OO,OO,(object name),"") { /* LFD(Lmake_symbol)() */ check_type_string(&name); RETURN1(make_symbol(name)); } @(defun copy_symbol (sym &optional cp &aux x) @ check_type_sym(&sym); x = make_symbol(sym->s.s_name); 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),""); static object gensym_int(object this_gensym_prefix,object this_gensym_counter) { int i, j, sign, size; fixnum f; char *q=NULL,*p=NULL; object big; object sym; switch (type_of(this_gensym_counter)) { case t_bignum: big=this_gensym_counter; sign=BIG_SIGN(big); size = mpz_sizeinbase(MP(big),10)+(BIG_SIGN(big)<0? 1 : 0)+1; massert(p=alloca(size)); massert(p=mpz_get_str(p,10,MP(big))); q=p+strlen(p); break; case t_fixnum: for (size=1,f=fix(this_gensym_counter);f;f/=10,size++); q=p=ZALLOCA(size+5); if ((j=snprintf(p,size+5,"%d",(int)fix(this_gensym_counter)))<=0) FEerror("Cannot write gensym counter",0); q=p+j; break; default: TYPE_ERROR(this_gensym_counter,sLinteger); break; } i = (q-p)+(this_gensym_prefix==OBJNULL ? 1 : VLEN(this_gensym_prefix)); sym = make_symbol(str("")); { BEGIN_NO_INTERRUPT; sym->s.s_name=alloc_simple_string(i); sym->s.s_name->st.st_self = alloc_relblock(i); /* sym->s.s_fillp = i; */ i=this_gensym_prefix==OBJNULL ? 1 : VLEN(this_gensym_prefix); for (j = 0; j < i; j++) sym->s.s_name->st.st_self[j] = this_gensym_prefix==OBJNULL ? 'G' : this_gensym_prefix->st.st_self[j]; for (;js.s_name);j++) sym->s.s_name->st.st_self[j] = p[j-i]; END_NO_INTERRUPT; } RETURN1(sym); } DEFUN("GENSYM0",object,fSgensym0,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { object x; x=sLgensym_counter->s.s_dbind; sLgensym_counter->s.s_dbind=number_plus(sLgensym_counter->s.s_dbind,small_fixnum(1)); RETURN1(gensym_int(OBJNULL,x)); } DEFUN("GENSYM1S",object,fSgensym1s,SI,1,1,NONE,OO,OO,OO,OO,(object g),"") { object x; x=sLgensym_counter->s.s_dbind; sLgensym_counter->s.s_dbind=number_plus(sLgensym_counter->s.s_dbind,small_fixnum(1)); RETURN1(gensym_int(g,x)); } DEFUN("GENSYM1IG",object,fSgensym1ig,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_non_negative_integer(&x); RETURN1(gensym_int(OBJNULL,x)); } #ifdef STATIC_FUNCTION_POINTERS object fSgensym0(void) { return FFN(fSgensym0)(); } object fSgensym1s(object x) { return FFN(fSgensym1s)(x); } object fSgensym1ig(object x) { return FFN(fSgensym1ig)(x); } #endif @(defun gentemp (&optional (prefix gentemp_prefix) (pack `current_package()`) &aux smbl) int i, j; @ check_type_string(&prefix); if (type_of(pack)!=t_package) {object tem; tem=find_package(pack); if (tem==Cnil) FEerror("No package named ~a exists",1,pack); pack=tem;} /* 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 += VLEN(prefix); {BEGIN_NO_INTERRUPT; string_register->st.st_dim = i; string_register->st.st_self = alloc_relblock(i); for (j = 0; j < VLEN(prefix); 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) @) DEFUN("SYMBOL-PACKAGE",object,fLsymbol_package,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { check_type_sym(&sym); RETURN1(sym->s.s_hpack); } DEFUN("KEYWORDP",object,fLkeywordp,LISP,1,1,NONE,OO,OO,OO,OO,(object sym),"") { RETURN1(type_of(sym) == t_symbol && keywordp(sym) ? Ct : 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_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.7.1/o/PaxHeaders/fat_string.c0000644000000000000000000000013114555557372014127 xustar0029 mtime=1706483450.80039273 30 atime=1744339827.075489165 30 ctime=1744351535.478909254 gcl-2.7.1/o/fat_string.c0000644000175000017500000002160214555557372013527 0ustar00cammcamm/* (c) Copyright W. Schelter 1988, All rights reserved. Copyright (c) 2024 Camm Maguire */ #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("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 (!stringp(ar)) 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("FUNCTION-START",object,fSfunction_start,SI ,1,1,NONE,OO,OO,OO,OO,(object funobj),"") {/* 1 args */ if(/* type_of(funobj)!=t_cfun */ /* && */type_of(funobj)!=t_function) FEerror("not compiled function",0); funobj=make_fixnum((long) (funobj->fun.fun_self)); RETURN1(funobj); } /* 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)*CHAR_SIZE-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_function].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_function) continue; if (is_free(x) || x->fun.fun_self == NULL) continue; /* the cdefn things are the proclaimed call types. */ cf_addr=(char * ) ((unsigned long)(x->fun.fun_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("SET-UP-COMBINED",object,fSset_up_combined,SI ,0,1,NONE,OO,OO,OO,OO,(object first,...),"") { unsigned int n; object siz,l=Cnil,f=OBJNULL; fixnum nargs=INIT_NARGS(0); va_list ap; va_start(ap,first); siz=NEXT_ARG(nargs,ap,l,f,make_fixnum(0)); 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("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 (!stringp(obj_ar)) 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);} *//*FIXME*/ 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("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.7.1/o/PaxHeaders/unixsys.c0000644000000000000000000000013214556573017013505 xustar0030 mtime=1706751503.785071974 30 atime=1744339826.159483444 30 ctime=1744351535.478909254 gcl-2.7.1/o/unixsys.c0000644000175000017500000000775114556573017013115 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 #ifndef __MINGW32__ #include #endif #include "include.h" #if !defined(__MINGW32__) && !defined(__CYGWIN__) int vsystem(char *command) { char *c; const char *x1[]={"/bin/sh","-c",NULL,NULL},*spc=" \n\t",**p1,**pp,**pe; int s; pid_t pid; posix_spawnattr_t attr; posix_spawn_file_actions_t file_actions; extern char **environ; if (strpbrk(command,"\"'$<>")) (p1=x1)[2]=command; else { p1=(void *)FN2; pe=p1+sizeof(FN2)/sizeof(*p1); for (pp=p1,c=command;pp0); 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(char *s) { return psystem(s); } static void FFN(siLsystem)(void) { static char command[32768]; int i; check_arg(1); check_type_string(&vs_base[0]); if (VLEN(vs_base[0]) >= 32768) FEerror("Too long command line: ~S.", 1, vs_base[0]); for (i = 0; i < VLEN(vs_base[0]); 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("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.7.1/o/PaxHeaders/gmp_big.c0000644000000000000000000000013114757123151013357 xustar0029 mtime=1740416617.08497045 30 atime=1744339817.891431827 30 ctime=1744351535.582908322 gcl-2.7.1/o/gmp_big.c0000644000175000017500000002777114757123151012774 0ustar00cammcamm /* Copyright William F. Schelter 1991 Copyright 2024 Camm Maguire 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 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 #ifndef GMP_USE_MALLOC object big_gcprotect; object big_fixnum1; object big_fixnum2; object big_fixnum3; object big_fixnum4; object big_fixnum5; #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 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 = (u==MP(big_fixnum1) || u==MP(big_fixnum2) || u==MP(big_fixnum3) || u==MP(big_fixnum4) || u==MP(big_fixnum5)) ? 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 double big_to_double(object x) { int s=mpz_sizeinbase(MP(x),2),i=0,j; if (s>=54 && mpz_tstbit(MP(x),s-54)) for (i=mpz_tstbit(MP(x),s-53),j=s-55;!i && j>=0 && !(i=mpz_tstbit(MP(x),j));j--); if (i) { mpz_set_si(MP(big_fixnum1),mpz_sgn(MP(x))>0 ? 1 : -1); mpz_mul_2exp(MP(big_fixnum1),MP(big_fixnum1),s-54); mpz_add(MP(big_fixnum1),MP(big_fixnum1),MP(x)); x=big_fixnum1; } return mpz_get_d(MP(x)); } /* 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; } MP_INT * stoi(fixnum x) { object y = new_bignum(); mpz_set_si(MP(y),x); return MP(y); } /* 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 replace_big(object x) { return make_bignum(MP(x)); } 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 replace_big(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!=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 ss=mpz_sizeinbase(MP(x),printbase)+(BIG_SIGN(x)<0 ? 1 : 0)+1; char *p; object ans; massert(p=alloca(ss)); massert(p=mpz_get_str(p,printbase,MP(x))); ss=strlen(p); ans=alloc_simple_string(ss); ans->st.st_self=alloc_relblock(ss); memcpy(ans->st.st_self,p,ss); return ans; } void gcl_init_big(void) { gcl_init_big1(); big_gcprotect=alloc_object(t_bignum);/*FIXME*/ MP_SELF(big_gcprotect)=0; MP_ALLOCATED(big_gcprotect)=0; enter_mark_origin(&big_gcprotect); #define mjoin(a_,b_) a_ ## b_ #define Mjoin(a_,b_) mjoin(a_,b_) #define init_big_fixnum(a_) { \ Mjoin(big_fixnum,a_)=new_bignum(); \ mpz_set_si(MP(Mjoin(big_fixnum,a_)),0); \ enter_mark_origin(&Mjoin(big_fixnum,a_)); \ } init_big_fixnum(1); init_big_fixnum(2); init_big_fixnum(3); init_big_fixnum(4); init_big_fixnum(5); sSPminus_most_negative_fixnumP=make_si_constant("+MINUS-MOST-NEGATIVE-FIXNUM+",fixnum_add(MOST_POSITIVE_FIX,1)); } gcl-2.7.1/o/PaxHeaders/frame.c0000644000000000000000000000013114555557372013061 xustar0029 mtime=1706483450.80039273 30 atime=1744339813.047401611 30 ctime=1744351535.454909469 gcl-2.7.1/o/frame.c0000644000175000017500000000371214555557372012463 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.7.1/o/PaxHeaders/regexpr.c0000644000000000000000000000013214720126436013427 xustar0030 mtime=1732291870.782087945 30 atime=1744339822.799462461 30 ctime=1744351535.470909326 gcl-2.7.1/o/regexpr.c0000644000175000017500000001412714720126436013032 0ustar00cammcamm/* Copyright (C) 1994 W. Schelter Copyright (C) 2024 Camm Maguire 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" #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 (!stringp(x)) \ not_a_string(x) DEFVAR("*COMPILED-REGEXP-CACHE*",sSAcompiled_regexp_cacheA,SI,MMcons(MMcons(sLnil,sLnil),sLnil),""); 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("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(((fixnum *)sSAmatch_dataA->s.s_dbind->a.a_self)[i])); RETURN1(make_fixnum(-1)); } DEFUN("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(((fixnum *)sSAmatch_dataA->s.s_dbind->a.a_self)[i+NSUBEXP])); RETURN1(make_fixnum(-1)); } DEFUN("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; void *v; ufixnum sz=0; p=coerce_to_string(p); if (!(tmp=alloca(VLEN(p)+1))) FEerror("out of C stack",0); memcpy(tmp,p->st.st_self,VLEN(p)); tmp[VLEN(p)]=0; if (!(v=(void *)regcomp(tmp,&sz))) FEerror("regcomp failure",0); res=alloc_object(t_vector); res->v.v_adjustable=1; res->v.v_hasfillp=1; SET_ADISP(res,Cnil); set_array_elttype(res,aet_uchar); res->v.v_rank=1; res->v.v_self=v; res->v.v_dim=sz; VSET_MAX_FILLP(res); RETURN1(res); } #ifdef STATIC_FUNCTION_POINTERS object fScompile_regexp(object x) { return FFN(fScompile_regexp)(x); } #endif DEFUN("STRING-MATCH",object,fSstring_match,SI,2,4,NONE,IO,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. \ ") { fixnum nargs=INIT_NARGS(2); int i,ans; int len,start,end; va_list ap; object v=sSAmatch_dataA->s.s_dbind,l=Cnil,f=OBJNULL; char **pp,*str,save_c=0; if (!stringp(pattern) && 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 (!stringp(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); */ v=sSAmatch_dataA->s.s_dbind=fSmake_vector(sLfixnum,(NSUBEXP *2),Ct,Cnil,Cnil,0,Cnil,Cnil); va_start(ap,string); start=fixint(NEXT_ARG(nargs,ap,l,f,make_fixnum(0))); end=fixint(NEXT_ARG(nargs,ap,l,f,make_fixnum(VLEN(string)))); va_end(ap); if (start < 0 || end > VLEN(string) || start > end) FEerror("Bad start or end",0); len=VLEN(pattern); if (len==0) { /* trivial case of empty pattern */ for (i=0;ia.a_self)[i]=i ? -1 : 0; memcpy(((fixnum *)v->a.a_self)+NSUBEXP,((fixnum *)v->a.a_self),NSUBEXP*sizeof(*((fixnum *)v->a.a_self))); RETURN1(0); } { regexp *compiled_regexp; BEGIN_NO_INTERRUPT; if (type_of(pattern)==t_vector) compiled_regexp=(void *)pattern->ust.ust_self; else { object cache=sSAcompiled_regexp_cacheA->s.s_dbind; if (cache->c.c_car->c.c_car!=pattern || cache->c.c_car->c.c_cdr!=sSAcase_fold_searchA->s.s_dbind) { cache->c.c_car->c.c_car=pattern; cache->c.c_car->c.c_cdr=sSAcase_fold_searchA->s.s_dbind; cache->c.c_cdr=FFN(fScompile_regexp)(pattern); } compiled_regexp=(regexp *)cache->c.c_cdr->v.v_self; } str=string->st.st_self; if (NULL_OR_ON_C_STACK(str+end) || str+end==(void *)compiled_regexp) { if (!(str=alloca(VLEN(string)+1))) FEerror("Cannot allocate memory on C stack",0); memcpy(str,string->st.st_self,VLEN(string)); } 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((object)-1); } pp=compiled_regexp->startp; for (i=0;ia.a_self)[i]=*pp ? *pp-str : -1; pp=compiled_regexp->endp; for (;i<2*NSUBEXP;i++,pp++) ((fixnum *)v->a.a_self)[i]=*pp ? *pp-str : -1; END_NO_INTERRUPT; RETURN1((object)((fixnum *)v->a.a_self)[0]); } } object fSstring_match2(object x,object y) { return FFN(fSstring_match)(x,y); } gcl-2.7.1/o/PaxHeaders/array.c0000644000000000000000000000013114646003121013060 xustar0030 mtime=1721239121.052021936 29 atime=1744339822.21945884 30 ctime=1744351535.470909326 gcl-2.7.1/o/array.c0000644000175000017500000010347314646003121012467 0ustar00cammcamm/* Copyright (C) 1994 W. Schelter Copyright (C) 2024 Camm Maguire 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" #include "page.h" static object Iname_t=Ct; static char zero[4*SIZEOF_LONG];/*FIXME*/ aet_type_struct aet_types[] = { {" ",&sLcharacter,sizeof(char)}, {zero,&sLbit,sizeof(char)}, {zero,&sSnon_negative_char,sizeof(char)}, {zero,&sSunsigned_char,sizeof(char)}, {zero,&sSsigned_char,sizeof(char)}, {zero,&sSnon_negative_short,sizeof(short)}, {zero,&sSunsigned_short,sizeof(short)}, {zero,&sSsigned_short,sizeof(short)}, {zero,&sLshort_float,sizeof(float)}, #if SIZEOF_LONG != SIZEOF_INT {zero,&sSnon_negative_int,sizeof(int)}, {zero,&sSunsigned_int,sizeof(int)}, {zero,&sSsigned_int,sizeof(int)}, #endif {zero,&sLlong_float,sizeof(double)}, {Cnil,&Iname_t,sizeof(object)}, {zero,&sSnon_negative_fixnum,sizeof(fixnum)}, {zero,&sLfixnum,sizeof(fixnum)} #if SIZEOF_LONG == SIZEOF_INT ,{zero,&sSnon_negative_int,sizeof(int)}, {zero,&sSunsigned_int,sizeof(int)}, {zero,&sSsigned_int,sizeof(int)} #endif }; 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(ARRAY_DIMENSION_LIMIT),""); DEFCONST("ARRAY-TOTAL-SIZE-LIMIT", sLarray_total_size_limit,LISP,make_fixnum(ARRAY_DIMENSION_LIMIT),""); DEF_ORDINARY("BIT",sLbit,LISP,""); DEF_ORDINARY("SBIT",sLsbit,LISP,""); #define ARRAY_BODY_PTR(ar,n) \ (void *)(ar->ust.ust_self + aet_types[Iarray_element_type(ar)].size*n) #define N_FIXNUM_ARGS 6 /*FIXME*/ DEFUN("AREF",object,fLaref,LISP,1,MAX_ARGS,ONE_VAL,OO,II,II,II,(object x,...),"") { va_list ap; fixnum k,n=INIT_NARGS(1); object l=Cnil,f=OBJNULL; ufixnum i1,m,rank=type_of(x)==t_array ? x->a.a_rank : 1; va_start(ap,x); for (m=i1=0;(k=(fixnum)NEXT_ARG(n,ap,l,f,(object)-1))!=-1 && m=N_FIXNUM_ARGS) { object x=(object)k; check_type(x,t_fixnum); k=Mfix(x); } if (k>=(rank>1 ? x->a.a_dims[m] : x->v.v_dim)||k<0) FEerror("Index ~a to array is out of bounds",1,make_fixnum(m)); i1*=rank>1 ? x->a.a_dims[m] : 1; i1+=k; } va_end(ap); if (m!=rank || k!=-1) FEerror("Array rank/index number mismatch on ~a",1,x); RETURN1(fLrow_major_aref(x,i1)); } static void fScheck_bounds_bounds(object x, fixnum i) { if ( ( i >= x->a.a_dim ) || ( i < 0 ) ) { FEerror("Array index ~a out of bounds for ~a", 2, make_fixnum(i),x); } } DEFUN("SVREF",object,fLsvref,LISP,2,2,ONE_VAL,OO,IO,OO,OO,(object x,ufixnum i),"For array X and index I it returns (aref x i) ") { if (TS_MEMBER(type_of(x),TS(t_vector)|TS(t_simple_vector)) && (enum aelttype)x->v.v_elttype == aet_object) {/*FIXME*/ if (x->v.v_dim > i) RETURN1(x->v.v_self[i]); else TYPE_ERROR(make_fixnum(i),list(3,sLinteger,make_fixnum(0),make_fixnum(x->v.v_dim))); } else TYPE_ERROR(x,sLsimple_vector); return(Cnil); } DEFUN("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_simple_vector: case t_simple_bitvector: case t_vector: case t_bitvector: 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: case aet_nnfix: return make_fixnum(((fixnum *)x->a.a_self)[i]); case aet_sf: return make_shortfloat(((float *)x->a.a_self)[i]); case aet_lf: return make_longfloat(((double *)x->a.a_self)[i]); case aet_char: case aet_nnchar: return small_fixnum(x->st.st_self[i]); case aet_uchar: return small_fixnum(x->ust.ust_self[i]); case aet_short: case aet_nnshort: return make_fixnum(SHORT_GCL(x, i)); case aet_ushort: return make_fixnum(USHORT_GCL(x, i)); case aet_int: case aet_nnint: return make_fixnum(INT_GCL(x, i)); case aet_uint: return make_fixnum(UINT_GCL(x, i)); default: FEerror("unknown array type",0); } case t_simple_string: case t_string: fScheck_bounds_bounds(x, i); return code_char(x->st.st_self[i]); default: FEwrong_type_argument(sLarray,x); 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("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_simple_vector: case t_simple_bitvector: case t_vector: case t_bitvector: 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: case aet_nnfix: ASSURE_TYPE(val,t_fixnum); (((fixnum *)x->a.a_self)[i]) = Mfix(val); break; case aet_sf: ASSURE_TYPE(val,t_shortfloat); (((float *)x->a.a_self)[i]) = Msf(val); break; case aet_lf: ASSURE_TYPE(val,t_longfloat); (((double *)x->a.a_self)[i]) = Mlf(val); break; case aet_char: case aet_nnchar: 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: case aet_nnshort: 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; case aet_int: case aet_nnint: ASSURE_TYPE(val,t_fixnum); INT_GCL(x, i) = Mfix(val); break; case aet_uint: ASSURE_TYPE(val,t_fixnum); UINT_GCL(x, i) = Mfix(val); break; default: FEerror("unknown array type",0); } break; case t_simple_string: case t_string: fScheck_bounds_bounds(x, i); ASSURE_TYPE(val,t_character); x->st.st_self[i] = char_code(val); break; default: FEwrong_type_argument(sLarray,x); } return val; } #ifdef STATIC_FUNCTION_POINTERS object fSaset1(object x, fixnum i,object val) { return FFN(fSaset1)(x,i,val); } #endif DEFUN("ASET",object,fSaset,SI,2,ARG_LIMIT,NONE,OO,OO,OO,OO,(object y,object x,...),"") { va_list ap; fixnum k,n=INIT_NARGS(2); ufixnum m,i1,rank=type_of(x)==t_array ? x->a.a_rank : 1; object z,l=Cnil,f=OBJNULL; va_start(ap,x); for (i1=m=0;(z=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL && m=(rank>1 ? x->a.a_dims[m] : x->v.v_dim)||k<0) FEerror("Index ~a to array is out of bounds",1,make_fixnum(m)); i1*=rank>1 ? x->a.a_dims[m] : 1; i1+=k; } va_end(ap); if (m!=rank || z!=OBJNULL) FEerror("Array rank/index number mismatch on ~a",1,x); RETURN1(fSaset1(x,i1,y)); } DEFUN("SVSET",object,fSsvset,SI,3,3,NONE,OO,IO,OO,OO,(object x,fixnum i,object val),"") { if (!TS_MEMBER(type_of(x),TS(t_vector)|TS(t_simple_vector)) || DISPLACED_TO(x) != Cnil)/*FIXME*/ TYPE_ERROR(x,sLsimple_vector); /* Wrong_type_error("simple array",0); */ if (i > x->v.v_dim) FEerror("out of bounds",0); return x->v.v_self[i] = val; } void set_array_elttype(object x,enum aelttype tp) { x->a.a_elttype=tp; x->a.a_eltsize=fixnum_length(elt_size(tp)); x->a.a_eltmode=elt_mode(tp); } fixnum elt_size(fixnum elt_type) { switch (elt_type) { case aet_bit: /* bit */ return 0; case aet_ch: /* character */ case aet_nnchar: /* non-neg char */ case aet_char: /* signed char */ case aet_uchar: /* unsigned char */ return sizeof(char); case aet_nnshort: /* non-neg short */ case aet_short: /* signed short */ case aet_ushort: /* unsigned short */ return sizeof(short); break; case aet_nnint: /* non-neg int */ case aet_int: /* signed int */ case aet_uint: /* unsigned int */ return sizeof(int); break; case aet_nnfix: /* non-neg fixnum */ case aet_fix: /* fixnum */ case aet_object: /* t */ return sizeof(fixnum); case aet_sf: /* short-float */ return sizeof(float); case aet_lf: /* plong-float */ return sizeof(double); default: FEerror("Bad elt type",0); return -1; } } fixnum elt_mode(fixnum elt_type) { switch (elt_type) { case aet_bit: /* bit */ case aet_uchar: /* unsigned char */ case aet_ushort: /* unsigned short */ case aet_uint: /* unsigned int */ return aem_unsigned; case aet_ch: /* character */ return aem_character; case aet_nnchar: /* non-neg char */ case aet_char: /* signed char */ case aet_nnshort: /* non-neg short */ case aet_short: /* signed short */ case aet_nnint: /* non-neg int */ case aet_int: /* signed int */ case aet_nnfix: /* non-neg fixnum */ /*FIXME*/ case aet_fix: /* fixnum */ return aem_signed; case aet_object: /* t */ return aem_t; case aet_sf: /* short-float */ case aet_lf: /* plong-float */ return aem_float; default: FEerror("Bad elt type",0); return -1; } } DEFUN("MAKE-VECTOR",object,fSmake_vector,SI,8,8,NONE,OO,IO,OO,IO, (object etp,fixnum n,object adjp,object fp,object displaced_to,fixnum V9,object staticp,object initial_element),"") { object x; fixnum elt_type=type_of(etp)==t_symbol ? fix(fSget_aelttype(etp)) : fix(etp); fixnum fillp=fp==Cnil ? -1 : (fp==Ct ? n : Mfix(fp)); BEGIN_NO_INTERRUPT; switch(elt_type) { case aet_ch: x = adjp==Cnil && fp==Cnil && displaced_to == Cnil ? alloc_simple_string(n) : alloc_string(n); break; case aet_bit: x = adjp==Cnil && fp==Cnil && displaced_to == Cnil ? alloc_simple_bitvector(n) : alloc_bitvector(n); break; case aet_object: x = adjp==Cnil && fp==Cnil && displaced_to == Cnil ? alloc_simple_vector(n) : alloc_vector(n,aet_object); break; default: x = alloc_vector(n,elt_type); } if (fillp<0) x->a.a_hasfillp=0; else if (fillp>n) FEerror("bad fillp",0); VFILLP_SET(x,fillp); if (displaced_to==Cnil) array_allocself(x,staticp!=Cnil,initial_element); else displace(x,displaced_to,V9); END_NO_INTERRUPT; return x; } #ifdef STATIC_FUNCTION_POINTERS object fSmake_vector(object etp,fixnum n,object adjp,object fp,object displaced_to,fixnum V9,object staticp,object initial_element) { return FFN(fSmake_vector)(etp,n,adjp,fp,displaced_to,V9,staticp,initial_element); } #endif object aelttype_list(void) { aet_type_struct *p,*pe; object f=Cnil,x,y=OBJNULL; for (p=aet_types,pe=p+aet_fix;p<=pe;p++) { x=MMcons(*p->namep,Cnil); y=y!=OBJNULL ? (y->c.c_cdr=x) : (f=x); } return f; } DEFCONST("+ARRAY-TYPES+",sSParray_typesP,SI,aelttype_list(),""); DEFUN("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); if (x==sSnegative_char) return make_fixnum(aet_char); if (x==sSnegative_short) return make_fixnum(aet_short); if (x==sSnegative_int) #if SIZEOF_LONG != SIZEOF_INT return make_fixnum(aet_int); #else return make_fixnum(aet_fix); #endif if (x==sSnegative_fixnum || x==sSsigned_fixnum) return make_fixnum(aet_fix); return make_fixnum(aet_object); } #ifdef STATIC_FUNCTION_POINTERS object fSget_aelttype(object x) { return FFN(fSget_aelttype)(x); } #endif DEFUN("MAKE-ARRAY1",object,fSmake_array1,SI,7,7,NONE,OO,OO,OI,OO, (object x0,object staticp,object initial_element,object displaced_to,fixnum displaced_index_offset, object dimensions,object adjp),"") { int rank = length(dimensions); fixnum elt_type=fix(fSget_aelttype(x0)); 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); set_array_elttype(x,elt_type); x->a.a_self = 0; x->a.a_hasfillp = 0; x->a.a_rank = rank; x->a.a_dims = AR_ALLOC(alloc_relblock,rank,ufixnum); 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 = TRUE;/* adjp!=Cnil; */ SET_ADISP(x,Cnil); { 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(object elt_type,object staticp,object initial_element,object displaced_to, fixnum displaced_index_offset,object dimensions,object adjustable) { return FFN(fSmake_array1)(elt_type,staticp,initial_element, displaced_to,displaced_index_offset,dimensions,adjustable); } #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=ADISP(array)->c.c_car; if (a==Cnil) { vs_push(Cnil); vs_push(make_fixnum(0)); END_NO_INTERRUPT; return; } s=aet_types[Iarray_element_type(a)].size; n=(void *)array->a.a_self-(void *)a->a.a_self; if (Iarray_element_type(a)==aet_bit) n=n*CHAR_SIZE+BV_OFFSET(array)-BV_OFFSET(a); 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) */ void set_displaced_body_ptr(object from_array) { object displaced=ADISP(from_array)->c.c_car; if (displaced!=Cnil) { enum aelttype typ =Iarray_element_type(from_array); object dest_array=displaced->c.c_car; int offset=fix(Scdr(displaced)); if (typ == aet_bit) { if (Iarray_element_type(dest_array)==aet_bit) offset += BV_OFFSET(dest_array); from_array->bv.bv_self = (void *)dest_array->bv.bv_self + offset/CHAR_SIZE; SET_BV_OFFSET(from_array,offset % CHAR_SIZE); } else from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset); } } 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 (offset<0) FEerror("Negative offset",0); if (typ!=aet_bit) { void *v1; ufixnum n=0; v1=((void *)dest_array->a.a_self)+ (Iarray_element_type(dest_array)!=aet_bit ? elt_size(dest_array->a.a_elttype)*offset : FLR((n=offset+BV_OFFSET(dest_array)),CHAR_SIZE)/CHAR_SIZE); if (((unsigned long)v1)%elt_size(from_array->a.a_elttype) || n%CHAR_SIZE) FEerror("Offset produces illegal array alignment.",0); } #define BIT_SIZE(a_,b_) ((a_)*((b_) ? (b_)*CHAR_SIZE : 1)) if (BIT_SIZE(from_array->a.a_dim,elt_size(from_array->a.a_elttype))> BIT_SIZE(((fixnum)dest_array->a.a_dim)-offset,elt_size(dest_array->a.a_elttype))) FEerror("Destination array too small",0); /* ensure that we have a cons */ if (ADISP(dest_array) == Cnil) SET_ADISP(dest_array,list(2,Cnil,from_array)); else Mcdr(ADISP(dest_array)) = make_cons(from_array,Mcdr(ADISP(dest_array))); SET_ADISP(from_array,make_cons(make_cons(dest_array,make_fixnum(offset)),Cnil)); /* 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 */ set_displaced_body_ptr(from_array); } 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_simple_vector: case t_vector: t = (enum aelttype) x->v.v_elttype; break; case t_simple_bitvector: case t_bitvector: t = aet_bit; break; case t_simple_string: case t_string: t = aet_ch; break; default: FEwrong_type_argument(sLarray,x); } return t; } void adjust_displaced(object x) { set_displaced_body_ptr(x); for (x = ADISP(x)->c.c_cdr; x != Cnil; x = x->c.c_cdr) adjust_displaced(x->c.c_car); } /* 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;int i;unsigned int ui; fixnum f;shortfloat sf;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.f=-Mfix(x); break; case aet_fix: case aet_nnfix: /* STORE_TYPED(&u,fixnum, Mfix(x)); */ u.f=Mfix(x); break; case aet_sf: /* STORE_TYPED(&u,shortfloat, Msf(x)); */ u.sf=Msf(x); break; case aet_lf: /* STORE_TYPED(&u,longfloat, Mlf(x)); */ u.d=Mlf(x); break; case aet_char: case aet_nnchar: /* 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: case aet_nnshort: /* 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; case aet_int: case aet_nnint: /* STORE_TYPED(&u, int, Mfix(x)); */ u.i=(int)Mfix(x); break; case aet_uint: /* STORE_TYPED(&u,unsigned int,Mfix(x)); */ u.ui=(unsigned int)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, fixnum 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:case aet_nnfix: GSET(p1,n,fixnum,val); case aet_sf: GSET(p1,n,shortfloat,val); case aet_lf: GSET(p1,n,longfloat,val); case aet_char:case aet_nnchar: GSET(p1,n,char,val); case aet_uchar: GSET(p1,n,unsigned char,val); case aet_short:case aet_nnshort: GSET(p1,n,short,val); case aet_ushort: GSET(p1,n,unsigned short,val); case aet_int:case aet_nnint: GSET(p1,n,int,val); case aet_uint: GSET(p1,n,unsigned int,val); default: FEerror("bad elttype",0); } } DEFUN("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4, 5,NONE,OO,OO,OO,OO,(object x,object y,object o1,object o2,...), "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.") { enum aelttype typ1=Iarray_element_type(x); enum aelttype typ2=Iarray_element_type(y); fixnum i1=fix(o1),i2=fix(o2); int n1,nc; fixnum n=INIT_NARGS(4); object z,l=Cnil,f=OBJNULL; va_list ap; va_start(ap,o2); z=NEXT_ARG(n,ap,l,f,OBJNULL); n1=z==OBJNULL ? x->v.v_dim-i1 : fix(z); va_end(ap); 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) { FFN(fSaset1)(y,i2+n1-rest,(FFN(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_types[(int)typ1].size; if (i1+n1 > x->a.a_dim || ((y->a.a_dim - i2) *aet_types[(int)typ2].size) < nc) FEerror("Copy out of bounds",0); bcopy(x->ust.ust_self + (i1*aet_types[(int)typ1].size), y->ust.ust_self + (i2*aet_types[(int)typ2].size), 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_nnchar: case aet_uchar: x->st.st_self = AR_ALLOC(*fun,n,char); break; case aet_short: case aet_nnshort: case aet_ushort: x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short); break; case aet_int: case aet_nnint: case aet_uint: x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,int); break; case aet_bit: n=ceil(n,BV_ALLOC); n++;/*allow for arrays displaced to end BV_ALLOC access*/ SET_BV_OFFSET(x,0); case aet_fix: case aet_nnfix: x->a.a_self = (void *)AR_ALLOC(*fun,n,fixnum); break; case aet_sf: x->a.a_self = (void *)AR_ALLOC(*fun,n,shortfloat); break; case aet_lf: x->a.a_self = (void *)AR_ALLOC(*fun,n,longfloat); break; default: break; } if(dflt!=OBJNULL) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ); } } DEFUN("FILL-POINTER-SET",object,fSfill_pointer_set,SI,2,2,NONE,OO,IO,OO,OO,(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); } /* DEFUN("FILL-POINTER-INTERNAL",fixnum,fSfill_pointer_internal,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { */ /* RETURN1(x->v.v_fillp); */ /* } */ DEFUN("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("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; */ DEFUN("ARRAY-ELEMENT-TYPE",object,fLarray_element_type,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { enum aelttype t; t = Iarray_element_type(x); return * aet_types[(int)t].namep; } DEFUN("REF",object,fSref,SI,5,5,NONE,OI,II,IO,OO,(fixnum addr,fixnum s,fixnum u,fixnum z,object v),"") { #define el(s_,e_) ((Mjoin(u,s_) *)addr)->e_ #define nw(s_,e_,v_) ({if (z) el(s_,e_)=v_(v); el(s_,e_);}) switch (s) { case 1: switch (u) { case aem_character: RETURN1(code_char(nw(8,u,char_code))); case aem_unsigned: RETURN1(make_fixnum(nw(8,u,fix))); case aem_signed: RETURN1(make_fixnum(nw(8,i,fix))); default: FEerror("Bad mode",0); RETURN1(Cnil); } case 2: switch (u) { case aem_unsigned: RETURN1(make_fixnum(nw(16,u,fix))); case aem_signed: RETURN1(make_fixnum(nw(16,i,fix))); default: FEerror("Bad mode",0); RETURN1(Cnil); } case 4: switch (u) { case aem_signed: RETURN1(make_fixnum(nw(32,i,fix))); case aem_float: RETURN1(make_shortfloat(nw(32,f,sf))); #if SIZEOF_LONG!=4 case aem_unsigned: RETURN1(make_fixnum(nw(32,u,fix))); #else case aem_t: RETURN1(nw(32,o,)); #endif default: FEerror("Bad mode",0); RETURN1(Cnil); } case 8: switch (u) { #if SIZEOF_LONG!=4 case aem_t: RETURN1(nw(64,o,)); case aem_signed: RETURN1(make_fixnum(nw(64,i,fix))); #endif case aem_float: RETURN1(make_longfloat(nw(64,f,lf))); case aem_complex: RETURN1(make_fcomplex(nw(64,c,sfc))); default: FEerror("Bad mode",0); RETURN1(Cnil); } case 16: switch (u) { case aem_complex: RETURN1(make_dcomplex(nw(64,c,lfc))); default: FEerror("Bad mode",0); RETURN1(Cnil); } default: FEerror("Bad size", 0); RETURN1(Cnil); } } DEFUN("CREF",object,fScref,SI,5,5,NONE,OI,II,IO,OO,(fixnum addr,fixnum s,fixnum u,fixnum z,object v),"") { RETURN1(FFN(fSref)(addr,s,u,z,v)); } DEFUN("RREF",object,fSrref,SI,4,5,NONE,OO,II,IO,OO,(object x,fixnum i,fixnum s,fixnum u,...),"") { fixnum n=INIT_NARGS(4); object l=Cnil,f=OBJNULL,v; va_list ap; va_start(ap,u); v=NEXT_ARG(n,ap,l,f,OBJNULL); va_end(ap); RETURN1(FFN(fSref)((long)((char *)x->a.a_self+i*elt_size(x->a.a_elttype)),s,u,v!=OBJNULL,v)); } DEFUN("ARRAY-ELTSIZE",object,fSarray_eltsize,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((object)elt_size(x->a.a_elttype)); } DEFUN("ARRAY-DIMS",object,fSarray_dims,SI,2,2,NONE,IO,IO,OO,OO,(object x,fixnum i),"") { RETURN1((object)x->a.a_dims[i]); } DEFUN("ARRAY-MODE",object,fSarray_mode,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((object)elt_mode(x->a.a_elttype)); } DEFUN("ARRAY-HASFILLP",object,fSarray_hasfillp,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((object)(fixnum)x->a.a_hasfillp); } DEFUN("VECTOR-DIM",object,fSvector_dim,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((object)(fixnum)x->v.v_dim); } DEFUN("ARRAY-ELTTYPE",object,fSarray_elttype,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((object)(fixnum)x->a.a_elttype); } DEFUN("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { IisArray(x); switch (type_of(x)) { case t_array: x=x->a.a_adjustable ? Ct : Cnil; break; case t_string: x=x->st.st_adjustable ? Ct : Cnil; break; case t_vector: x=x->v.v_adjustable ? Ct : Cnil; break; case t_bitvector: x=x->bv.bv_adjustable ? Ct : Cnil; break; default: FEerror("Bad array type",0); break; } return x; } DEFUN("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { IisArray(x); return (ADISP(x) == Cnil ? Cnil : sLt); } DEFUN("ARRAY-RANK",object,fLarray_rank,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (type_of(x) == t_array) RETURN1(make_fixnum(x->a.a_rank)); IisArray(x); RETURN1(make_fixnum(1)); } DEFUN("ARRAY-DIMENSION",object,fLarray_dimension,LISP,2,2,NONE,OO,IO,OO,OO,(object x,fixnum i),"") { if (type_of(x) == t_array) { if ((unsigned int)i >= x->a.a_rank) TYPE_ERROR(make_fixnum(i),list(3,sLinteger,make_fixnum(0),make_fixnum(x->a.a_rank))); else { RETURN1(make_fixnum(x->a.a_dims[i])); } } IisArray(x); RETURN1(make_fixnum(x->v.v_dim)); } #ifdef STATIC_FUNCTION_POINTERS object fLarray_dimension(object x,fixnum i) { return FFN(fLarray_dimension)(x,i); } #endif 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); } } DEFUN("MEMCPY",object,fSmemcpy,SI,3,3,NONE,II,II,OO,OO,(fixnum x,fixnum y,fixnum z),"") { RETURN1((object)(fixnum)memcpy((void *)x,(void *)y,z)); } DEFUN("MEMMOVE",object,fSmemmove,SI,3,3,NONE,II,II,OO,OO,(fixnum x,fixnum y,fixnum z),"") { RETURN1((object)(fixnum)memmove((void *)x,(void *)y,z)); } DEFUN("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,OO,OO,OO,OO,(object old,object new),"") { struct dummy fw; int offset; object displaced; enum type otp=type_of(old),ntp=type_of(new);; fw = old->d; old = IisArray(old); if (otp != ntp || (otp == t_array && old->a.a_rank != new->a.a_rank)) FEerror("Cannot do array replacement ~a by ~a",2,old,new); offset = new->ust.ust_self - old->ust.ust_self; displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim); switch (otp) { case t_array: old->a=new->a; break; case t_bitvector: old->bv=new->bv; break; case t_vector: old->v=new->v; break; case t_string: old->st=new->st; break; default: FEwrong_type_argument(sLarray,old); break; } /* 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; SET_ADISP(old,displaced); adjust_displaced(old); return old; } DEFUN("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1,NONE,IO,OO,OO,OO,(object x),"") { x = IisArray(x); RETURN1((object)(fixnum)x->a.a_dim); } DEFUN("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3,NONE,OO,OO,OO,OO,(object array,object val,object cursor),"") { object x=(VFUN_NARGS=-3,FFN(fSaset)(val,array,cursor)); RETURN1(x); } void gcl_init_array_function(void) { make_function("ARRAY-DISPLACEMENT", Larray_displacement); } gcl-2.7.1/o/PaxHeaders/predicate.c0000644000000000000000000000013214722425025013711 xustar0030 mtime=1732913685.426115449 30 atime=1744340055.684934165 30 ctime=1744351535.458909434 gcl-2.7.1/o/predicate.c0000644000175000017500000003136114722425025013313 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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.h" DEFUN("NULL",object,fLnull,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(x==Cnil ? Ct : Cnil); } DEFUN("NOT",object,fLnot,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(x==Cnil ? Ct : Cnil); } DEFUN("SYMBOLP",object,fLsymbolp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_symbol ? Ct : Cnil); } DEFUN("ATOM",object,fLatom,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(!consp(x) ? Ct : Cnil); } DEFUN("CONSP",object,fLconsp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(consp(x) ? Ct : Cnil); } DEFUN("LISTP",object,fLlistp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(listp(x) ? Ct : Cnil); } DEFUN("NUMBERP",object,fLnumberp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(numberp(x) ? Ct : Cnil); } DEFUN("INTEGERP",object,fLintegerp ,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(integerp(x) ? Ct : Cnil); } DEFUN("RATIONALP",object,fLrationalp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(rationalp(x) ? Ct : Cnil); } DEFUN("REALP",object,fLrealp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(realp(x) ? Ct : Cnil); } DEFUN("FLOATP",object,fLfloatp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(floatp(x) ? Ct : Cnil);} DEFUN("COMPLEXP",object,fLcomplexp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_complex ? Ct : Cnil); } DEFUN("CHARACTERP",object,fLcharacterp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_character ? Ct : Cnil); } DEFUN("STRINGP",object,fLstringp ,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(stringp(x) ? Ct : Cnil); } DEFUN("BIT-VECTOR-P",object,fLbit_vector_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(TS_MEMBER(type_of(x),TS(t_bitvector)|TS(t_simple_bitvector)) ? Ct : Cnil); } DEFUN("VECTORP",object,fLvectorp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(vectorp(x) ? Ct : Cnil); } DEFUN("SIMPLE-STRING-P",object,fLsimple_string_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLstringp)(x)); } DEFUN("SIMPLE-BIT-VECTOR-P",object,fLsimple_bit_vector_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLbit_vector_p)(x)); } DEFUN("SIMPLE-VECTOR-P",object,fLsimple_vector_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(FFN(fLvectorp)(x)==Ct && (enum aelttype)x->v.v_elttype==aet_object ? Ct : Cnil); } DEFUN("ARRAYP",object,fLarrayp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(arrayp(x) ? Ct : Cnil); } DEFUN("PACKAGEP",object,fLpackagep,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_package ? Ct : Cnil); } DEFUN("FUNCTIONP",object,fLfunctionp,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(functionp(x) ? Ct : Cnil); } #ifdef STATIC_FUNCTION_POINTERS object fLfunctionp(object x) { return FFN(fLfunctionp)(x); } #endif DEFUN("LOGICAL-PATHNAME-P",object,fSlogical_pathname_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_pathname && x->d.tt ? Ct : Cnil); } DEFUN("COMPILED-FUNCTION-P",object,fLcompiled_function_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_function ? Ct : Cnil); } DEFUN("GENERIC-FUNCTION-P",object,fSgeneric_function_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_function && x->d.tt==1 ? Ct : Cnil); } DEFUN("SET-D-TT",object,fSset_d_tt_p,SI,2,2,NONE,OI,OO,OO,OO,(fixnum x,object y),"") { y->d.tt=x; RETURN1(y); } DEFUN("COMMONP",object,fScommonp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x) != t_spice ? Ct : Cnil); } DEFUN("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 eql_is_eq and d.t == */ switch (x->d.t) { eqlm(x,y); } } /*for sublis1-inline*/ bool oeql(object x,object y) { return eql(x,y) ? TRUE : FALSE; } DEFUN("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) { enum type tx,ty; /*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; #define BASE_T(a_) ({enum type _t=(a_)->d.t;\ _t==t_simple_string ? t_string : (_t==t_simple_bitvector ? t_bitvector : _t);}) if ((tx=BASE_T(x))!=(ty=BASE_T(y))) return FALSE; #undef BASE_T switch(tx) { case t_string: return(string_eq(x, y)); case t_bitvector: { fixnum i, ox, oy; if (VLEN(x) != VLEN(y)) return(FALSE); ox = x->bv.bv_offset; oy = y->bv.bv_offset; if (!ox && !oy) { for (i=0;ibv.bv_self[i]!=y->bv.bv_self[i]) return(FALSE); if (VLEN(x)%BV_BITS) { #ifdef WORDS_BIGENDIAN ufixnum m=(~0L<<(BV_BITS-(VLEN(x)%BV_BITS))); #else ufixnum m=(~(~0L<<(VLEN(x)%BV_BITS))); #endif if ((x->bv.bv_self[i]&m)!=(y->bv.bv_self[i]&m)) return(FALSE); } return(TRUE); } for (i=0;id.t!=t_pathname) return(FALSE); 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); } } DEFUN("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 /*for sublis1-inline*/ bool oequal(object x,object y) { return equal(x,y) ? TRUE : FALSE; } 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; #define BASE_T(a_) ({object _t=(a_);\ numberp(_t) ? t_fixnum : (vectorp(_t) ? t_vector : _t->d.t);}) if ((tx=BASE_T(x))!=(ty=BASE_T(y))) return FALSE; #undef BASE_T switch(tx) { case t_fixnum: return(!number_compare(x, y)); case t_array: if (x->a.a_rank!=y->a.a_rank) return FALSE; if (x->a.a_rank>1 && memcmp(x->a.a_dims,y->a.a_dims,x->a.a_rank*sizeof(*x->a.a_dims))) return FALSE; case t_vector: if ((j=VLEN(x))!=VLEN(y)) return FALSE; { fixnum i; for (i = 0; i < j; i++) if (!equalp(aref(x, i), aref(y, i))) return(FALSE); } return(TRUE); 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 cons *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].c_cdr==OBJNULL) continue; if ((e=gethash(x->ht.ht_self[i].c_cdr,y))->c_cdr==OBJNULL ||!equalp(x->ht.ht_self[i].c_car,e->c_car)) 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); } } /*for sublis1-inline*/ bool oequalp(object x,object y) { return equalp(x,y) ? TRUE : FALSE; } DEFUN("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||tx==t_simple_vector) { int i; if (x->v.v_elttype==aet_object) for (i = 0; i < VLEN(x); 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("CONTAINS-SHARP-COMMA",object,fScontains_sharp_comma,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { RETURN1(contains_sharp_comma(x0) ? Ct : Cnil); } DEFUN("SPICEP",object,fSspicep,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { RETURN1(type_of(x0)==t_spice ? Ct : Cnil); } DEFUN("FIXNUMP",object,fSfixnump,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { RETURN1(type_of(x0)==t_fixnum ? Ct : Cnil); } void gcl_init_predicate_function(void) { sLand=make_special_form("AND",Fand); sLor=make_special_form("OR",For); } gcl-2.7.1/o/PaxHeaders/conditional.c0000644000000000000000000000013114555557372014272 xustar0029 mtime=1706483450.80039273 30 atime=1744339816.139420896 30 ctime=1744351535.458909434 gcl-2.7.1/o/conditional.c0000644000175000017500000000751714555557372013703 0ustar00cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 (!consp(clause)) 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 (!consp(clause)) FEerror("~S is an illegal CASE clause.",1,clause); key = MMcar(clause); conseq = MMcdr(clause); if (consp(key)) 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.7.1/o/PaxHeaders/gmp_wrappers.c0000644000000000000000000000013214542551763014470 xustar0030 mtime=1703597043.312022915 30 atime=1744339829.143502085 30 ctime=1744351535.482909218 gcl-2.7.1/o/gmp_wrappers.c0000644000175000017500000000012114542551763014060 0ustar00cammcammint jmp_gmp=0; #define GMP_EXTERN #define GMP_EXTERN_INLINE #include "include.h" gcl-2.7.1/o/PaxHeaders/cmac.c0000644000000000000000000000013114555557372012672 xustar0029 mtime=1706483450.80039273 30 atime=1744339822.123458241 30 ctime=1744351535.586908286 gcl-2.7.1/o/cmac.c0000644000175000017500000001063214555557372012273 0ustar00cammcamm/* Copyright (C) 2024 Camm Maguire */ #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("CMOD",object,fScmod,SI,1,1,NONE,OO,OO,OO,OO,(object num),"") { num=cmod(num); RETURN1(num); } DEFUN("CPLUS",object,fScplus,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { x0 = cplus(x0,x1); RETURN1( x0 ); } DEFUN("CTIMES",object,fSctimes,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { x0=ctimes(x0,x1); RETURN1(x0); } DEFUN("CDIFFERENCE",object,fScdifference,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { x0=cdifference(x0,x1); RETURN1(x0); } void gcl_init_cmac(void) { gclModulus = (&((make_si_special("MODULUS",Cnil))->s.s_dbind)); } gcl-2.7.1/o/PaxHeaders/print.d0000644000000000000000000000013114734562225013114 xustar0030 mtime=1735582869.181484623 29 atime=1744340056.10093682 30 ctime=1744351535.578908358 gcl-2.7.1/o/print.d0000644000175000017500000014764114734562225012530 0ustar00cammcamm/* -*-C-*- */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa Copyright (C) 2024 Camm Maguire 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 */ /* hacked by Michael Koehne (c) GNU LGPL * kraehe (at) copyleft.de * Sun Apr 25 07:43:08 CEST 2004 * * beware of new bugs^h^h^h^h features ! * * many thanks to pfdietz - not only for ircing at #lisp to explain a * few bits to me, but even more for writing the ansi-test. This hack * would never been possible without his regression test ! * ------------------------------------------------------------------------- */ #define NEED_ISFINITE #include "include.h" #include #include "num_include.h" #define MINIMUM_RIGHT_MARGIN 1 #define DEFAULT_RIGHT_MARGIN 72 #define PRINTreadably (sLAprint_readablyA->s.s_dbind != Cnil) #define PRINTescape (PRINTreadably || (sLAprint_escapeA->s.s_dbind != Cnil)) #define PRINTpretty (sLAprint_prettyA->s.s_dbind != Cnil) #define PRINTcircle (sLAprint_circleA->s.s_dbind != Cnil) #define PRINTarray (PRINTreadably || (sLAprint_arrayA->s.s_dbind != Cnil)) #define PRINTgensym (PRINTreadably || (sLAprint_gensymA->s.s_dbind != Cnil)) #define PRINTradix (sLAprint_radixA->s.s_dbind != Cnil) #define PRINTpackage (sSAprint_packageA->s.s_dbind != Cnil) #define PRINTstructure (sSAprint_structureA->s.s_dbind != Cnil) #define PRINTbase fixint(sLAprint_baseA->s.s_dbind) #define PRINTcase sLAprint_caseA->s.s_dbind #define PRINTlevel (PRINTreadably || sLAprint_levelA->s.s_dbind==Cnil || type_of(sLAprint_levelA->s.s_dbind)!=t_fixnum ? -1 : fix(sLAprint_levelA->s.s_dbind)) #define PRINTlength (PRINTreadably || sLAprint_lengthA->s.s_dbind==Cnil || type_of(sLAprint_lengthA->s.s_dbind)!=t_fixnum ? -1 : fixint(sLAprint_lengthA->s.s_dbind)) #define PRINTlines (PRINTreadably || sLAprint_linesA->s.s_dbind==Cnil || type_of(sLAprint_linesA->s.s_dbind)!=t_fixnum ? -1 : fixint(sLAprint_linesA->s.s_dbind)) DEFVAR("*PRINT-CONTEXT*",sSAprint_contextA,SI,make_fixnum(0),""); DEFVAR("*PRINT-CONTEXT-HEAD*",sSAprint_context_headA,SI,make_fixnum(0),""); #define Q_SIZE 256 #define IS_SIZE 256 struct printStruct { unsigned short p_queue[Q_SIZE]; unsigned short p_indent_stack[IS_SIZE]; int p_qh; int p_qt; int p_qc; int p_isp; int p_iisp; int p_lb; int p_col; int p_sn; int p_ll; }; struct printContext { struct printContext *next; struct printContext *pp; object s,h; void (*write_ch_fun)(int,void *); int (*write_stream_fun)(int,object); int ll,ms; struct printStruct b; }; struct printContextshort { struct printContext *next; struct printContext *pp; object s,h; void (*write_ch_fun)(int,void *); int (*write_stream_fun)(int,object); }; struct printContext * lookup_print_context(object strm) { struct printContext *p=(void *)fix(sSAprint_context_headA->s.s_dbind); for (;p && p->s!=strm;p=p->next); return p; } /* object y=output_stream(_y); \ */ /* pp->write_stream_fun=writec_stream_fun(y); \ */ #define SETUP_PRINT_DEFAULT(_x,_y,_z,_s) \ bds_ptr old_bds_top=bds_top; \ struct printContext *p,*pp=lookup_print_context(_y); \ pp=pp ? pp : ZALLOCA(sizeof(struct printContextshort)); \ if (!pp->s) { \ pp->s=_y; \ pp->h=((PRINTcircle&&!_s) ? setupPRINTcircle1(_x,1) : Cnil); \ pp->write_ch_fun=writec_PRINTstream; \ pp->write_stream_fun=writec_stream; \ pp->next=(void *)fix(sSAprint_context_headA->s.s_dbind); \ bds_bind(sSAprint_context_headA,make_fixnum((fixnum)(void *)pp)); \ } \ p=(!PRINTpretty || _s || pp->write_ch_fun==writec_queue)&&_z ? \ pp : ZALLOCA(sizeof(*p)); \ if (!p->s) { \ p->s=_y; \ p->pp=pp; \ p->h=pp->h; \ p->write_ch_fun=writec_queue; \ p->b.p_col=file_column(_y); \ p->b.p_ll=get_line_length(); \ p->ms=get_miser_style(p->b.p_col,p->b.p_ll); \ p->next=(void *)fix(sSAprint_context_headA->s.s_dbind); \ bds_bind(sSAprint_context_headA,make_fixnum((fixnum)(void *)p)); \ } \ bds_bind(sSAprint_contextA,make_fixnum((fixnum)(void *)p)) \ #define CLEANUP_PRINT_DEFAULT() \ bds_unwind(old_bds_top); \ if (p!=pp) \ flush_queue(TRUE,p) \ void write_ch_fun(int c) { struct printContext *p=(struct printContext *)(void *)fix(sSAprint_contextA->s.s_dbind); p->write_ch_fun(c,p); } #define DONE 1 #define FOUND -1 #define write_ch (*write_ch_fun) static void write_decimal1(int); static void write_decimal(i) int i; { if (i == 0) { write_ch('0'); return; } write_decimal1(i); } static int do_write_sharp_eq(struct cons *e,bool dot) { fixnum val=fix(e->c_car); bool defined=val&1; if (dot) { write_str(" . "); if (!defined) return FOUND; } if (!defined) e->c_car=make_fixnum(val|1); write_ch('#'); write_decimal(val>>1); write_ch(defined ? '#' : '='); return defined ? DONE : FOUND; } static int write_sharp_eq1(object x,bool dot,object h) { struct cons *e; return h!=Cnil && (e=gethash(x,h))->c_cdr!=OBJNULL ? do_write_sharp_eq(e,dot) : 0; } int write_sharp_eq(object x,bool dot) { struct printContext *p=(struct printContext *)(void *)fix(sSAprint_contextA->s.s_dbind); return write_sharp_eq1(x,dot,p->h); } static void per_line_prefix_context(struct printContext *p) { int i; if (stringp(sSAprint_line_prefixA->s.s_dbind)) for (i=0;is.s_dbind);i++) p->write_ch_fun(sSAprint_line_prefixA->s.s_dbind->st.st_self[i],p); } #define READ_TABLE_CASE (Vreadtable->s.s_dbind->rt.rt_case) #define mod(x) ((x)%Q_SIZE) object sSAprint_packageA; object sSAprint_structureA; #define MARK 0400 #define UNMARK 0401 #define LINEAR 0406 #define MISER 0407 #define FILL 0410 #define MANDATORY 0411 #define CURRENT 0412 #define BLOCK 0413 #define LINE 0414 #define SECTION 0415 #define LINE_RELATIVE 0416 #define SECTION_RELATIVE 0417 #define CONTINUATION 0x8000 extern object coerce_stream(object,int); DEFVAR("*PRINT-LINE-PREFIX*",sSAprint_line_prefixA,SI,Cnil,""); void writec_PRINTstream(int c,void *v) { struct printContext *p=v; p->write_stream_fun(c,p->s); } static int dgs,dga; static fixnum mlen,mlev; #include "page.h" static void travel_push(object x,fixnum lev,fixnum len) { int i; if (is_imm_fixnum(x)) return; if (lev>=mlev||len>=mlen) 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,lev+1,0); travel_push(y,lev,len+1); } break; case t_vector: case t_array: case t_string: case t_bitvector: case t_simple_vector: case t_simple_array: case t_simple_string: case t_simple_bitvector: 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],lev+1,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),lev+1,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: case t_simple_vector: case t_simple_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,fixnum lev,fixnum len) { BEGIN_NO_INTERRUPT; dgs=mdgs; dga=mdga; mlev=lev; mlen=len; travel_push(x,0,0); travel_clear(x); END_NO_INTERRUPT; } object sLeq; static object setupPRINTcircle1(object x,int dogensyms) { object *vp=vs_top,*v=vp,h; fixnum j; travel(x,dogensyms,PRINTarray, PRINTlevel>=0 ? PRINTlevel : ARRAY_DIMENSION_LIMIT, PRINTlength>=0 ? PRINTlength : ARRAY_DIMENSION_LIMIT); h=vs_top>vp ? gcl_make_hash_table(sLeq) : Cnil; for (j=0;vc_cdr==OBJNULL) sethash(*v,h,make_fixnum((++j)<<1)); vs_top=vp; return h; } static int get_miser_style(int col,int ll) { object o=symbol_value(sLAprint_miser_widthA); return o!=Cnil && col>=(ll-fixint(o)); } static ushort flush_queue_tab_nspaces(ushort c,ushort num,ushort inc,ushort pos,ushort s) { num<<=1;num>>=1;inc<<=1;inc>>=1; switch (c) { case LINE_RELATIVE: num+=pos; num+=(inc && num%inc) ? inc-(num%inc) : 0; break; case SECTION_RELATIVE: num+=pos-s; num+=(inc && num%inc) ? inc-(num%inc) : 0; num+=s; break; case SECTION: num+=s; case LINE: while (num<=pos) if (inc) num+=inc; else break; break; } return num>=pos ? num-pos : 0; } static int flush_queue_flush(int force,int i,struct printContext *p) { int j,c; for (j=0;jb.p_queue[p->b.p_qh]; if (c==' ') p->b.p_lb++; else if (c==LINE||c==SECTION||c==LINE_RELATIVE||c==SECTION_RELATIVE) p->b.p_lb+=flush_queue_tab_nspaces(c,p->b.p_queue[mod(p->b.p_qh+1)],p->b.p_queue[mod(p->b.p_qh+2)], p->b.p_col+p->b.p_lb,p->b.p_indent_stack[p->b.p_isp-1]); else if (c<0400) { for (;p->b.p_lb;p->b.p_lb--) { p->pp->write_ch_fun(' ',p->pp); p->b.p_col++; } p->pp->write_ch_fun(c,p->pp); p->b.p_col=c=='\n' ? 0 : (c=='\t' ? (p->b.p_col&-07)+8 : p->b.p_col+1); p->b.p_sn=c=='\n' || p->b.p_sn; if (!p->b.p_col) per_line_prefix_context(p->pp); } p->b.p_qh = mod(p->b.p_qh+1); --p->b.p_qc; } if (!p->b.p_qc) for (;p->b.p_lb;p->b.p_lb--) p->pp->write_ch_fun(' ',p->pp); return 0; } static int flush_queue_put_indent(int force,struct printContext *p) { p->pp->write_ch_fun('\n',p->pp); p->b.p_col=0; p->b.p_sn=0; per_line_prefix_context(p->pp); p->b.p_lb=p->b.p_indent_stack[p->b.p_isp]; p->b.p_iisp = p->b.p_isp; p->b.p_qh = mod(p->b.p_qh+1); --p->b.p_qc; return 0; } static int flush_queue_proc(struct printContext *p,int i,int *l,int *i0,int *j,int *nb) { ushort c,s=p->b.p_indent_stack[p->b.p_isp-1]; switch((c=p->b.p_queue[mod(p->b.p_qh+i)])) { case MARK: (*l)++;return 0; case UNMARK: if (--(*l) == 0) *i0=i;return (*l==0); case FILL: if (*l==1) *i0=i;return 0; case MANDATORY: case LINEAR:if (*l==1) *i0=i;return (*l == 1); case LINE:case SECTION:case LINE_RELATIVE:case SECTION_RELATIVE: (*nb)+=flush_queue_tab_nspaces(c,p->b.p_queue[mod(p->b.p_qh+i+1)],p->b.p_queue[mod(p->b.p_qh+i+2)],*j,s); return 0; case ' ':(*nb)++;return 0; default: if (c < 0400) {(*j)+=1+*nb;*nb=0;} return 0; } } static int flush_queue_indent(int force,struct printContext *p) { int i,j,k,l,i0,nb; if (p->b.p_iisp > p->b.p_isp) return flush_queue_put_indent(force,p); k = p->b.p_ll-1; for (i0=0,j=p->b.p_col,nb=p->b.p_lb,l=1,i=1;ib.p_qc && j<=k;i++) if (flush_queue_proc(p,i,&l,&i0,&j,&nb)) break; if (i == p->b.p_qc && !force) return 1; if (i0 && !p->b.p_sn && p->b.p_queue[mod(p->b.p_qh)]==FILL) return flush_queue_flush(force,i0,p); return flush_queue_put_indent(force,p); } static int flush_queue_mark(int force,struct printContext *p) { int i,j,k,l,c; k = p->b.p_ll - 1 - p->b.p_col; for (i=l=1,j=p->b.p_lb;l>0 && ib.p_qc && jb.p_queue[mod(p->b.p_qh + i)]; if (c=='\n' || c==MANDATORY || c==LINE || c==SECTION || c==LINE_RELATIVE || c==SECTION_RELATIVE) break; switch(c) { case MARK:l++;break; case UNMARK:--l;break; default: if (c<0400) j++;break; } } if (l == 0 && c!='\n' && c!=MANDATORY && c!=LINE && c!=SECTION && c!=LINE_RELATIVE && c!=SECTION_RELATIVE) return flush_queue_flush(force,i,p); if (i == p->b.p_qc && !force) return 1; if (++p->b.p_isp >= IS_SIZE-1) FEerror("Can't pretty-print.", 0); p->b.p_indent_stack[p->b.p_isp++] = p->b.p_col+p->b.p_lb; p->b.p_indent_stack[p->b.p_isp] = p->b.p_indent_stack[p->b.p_isp-1]; return flush_queue_flush(force,1,p); } static void flush_queue(int force,struct printContext *p) { int c; if (!p->b.p_col) per_line_prefix_context(p->pp); while (p->b.p_qc > 0) { switch ((c = p->b.p_queue[p->b.p_qh])) { case MARK: if (flush_queue_mark(force,p)) return; break; case UNMARK: p->b.p_isp -= 2; flush_queue_flush(force,1,p); break; case FILL: case LINEAR:case MANDATORY: if (flush_queue_indent(force,p)) return; break; case CURRENT: case BLOCK: { short sh=p->b.p_queue[mod(p->b.p_qh+1)]; if (p->b.p_qc<2) return; sh<<=1;sh>>=1; sh+=(c==CURRENT ? p->b.p_col : p->b.p_indent_stack[p->b.p_isp-1]);/*lb*/ sh=sh<0 ? 0 : sh; p->b.p_indent_stack[p->b.p_isp] = sh; flush_queue_flush(force,2,p); break; } case LINE:case SECTION:case LINE_RELATIVE:case SECTION_RELATIVE: if (p->b.p_qc<3) return; flush_queue_flush(force,3,p); break; default: flush_queue_flush(force,1,p); break; } } flush_queue_flush(force,0,p); } static void writec_queue(int c,void *v) { struct printContext *p=v; struct printStruct *b=&p->b; if (b->p_qc >= Q_SIZE) flush_queue(FALSE,p); if (b->p_qc >= Q_SIZE) FEerror("Can't pretty-print.", 0); b->p_queue[b->p_qt] = c; b->p_qt = mod(b->p_qt+1); b->p_qc++; } void write_str(s) char *s; { while (*s != '\0') write_ch(*s++); } 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 = CHAR_SIZE*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; static int char_inc(char *b,char *p) { if (b==p) { *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_) \ ({fixnum _r; \ BLOCK_EXCEPTIONS(_r=((d_) ? strtod((a_),(b_))==(c_) : strtof((a_),(b_))==(float)(c_))); \ _r;}) 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,strlen(p)+1); 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 (1 /* sSAprint_nansA->s.s_dbind !=Cnil */) { sprintf(s, "%e",d); *sp=2; return; } } 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(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(object x,int level) { struct printContext *p=(struct printContext *)(void *)fix(sSAprint_contextA->s.s_dbind); ifuncall3(S_DATA(x->str.str_def)->print_function,x,p->s,make_fixnum(level)); } object copy_big(); object coerce_big_to_string(object,int); extern object cLtype_of(object); static bool potential_number_p(object,int); DEF_ORDINARY("PPRINT-DISPATCH",sLpprint_dispatch,LISP,""); DEF_ORDINARY("DEFAULT-PPRINT-OBJECT",sSdefault_pprint_object,SI,""); object print(object obj,object strm) { terpri(strm); prin1(obj,strm); princ(code_char(' '),strm); return(obj); } object terpri(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_pstream('\n',strm); return(Cnil); } static int get_line_length(void) { int l=0; object o=symbol_value(sLAprint_right_marginA); if ((o!=Cnil) && (type_of(o)==t_fixnum)) l=fix(o); if (lst.st_self[b++]); CLEANUP_PRINT_DEFAULT(); } void write_string_pstream(object str,object strm) { write_bounded_string_pstream(str,0,VLEN(str),strm); } void write_string(object strng,object strm) { 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); write_string_pstream(strng,strm); flush_stream(strm); } void princ_str(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_pstream(s, sym); } void princ_char(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); writec_pstream(c,sym); } void pp(object x) { princ(x,Cnil); flush_stream(symbol_value(sLAstandard_outputA)); } static int constant_case(object x) { fixnum i,j=0,jj; for (i=0;ist.st_self[i]) ? 1 : (isLower(x->st.st_self[i]) ? -1 : 0); if (j*jj==-1) return 0; } return j; } static int needs_escape (object x) { fixnum i,all_dots=1; unsigned char ch; for (i=0;ist.st_self[i])) { case ' ': case '#': case '(': case ')': case ':': case '`': case '\'': case '"': case ';': case ',': case '\n': return 1; case '.': break; default: all_dots=0; if (Vreadtable->s.s_dbind->rt.rt_self[ch].rte_chattrib!=cat_constituent) return 1; break; } if (all_dots) return 1; if (READ_TABLE_CASE==sKupcase || PRINTreadably) { for (i=0;ist.st_self[i])) return 1; } else if (READ_TABLE_CASE==sKdowncase) { for (i=0;ist.st_self[i])) return 1; } if (potential_number_p(x, PRINTbase)) return 1; return !VLEN(x); } #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 pp) { int i,j,fc,tc,lw,k,cc; cc=constant_case(x); k=needs_escape(x); k=PRINTescape ? k : 0; pp=k&&pp ? 0 : 1; if (k) write_ch('|'); for (lw=i=0;ist.st_self[i]; if (PRINTescape && (j == '|' || j == '\\')) 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; tc*=pp*fc*fc; fc=tc*tc*(tc-fc)>>1; j+=fc*('A'-'a'); write_ch(j); } if (k) write_ch('|'); } static int write_level(void) { return type_of(sSAprin_levelA->s.s_dbind)==t_fixnum ? fix(sSAprin_levelA->s.s_dbind) : 0; } static void write_object(object x,int level) { object r, y; fixnum i, j, k; cs_check(x); if (x == OBJNULL) { write_unreadable_str(x,"#"); return; } if (is_free(x)) { write_unreadable_str(x,"#"); return; } switch (type_of(x)) { case t_fixnum: { object *vsp; if (PRINTradix && PRINTbase != 10) write_base(); i = fix(x); if (i == 0) { write_ch('0'); if (PRINTradix && PRINTbase == 10) write_ch('.'); break; } vsp = vs_top; if (i < 0) { write_ch('-'); if (i == MOST_NEGATIVE_FIX) { vs_push(code_char(digit_weight(labs(i%PRINTbase),PRINTbase))); i/=PRINTbase; } i = -i; } for (;i;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_self[i++]); } } if (PRINTradix && PRINTbase == 10) write_ch('.'); break; } case t_ratio: if (PRINTradix) { write_base(); bds_bind(sLAprint_radixA,Cnil); write_object(x->rat.rat_num, level); write_ch('/'); write_object(x->rat.rat_den, level); bds_unwind1; } 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(" "); /* 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); if (char_code(x)==28) write_ch(char_code(x) + 0100); } else write_ch(char_code(x)); break; } break; case t_symbol: { object y=vs_head; y=y!=OBJNULL && consp(y) && y->c.c_car==sSstructure_list ? y->c.c_cdr: Cnil; for (;consp(y) && y->c.c_car!=x;y=y->c.c_cdr); if (PRINTescape || consp(y)) { if (x->s.s_hpack == Cnil || x->s.s_hpack->p.p_name==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,1); 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->s.s_name,1); break; } case t_array: case t_simple_array: { int subscripts[ARRAY_RANK_LIMIT]; int n, m; if (!PRINTarray) { write_unreadable_str(x,"#"); break; } else if (x->v.v_elttype!=aet_object) write_unreadable_str(x,""); 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) { if (PRINTpretty) write_ch(MARK); write_ch('('); if (PRINTpretty) {write_ch(CURRENT);write_ch(CONTINUATION);} if (x->a.a_dims[i] == 0) { write_ch(')'); if (PRINTpretty) write_ch(UNMARK); j = i-1; k = 0; if (PRINTreadably) PRINT_NOT_READABLE(x,"Array has a zero dimension."); goto INC; } } if (subscripts[i] > 0) { write_ch(' '); if (PRINTpretty) write_ch(FILL); } if (PRINTlength >= 0 && subscripts[i] >= PRINTlength) { write_str("...)"); if (PRINTpretty) 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(')'); if (PRINTpretty) write_ch(UNMARK); --j; } if (j < 0) break; m += k; } break; } case t_vector: case t_simple_vector: if (!PRINTarray) { write_unreadable_str(x,"#"); break; } else if (x->v.v_elttype!=aet_object) write_unreadable_str(x,""); if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (PRINTlevel >= 0 && level >= PRINTlevel) { write_ch('#'); break; } write_ch('#'); if (PRINTpretty) write_ch(MARK); write_ch('('); if (PRINTpretty) {write_ch(CURRENT);write_ch(CONTINUATION);} if (VLEN(x) > 0) { if (PRINTlength == 0) { write_str("...)"); if (PRINTpretty) write_ch(UNMARK); break; } vs_push(aref(x, 0)); write_object(vs_head, level+1); vs_popp; for (i = 1; i < VLEN(x); i++) { write_ch(' '); if (PRINTpretty) write_ch(FILL); if (PRINTlength>=0 && i>=PRINTlength){ write_str("..."); break; } vs_push(aref(x, i)); write_object(vs_head, level+1); vs_popp; } } write_ch(')'); if (PRINTpretty) write_ch(UNMARK); break; case t_simple_string: case t_string: if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (!PRINTescape) { for (i = 0; i < VLEN(x); i++) write_ch((uchar)x->st.st_self[i]); break; } write_ch('"'); for (i = 0; i < VLEN(x); i++) { if (x->st.st_self[i] == '"' || x->st.st_self[i] == '\\') write_ch('\\'); write_ch((uchar)x->st.st_self[i]); } write_ch('"'); break; case t_bitvector: case t_simple_bitvector: if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (!PRINTarray) { write_unreadable_str(x,"#"); break; } write_str("#*"); for (i = x->bv.bv_offset; i < VLEN(x) + x->bv.bv_offset; i++) write_ch(BITREF(x,i) ? '1' : '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 && consp(x->c.c_cdr) && 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 && consp(x->c.c_cdr) && 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; } if (PRINTpretty) write_ch(MARK); write_ch('('); if (PRINTpretty) {write_ch(CURRENT);write_ch(CONTINUATION);} 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 (!x || !consp(x)) { if (x != Cnil) { write_ch(' '); if (PRINTpretty) write_ch(FILL); 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; } write_ch(' '); if (PRINTpretty) write_ch(i==0 && y!=OBJNULL && type_of(y)==t_symbol ? LINEAR : FILL); } RIGHT_PAREN: write_ch(')'); if (PRINTpretty) 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 (!consp(x)) { if (x != Cnil) { write_ch(' '); if (PRINTpretty) write_ch(FILL); write_str(". "); write_object(x, level); } break; } write_ch(' '); if (PRINTpretty) write_ch(i>=j ? MANDATORY : (!i ? LINEAR : FILL)); } goto RIGHT_PAREN; case t_package: write_unreadable_str(x,"#<"); write_object(x->p.p_name, level); write_str(" package>"); break; case t_hashtable: write_unreadable_str(x,"#"); break; case t_stream: switch (x->sm.sm_mode) { case smm_input: write_unreadable_str(x,"#sm.sm_object1, level); write_ch('>'); break; case smm_output: write_unreadable_str(x,"#sm.sm_object1, level); write_ch('>'); break; case smm_io: write_unreadable_str(x,"#sm.sm_object1, level); write_ch('>'); break; case smm_socket: write_unreadable_str(x,"#sm.sm_object0, level); write_ch('>'); break; case smm_probe: write_unreadable_str(x,"#sm.sm_object1, level); write_ch('>'); break; case smm_file_synonym: case smm_synonym: write_unreadable_str(x,"#sm.sm_object0, level); write_ch('>'); break; case smm_broadcast: write_unreadable_str(x,"#"); break; case smm_concatenated: write_unreadable_str(x,"#"); break; case smm_two_way: write_unreadable_str(x,"#"); break; case smm_echo: write_unreadable_str(x,"#"); break; case smm_string_input: write_unreadable_str(x,"#sm.sm_object0; if (y!=OBJNULL) { write_str(" from \""); j = VLEN(y); for (i = 0; i < j && i < 16; i++) write_ch(y->st.st_self[i]); if (j > 16) write_str("..."); } else write_str("(closed)"); write_str("\">"); break; #ifdef USER_DEFINED_STREAMS case smm_user_defined: write_unreadable_str(x,"#"); break; #endif case smm_string_output: write_unreadable_str(x,"#"); 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: { object y=structure_to_list(x); if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (y->c.c_cdr==Cnil) {/*FIXME: Where is this specified?*/ write_str("#S("); print_symbol_name_body(y->c.c_car->s.s_name,1); write_ch(')'); break; } 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 (S_DATA(x->str.str_def)->print_function != Cnil) { call_structure_print_function(x, level); break; } if (PRINTstructure) { write_str("#S"); vs_push(MMcons(sSstructure_list,y));/*FIXME alloc etc.*/ write_object(y, level); vs_popp; break; } break; } case t_readtable: write_unreadable_str(x,"#"); break; case t_pathname: if (PRINTreadably && x->pn.pn_version!=Cnil && x->pn.tt==0) { write_str("#.(MAKE-PATHNAME "); write_str(" :HOST ");write_object(x->pn.pn_host,level); write_str(" :DEVICE ");write_object(x->pn.pn_device,level); write_str(" :DIRECTORY '");write_object(x->pn.pn_directory,level); write_str(" :NAME ");write_object(x->pn.pn_name,level); write_str(" :TYPE ");write_object(x->pn.pn_type,level); write_str(" :VERSION ");write_object(x->pn.pn_version,level); write_str(")"); break; } /* PRINT_NOT_READABLE(x,"Physical pathname has non-nil version."); */ if (PRINTescape) { write_ch('#'); write_ch('P'); vs_push(x->pn.pn_namestring); write_object(vs_head, level); vs_popp; } else { vs_push(x->pn.pn_namestring); write_object(vs_head, level); vs_popp; } break; case t_function: write_unreadable_str(x,"#"); break; case t_spice: write_unreadable_str(x,"#<\100"); for (i = CHAR_SIZE*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"); } } void write_object_pstream(object obj,object strm) { object ppfun; SETUP_PRINT_DEFAULT(obj,strm,1,0); if (PRINTpretty && sLAprint_pprint_dispatchA->s.s_dbind->c.c_cdr!=Cnil && (ppfun=ifuncall1(sLpprint_dispatch,obj))!=Cnil && ppfun!=sSdefault_pprint_object) { ifuncall2(ppfun,p->s,obj); } else write_object(obj, write_level()); CLEANUP_PRINT_DEFAULT(); } object princ(object obj,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); bds_bind(sLAprint_readablyA,Cnil); bds_bind(sLAprint_escapeA,Cnil); write_object_pstream(obj,strm); bds_unwind1; bds_unwind1; return(obj); } object prin1(object obj,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); bds_bind(sLAprint_escapeA,Ct); write_object_pstream(obj,strm); bds_unwind1; flush_stream(strm); return(obj); } void travel_find_sharing(object x,object table) { object *vp=vs_top; travel(x,1,1,ARRAY_DIMENSION_LIMIT,ARRAY_DIMENSION_LIMIT); for (;vs_top>vp;vs_top--) sethash(vs_head,table,make_fixnum(-2)); } static bool potential_number_p(strng, base) object strng; int base; { int i, l, c, dc; char *s; l = VLEN(strng); 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-CH",object,fSwrite_ch,SI,1,1,NONE,OI,OO,OO,OO,(fixnum x),"") { write_ch(x); RETURN1(Cnil); } DEFUN("WRITE-INT",object,fSwrite_int,SI,2,2,NONE,OO,OO,OO,OO,(object x,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); write_object_pstream(x,strm); flush_stream(strm); RETURN1(x); } #ifdef STATIC_FUNCTION_POINTERS object fSwrite_int(object x,object y) { return FFN(fSwrite_int)(x,y); } #endif DEFUN("PPRINT-MISER-STYLE",object,fSpprint_miser_style,SI,1,1,NONE,OO,OO,OO,OO,(object strm),"") { struct printContext *p=lookup_print_context(strm);/*output_stream(strm)*/ RETURN1(p && p->ms ? Ct : Cnil); } static void queue_continuation(fixnum x,struct printContext *p) { short sh=x; sh<<=1;sh>>=1;sh|=CONTINUATION; p->write_ch_fun(sh,p); } static void queue_codes(object strm,fixnum code,fixnum n,fixnum c1,fixnum c2) { struct printContext *p=lookup_print_context(strm);/*output_stream(strm)*/ if (p && p->write_ch_fun==writec_queue) { p->write_ch_fun(code,p); if (n--) { queue_continuation(c1,p); if (n--) queue_continuation(c2,p); } } } void write_codes_pstream(object strm,fixnum code,fixnum nc,fixnum c1,fixnum c2) { SETUP_PRINT_DEFAULT(Cnil,strm,1,0); if (PRINTpretty) queue_codes(strm,code,nc,c1,c2); CLEANUP_PRINT_DEFAULT(); } DEFUN("PPRINT-QUEUE-CODES",object,fSpprint_queue_codes,SI,2,4,NONE,OO,IO,OO,OO,(object strm,fixnum off,...),"") { fixnum n=INIT_NARGS(2),nc=0,c1=0,c2=0; object l=Cnil,f=OBJNULL,x; va_list ap; va_start(ap,off); if ((x=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL) { c1=fixint(x); nc++; } if ((x=NEXT_ARG(n,ap,l,f,OBJNULL))!=OBJNULL) { c2=fixint(x); nc++; } va_end(ap); queue_codes(strm,off,nc,c1,c2); RETURN1(Cnil); } DEFUN("WRITE-INT1",object,fSwrite_int1,SI,5,5,NONE,OO,OO,OO,OO, (object x,object strm,object fun,object pref,object suf),"") { object s; 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); { SETUP_PRINT_DEFAULT(x,strm,0,0); if ((s=ifuncall2(pref,x,p->h))!=Cnil) { p->ms=get_miser_style(file_column(strm)+VLEN(s),p->b.p_ll); write_ch(MARK); ifuncall2(fun,x,p->h); write_ch(UNMARK); ifuncall2(suf,x,p->h); } CLEANUP_PRINT_DEFAULT(); } RETURN1(Cnil); } #ifdef STATIC_FUNCTION_POINTERS object fSwrite_int1(object a,object b,object c,object d,object e) { return FFN(fSwrite_int1)(a,b,c,d,e); } #endif @(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)`) (pprint_dispatch `symbol_value(sLAprint_pprint_dispatchA)`) (lines `symbol_value(sLAprint_linesA)`) (right_margin `symbol_value(sLAprint_right_marginA)`) (miser_width `symbol_value(sLAprint_miser_widthA)`)) @ x=FFN(fSwrite_int)(x,strm); @(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); terpri(strm); bds_bind(sLAprint_prettyA,Ct); prin1(obj,strm); bds_unwind1; @(return) @) @(defun default_pprint_object (strm obj) @ if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); bds_bind(sLAprint_prettyA,Cnil); write_object_pstream(obj,strm); bds_unwind1; @(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_pstream(char_code(c),strm); @(return c) @) @(defun write_string (strng &o strm &k start end) int s, e; @ check_type_string(&strng); 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_stream(&strm); write_bounded_string_pstream(strng,s,e,strm); flush_stream(strm); @(return strng) @) @(defun write_line (strng &o strm &k start end) int 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); get_string_start_end(strng, start, end, &s, &e); write_bounded_string_pstream(strng,s,e,strm); writec_pstream('\n',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) if (strm->sm.sm_mode==smm_broadcast && strm->sm.sm_object0==Cnil) @(return Cnil) writec_pstream('\n',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) @) DEF_ORDINARY("STRUCTURE-LIST",sSstructure_list,SI,""); DEF_ORDINARY("PPRINT-QUIT",sSpprint_quit,SI,""); DEF_ORDINARY("PPRINT-INSERT-CONDITIONAL-NEWLINES",sSpprint_insert_conditional_newlines,SI,""); DEF_ORDINARY("FORMAT-LOGICAL-BLOCK-PREFIX",sSformat_logical_block_prefix,SI,""); DEF_ORDINARY("FORMAT-LOGICAL-BLOCK-BODY",sSformat_logical_block_body,SI,""); DEF_ORDINARY("FORMAT-LOGICAL-BLOCK-SUFFIX",sSformat_logical_block_suffix,SI,""); DEF_ORDINARY("OBJECT",sKobject,KEYWORD,""); DEF_ORDINARY("LINEAR",sKlinear,KEYWORD,""); DEF_ORDINARY("MISER",sKmiser,KEYWORD,""); DEF_ORDINARY("FILL",sKfill,KEYWORD,""); DEF_ORDINARY("MANDATORY",sKmandatory,KEYWORD,""); DEF_ORDINARY("CURRENT",sKcurrent,KEYWORD,""); DEF_ORDINARY("BLOCK",sKblock,KEYWORD,""); DEF_ORDINARY("LINE",sKline,KEYWORD,""); DEF_ORDINARY("SECTION",sKsection,KEYWORD,""); DEF_ORDINARY("LINE-RELATIVE",sKline_relative,KEYWORD,""); DEF_ORDINARY("SECTION-RELATIVE",sKsection_relative,KEYWORD,""); 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("PPRINT-DISPATCH",sKpprint_dispatch,KEYWORD,""); DEF_ORDINARY("ARRAY",sKarray,KEYWORD,""); DEF_ORDINARY("LINES",sKlines,KEYWORD,""); DEF_ORDINARY("RIGHT-MARGIN",sKright_margin,KEYWORD,""); DEF_ORDINARY("MISER-WIDTH",sKmiser_width,KEYWORD,""); DEF_ORDINARY("LINEAR",sKlinear,KEYWORD,""); DEF_ORDINARY("MISER",sKmiser,KEYWORD,""); DEF_ORDINARY("FILL",sKfill,KEYWORD,""); DEF_ORDINARY("MANDATORY",sKmandatory,KEYWORD,""); DEFVAR("*PRIN-LEVEL*",sSAprin_levelA,SI,make_fixnum(0),""); DEFVAR("*PRINT-ESCAPE*",sLAprint_escapeA,LISP,Ct,""); DEFVAR("*PRINT-READABLY*",sLAprint_readablyA,LISP,Cnil,""); 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,Ct,""); DEF_ORDINARY("PRETTY-PRINT-FORMAT",sSpretty_print_format,SI,""); DEFVAR("*PRINT-NANS*",sSAprint_nansA,SI,Ct,""); DEFVAR("*PRINT-PPRINT-DISPATCH*",sLAprint_pprint_dispatchA,LISP,MMcons(Cnil,Cnil),""); DEFVAR("*PRINT-LINES*",sLAprint_linesA,LISP,Cnil,""); DEFVAR("*PRINT-MISER-WIDTH*",sLAprint_miser_widthA,LISP,Cnil,""); DEFVAR("*PRINT-RIGHT-MARGIN*",sLAprint_right_marginA,LISP,Cnil,""); DEFVAR("*READ-EVAL*",sLAread_evalA,LISP,Ct,""); void gcl_init_print(void) { } LFD(Lset_line_length)(void) { check_arg(1); if ((vs_base[0] == Cnil) || (type_of(vs_base[0]) == t_fixnum)) sLAprint_right_marginA->s.s_dbind = vs_base[0]; } 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_si_function("DEFAULT-PPRINT-OBJECT", Ldefault_pprint_object); /* KCL compatibility function */ make_si_function("SET-LINE-LENGTH",Lset_line_length); sKlinear->s.s_plist=putf(sKlinear->s.s_plist,make_fixnum(LINEAR),sLfixnum); sKmiser->s.s_plist=putf(sKmiser->s.s_plist,make_fixnum(MISER),sLfixnum); sKfill->s.s_plist=putf(sKfill->s.s_plist,make_fixnum(FILL),sLfixnum); sKmandatory->s.s_plist=putf(sKmandatory->s.s_plist,make_fixnum(MANDATORY),sLfixnum); sKcurrent->s.s_plist=putf(sKcurrent->s.s_plist,make_fixnum(CURRENT),sLfixnum); sKblock->s.s_plist=putf(sKblock->s.s_plist,make_fixnum(BLOCK),sLfixnum); sKline->s.s_plist=putf(sKline->s.s_plist,make_fixnum(LINE),sLfixnum); sKsection->s.s_plist=putf(sKsection->s.s_plist,make_fixnum(SECTION),sLfixnum); sKline_relative->s.s_plist=putf(sKline_relative->s.s_plist,make_fixnum(LINE_RELATIVE),sLfixnum); sKsection_relative->s.s_plist=putf(sKsection_relative->s.s_plist,make_fixnum(SECTION_RELATIVE),sLfixnum); } gcl-2.7.1/o/PaxHeaders/funlink.c0000644000000000000000000000013214762174251013425 xustar0030 mtime=1741224105.889132147 30 atime=1744339826.635486417 30 ctime=1744351535.478909254 gcl-2.7.1/o/funlink.c0000644000175000017500000003120614762174251013025 0ustar00cammcamm/* Copyright William Schelter. All rights reserved. Copyright 2024 Camm Maguire Fast linking method for kcl by W. Schelter University of Texas Note there are also changes to cmpcall.lsp and cmptop.lsp */ #include "include.h" #include "sfun_argd.h" #include "page.h" #if 0 #define DO_FUNLINK_DEBUG #endif #ifdef DO_FUNLINK_DEBUG void print_lisp_string ( char *boilerplate, object s ) { if ( s && VLEN(s) && s->st.st_self ) { int last = VLEN(s); int i; fprintf ( stderr, "%s", boilerplate ); for (i = 0; (i < last) && (i < 30); i++) { fputc ( s->st.st_self[i], stderr ); } fputc ( '\n', stderr ); } else { fprintf ( stderr, "Object %x not a string or empty\n", s ); } } #endif static int clean_link_array(object *,object *); object sScdefn; typedef object (*object_func)(); static int vpush_extend(void *,object); int Rset = 0; /* 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; #ifdef DO_FUNLINK_DEBUG fprintf ( stderr, "vpush_extend: item %x, ar %x\n", item, ar ); #endif 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; } #ifdef DO_FUNLINK_DEBUG_1 fprintf ( stderr, "vpush_extend: item %x, ar %x END\n", item, ar ); #endif } /* 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; #ifdef DO_FUNLINK_DEBUG fprintf ( stderr, "delete_link: address %x, link_ar %x START\n", address, link_ar ); #endif 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); #ifdef DO_FUNLINK_DEBUG fprintf ( stderr, "delete_link: address %x, link_ar %x END\n", address, link_ar ); #endif } DEFUN("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") { object sym; va_list ap; object *p,*ar,*ar_end; object link_ar; object fun=Cnil,l=Cnil,f=OBJNULL; fixnum n=INIT_NARGS(1); va_start(ap,flag); sym=NEXT_ARG(n,ap,l,f,Cnil); 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 (!stringp(link_ar)) 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]); if (sym==Cnil) { if (flag==Cnil) { Rset=0; while (arv.v_fillp=0; } else Rset=1; } else { if ((type_of(sym)==t_symbol)) fun=sym->s.s_gfdef; else fun=sym; /* FEerror("Second arg: ~a must be symbol or closure",0,sym); */ if (Rset) { if (fun==OBJNULL) RETURN1(Cnil); switch(type_of(fun)) { /* case t_cfun: */ /* if (flag==Cnil) */ /* delete_link(fun->cf.cf_self,link_ar); */ /* break; */ case t_function: if (flag==Cnil) delete_link(fun->fun.fun_self,link_ar); break; default: break; } } } 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; #ifdef DO_FUNLINK_DEBUG fprintf ( stderr, "clean_link_array: ar %x, ar_end %x START\n", ar, ar_end ); #endif orig=ar; number_unlinked=0; while(ars.s_gfdef)==OBJNULL) FEundefined_function(sym); } else fun=sym; check_type_function(&fun); tp=type_of(fun); u.i=vld; /* p=0; */ if (u.f.pu) { u.f.ma=vs_top-vs_base; u.f.va=u.f.nv=u.f.vv=0; /* p=vs_base; */ pushed=1; } margs=u.f.ma; varg=u.f.va; nargs=u.f.va ? abs(VFUN_NARGS) : margs; nfargs=u.f.va && VFUN_NARGS<0 ? nargs-1 : nargs; vald=!u.f.vv ? -(fixnum)u.f.nv : u.f.nv; x=tmp=(u.f.pu && !fun->fun.fun_argd && VFUN_NARGS>=fun->fun.fun_minarg) ? vs_base : ZALLOCA(nargs*sizeof(object)); if (tmp!=vs_base) { if (u.f.pu) memcpy(tmp,vs_base,nargs*sizeof(*tmp)); else for (i=0;ifun.fun_neval/* ,nvald=vald */; neval=fun->fun.fun_vv ? neval : -neval; /* nvald=FUN_VALP ? vald : 0; */ if (pushed) fas=0; else if (margs!=fun->fun.fun_minarg) /*margs < fun->fun.fun_minarg*/ fas=0; else if (u.f.va &&(nfargsfun.fun_minarg || nfargs>fun->fun.fun_maxarg))/*u.f.va -> varg, xxx*/ fas=0; else if (u.f.va && VFUN_NARGS<0 && fun->fun.fun_minarg==fun->fun.fun_maxarg)/*runtime apply #arg checking omitted in reg fns*/ fas=0; /* else if (u.f.va && VFUN_NARGS<0 && */ /* (nargs-1fun.fun_minarg || nargs-1>fun->fun.fun_maxarg))/\*u.f.va -> varg, xxx*\/ */ /* fas=0; */ /* FIXME: below should be removed?*/ else if (!varg && (fun->fun.fun_minarg!=fun->fun.fun_maxarg))/*and maybe inverse for error checking*/ fas=0; else if (vald!=neval && (vald<=0 || !neval || neval>vald))/*margs funvalp aggregate across file*//*FIXME check valp*/ fas=0; else if (fun->fun.fun_env!=def_env && !clp) fas=0; else if (fun->fun.fun_argd!=argd) fas=0; } break; default: fas=0; } if (fas!=Rset && sSAfast_link_warningsA->s.s_dbind==Ct) { if (tp==t_function) { fprintf(stderr,"Warning: arg/val mismatch in call to %-.*s (%p) prevents fast linking:\n %ld %ld/%ld %d(%d) %ld %d %ld %d %ld, recompile caller\n", (int)(type_of(sym)==t_symbol ? VLEN(sym->s.s_name) : 0),sym->s.s_name->st.st_self,sym, argd,(long)fun->fun.fun_argd, vald,fun->fun.fun_neval,fun->fun.fun_vv, margs,fun->fun.fun_minarg,nargs,fun->fun.fun_maxarg,pushed); fflush(stderr); } /* if (tp==t_cfun) */ /* fprintf(stderr,"Warning: arg/val mismatch in call to %-.*s (%p) prevents fast linking:is cfun\n", */ /* (int)(type_of(sym)==t_symbol ? sym->s.s_fillp : 0),sym->s.s_self,sym); */ } if (sSAprofilingA->s.s_dbind!=Cnil) sSin_call->s.s_gfdef->fun.fun_self(sym); if (fas) { if (do_link && link) { (void) vpush_extend(link,sSAlink_arrayA->s.s_dbind); (void) vpush_extend(*link,sSAlink_arrayA->s.s_dbind); *link = (void *)fun->fun.fun_self; } if (sSAprofilingA->s.s_dbind!=Cnil) sSout_call->s.s_gfdef->fun.fun_self(fSgettimeofday()); return(c_apply_n_fun(fun,x-tmp,tmp)); } else { object res; register object *base,*old_top; enum ftype result_type; fixnum larg=0,i; #define POP_BITS(x_,y_) ({ufixnum _t=x_&((1<>=y_;_t;}) result_type=POP_BITS(argd,2); if (vald || u.f.vv) larg=(fixnum)fcall.valp; if (!pushed) { object y; vs_base=vs_top; /*???*/ for (i=0;ic.c_cdr) vs_push(y->c.c_car); vs_check; } base=vs_base; old_top=vs_top; funcall(fun); res=vs_base[0]; if (larg) { object *tmp=vs_base+1,*tl=(void *)larg,*tle=tl+labs(vald);/*FIXME avoid if pushed*/ for (;tlvs_top ? tl-1 : tl; } else vs_top=base; for (;--old_top>=vs_top && vs_top>=vs_org;) *old_top=Cnil; switch(result_type) { case f_fixnum: res=(object)fix(res); break; default: break; } if (sSAprofilingA->s.s_dbind!=Cnil) sSout_call->s.s_gfdef->fun.fun_self(fSgettimeofday()); return res; } } object call_proc_new_nval(object sym,ufixnum clp,ufixnum vld,void **link,ufixnum argd,object first,...) { object x; va_list b; va_start(b,first); x=call_proc_new(sym,clp,vld,link,argd,first,b); va_end(b); return x; } object call_proc_cs1(object fun,...) { register object res; ufixnum vald; va_list ap; va_start(ap,fun); vald=((31<<12)|(1<<17)|(1<<18)|(1<<20)); res=call_proc_new(fun,1,vald,0,0,0,ap); va_end(ap); return res; } object call_proc_cs2(object first,...) { register object res; ufixnum vald; va_list ap; object fun=fcall.fun; va_start(ap,first); vald=((31<<12)|(1<<17)|(1<<18)); res=call_proc_new(fun,1,vald,0,0,first,ap); va_end(ap); return res; } object ifuncall(object sym,int n,...) { va_list ap; int i; object *old_vs_base; object *old_vs_top; object x; old_vs_base = vs_base; 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); x = vs_base[0]; vs_top = old_vs_top; vs_base = old_vs_base; return(x); } /* 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; } DEFUN("SET-MV",object,fSset_mv,SI,2,2,NONE,OI,OO,OO,OO,(ufixnum i, object val),"") { if (i >= (sizeof(MVloc)/sizeof(object))) FEerror("Bad mv index",0); return(MVloc[i]=val); } DEFUN("MV-REF",object,fSmv_ref,SI,1,1,NONE,OI,OO,OO,OO,(ufixnum 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) { gcl_init_xdrfuns(); } gcl-2.7.1/PaxHeaders/INSTALL0000644000000000000000000000013214776130437012411 xustar0030 mtime=1744351519.811050751 30 atime=1744351519.983049186 30 ctime=1744351535.442909577 gcl-2.7.1/INSTALL0000644000175000017500000003777114776130437012026 0ustar00cammcammInstallation Instructions ************************* Basic Installation ================== The following shell commands: test -f configure || ./bootstrap ./configure make make install should configure, build, and install this package. The first line, which bootstraps, is intended for developers; when building from distribution tarballs it does nothing and can be skipped. The following more-detailed instructions are generic; see the ‘README’ file for instructions specific to this package. Some packages provide this ‘INSTALL’ file but do not implement all of the features documented below. The lack of an optional feature in a given package is not necessarily a bug. More recommendations for GNU packages can be found in the GNU Coding Standards. Many packages have scripts meant for developers instead of ordinary builders, as they may use developer tools that are less commonly installed, or they may access the network, which has privacy implications. If the ‘bootstrap’ shell script exists, it attempts to build the ‘configure’ shell script and related files, possibly using developer tools or the network. Because the output of ‘bootstrap’ is system-independent, it is normally run by a package developer so that its output can be put into the distribution tarball and ordinary builders and users need not run ‘bootstrap’. Some packages have commands like ‘./autopull.sh’ and ‘./autogen.sh’ that you can run instead of ‘./bootstrap’, for more fine-grained control over bootstrapping. The ‘configure’ shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses those values to create a ‘Makefile’ in each directory of the package. It may also create one or more ‘.h’ files containing system-dependent definitions. Finally, it creates a shell script ‘config.status’ that you can run in the future to recreate the current configuration, and a file ‘config.log’ containing output useful for debugging ‘configure’. It can also use an optional file (typically called ‘config.cache’ and enabled with ‘--cache-file=config.cache’ or simply ‘-C’) that saves the results of its tests to speed up reconfiguring. Caching is disabled by default to prevent problems with accidental use of stale cache files. If you need to do unusual things to compile the package, please try to figure out how ‘configure’ could check whether to do them, and mail diffs or instructions to the address given in the ‘README’ so they can be considered for the next release. If you are using the cache, and at some point ‘config.cache’ contains results you don’t want to keep, you may remove or edit it. The ‘autoconf’ program generates ‘configure’ from the file ‘configure.ac’. Normally you should edit ‘configure.ac’ instead of editing ‘configure’ directly. The simplest way to compile this package is: 1. ‘cd’ to the directory containing the package’s source code. 2. If this is a developer checkout and file ‘configure’ does not yet exist, type ‘./bootstrap’ to create it. You may need special developer tools and network access to bootstrap, and the network access may have privacy implications. 3. Type ‘./configure’ to configure the package for your system. This might take a while. While running, ‘configure’ prints messages telling which features it is checking for. 4. Type ‘make’ to compile the package. 5. Optionally, type ‘make check’ to run any self-tests that come with the package, generally using the just-built uninstalled binaries. 6. Type ‘make install’ to install the programs and any data files and documentation. When installing into a prefix owned by root, it is recommended that the package be configured and built as a regular user, and only the ‘make install’ phase executed with root privileges. 7. Optionally, type ‘make installcheck’ to repeat any self-tests, but this time using the binaries in their final installed location. This target does not install anything. Running this target as a regular user, particularly if the prior ‘make install’ required root privileges, verifies that the installation completed correctly. 8. You can remove the program binaries and object files from the source code directory by typing ‘make clean’. To also remove the files that ‘configure’ created (so you can compile the package for a different kind of computer), type ‘make distclean’. There is also a ‘make maintainer-clean’ target, but that is intended mainly for the package’s developers. If you use it, you may have to bootstrap again. 9. If the package follows the GNU Coding Standards, you can type ‘make uninstall’ to remove the installed files. Compilers and Options ===================== Some systems require unusual options for compilation or linking that the ‘configure’ script does not know about. Run ‘./configure --help’ for details on some of the pertinent environment variables. You can give ‘configure’ initial values for configuration parameters by setting variables in the command line or in the environment. Here is an example: ./configure CC=gcc CFLAGS=-g LIBS=-lposix See “Defining Variables†for more details. Compiling For Multiple Architectures ==================================== You can compile the package for more than one kind of computer at the same time, by placing the object files for each system in their own directory. To do this, you can use GNU ‘make’. ‘cd’ to the directory where you want the object files and executables to go and run the ‘configure’ script. ‘configure’ automatically checks for the source code in the directory that ‘configure’ is in and in ‘..’. This is known as a “VPATH†build. With a non-GNU ‘make’, it is safer to compile the package for one system at a time in the source code directory. After you have installed the package for one system, use ‘make distclean’ before reconfiguring for another system. Some platforms, notably macOS, support “fat†or “universal†binaries, where a single binary can execute on different architectures. On these platforms you can configure and compile just once, with options specific to that platform. Installation Names ================== By default, ‘make install’ installs the package’s commands under ‘/usr/local/bin’, include files under ‘/usr/local/include’, etc. You can specify an installation prefix other than ‘/usr/local’ by giving ‘configure’ the option ‘--prefix=PREFIX’, where PREFIX must be an absolute file name. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you pass the option ‘--exec-prefix=PREFIX’ to ‘configure’, the package uses PREFIX as the prefix for installing programs and libraries. Documentation and other data files still use the regular prefix. In addition, if you use an unusual directory layout you can give options like ‘--bindir=DIR’ to specify different values for particular kinds of files. Run ‘configure --help’ for a list of the directories you can set and what kinds of files go in them. In general, the default for these options is expressed in terms of ‘${prefix}’, so that specifying just ‘--prefix’ will affect all of the other directory specifications that were not explicitly provided. The most portable way to affect installation locations is to pass the correct locations to ‘configure’; however, many packages provide one or both of the following shortcuts of passing variable assignments to the ‘make install’ command line to change installation locations without having to reconfigure or recompile. The first method involves providing an override variable for each affected directory. For example, ‘make install prefix=/alternate/directory’ will choose an alternate location for all directory configuration variables that were expressed in terms of ‘${prefix}’. Any directories that were specified during ‘configure’, but not in terms of ‘${prefix}’, must each be overridden at install time for the entire installation to be relocated. The approach of makefile variable overrides for each directory variable is required by the GNU Coding Standards, and ideally causes no recompilation. However, some platforms have known limitations with the semantics of shared libraries that end up requiring recompilation when using this method, particularly noticeable in packages that use GNU Libtool. The second method involves providing the ‘DESTDIR’ variable. For example, ‘make install DESTDIR=/alternate/directory’ will prepend ‘/alternate/directory’ before all installation names. The approach of ‘DESTDIR’ overrides is not required by the GNU Coding Standards, and does not work on platforms that have drive letters. On the other hand, it does better at avoiding recompilation issues, and works well even when some directory options were not specified in terms of ‘${prefix}’ at ‘configure’ time. Optional Features ================= If the package supports it, you can cause programs to be installed with an extra prefix or suffix on their names by giving ‘configure’ the option ‘--program-prefix=PREFIX’ or ‘--program-suffix=SUFFIX’. Some packages pay attention to ‘--enable-FEATURE’ and ‘--disable-FEATURE’ options to ‘configure’, where FEATURE indicates an optional part of the package. They may also pay attention to ‘--with-PACKAGE’ and ‘--without-PACKAGE’ options, where PACKAGE is something like ‘gnu-ld’. ‘./configure --help’ should mention the ‘--enable-...’ and ‘--with-...’ options that the package recognizes. Some packages offer the ability to configure how verbose the execution of ‘make’ will be. For these packages, running ‘./configure --enable-silent-rules’ sets the default to minimal output, which can be overridden with ‘make V=1’; while running ‘./configure --disable-silent-rules’ sets the default to verbose, which can be overridden with ‘make V=0’. Specifying a System Type ======================== By default ‘configure’ builds for the current system. To create binaries that can run on a different system type, specify a ‘--host=TYPE’ option along with compiler variables that specify how to generate object code for TYPE. For example, to create binaries intended to run on a 64-bit ARM processor: ./configure --host=aarch64-linux-gnu \ CC=aarch64-linux-gnu-gcc \ CXX=aarch64-linux-gnu-g++ If done on a machine that can execute these binaries (e.g., via ‘qemu-aarch64’, ‘$QEMU_LD_PREFIX’, and Linux’s ‘binfmt_misc’ capability), the build behaves like a native build. Otherwise it is a cross-build: ‘configure’ will make cross-compilation guesses instead of running test programs, and ‘make check’ will not work. A system type can either be a short name like ‘mingw64’, or a canonical name like ‘x86_64-pc-linux-gnu’. Canonical names have the form CPU-COMPANY-SYSTEM where SYSTEM is either OS or KERNEL-OS. To canonicalize and validate a system type, you can run the command ‘config.sub’, which is often squirreled away in a subdirectory like ‘build-aux’. For example: $ build-aux/config.sub arm64-linux aarch64-unknown-linux-gnu $ build-aux/config.sub riscv-lnx Invalid configuration 'riscv-lnx': OS 'lnx' not recognized You can look at the ‘config.sub’ file to see which types are recognized. If the file is absent, this package does not need the system type. If ‘configure’ fails with the diagnostic “cannot guess build typeâ€. ‘config.sub’ did not recognize your system’s type. In this case, first fetch the newest versions of these files from the GNU config package (https://savannah.gnu.org/projects/config). If that fixes things, please report it to the maintainers of the package containing ‘configure’. Otherwise, you can try the configure option ‘--build=TYPE’ where TYPE comes close to your system type; also, please report the problem to . For more details about configuring system types, see the Autoconf documentation. Sharing Defaults ================ If you want to set default values for ‘configure’ scripts to share, you can create a site shell script called ‘config.site’ that gives default values for variables like ‘CC’, ‘cache_file’, and ‘prefix’. ‘configure’ looks for ‘PREFIX/share/config.site’ if it exists, then ‘PREFIX/etc/config.site’ if it exists. Or, you can set the ‘CONFIG_SITE’ environment variable to the location of the site script. A warning: not all ‘configure’ scripts look for a site script. Defining Variables ================== Variables not defined in a site shell script can be set in the environment passed to ‘configure’. However, some packages may run configure again during the build, and the customized values of these variables may be lost. In order to avoid this problem, you should set them in the ‘configure’ command line, using ‘VAR=value’. For example: ./configure CC=/usr/local2/bin/gcc causes the specified ‘gcc’ to be used as the C compiler (unless it is overridden in the site shell script). Unfortunately, this technique does not work for ‘CONFIG_SHELL’ due to an Autoconf limitation. Until the limitation is lifted, you can use this workaround: CONFIG_SHELL=/bin/bash ./configure CONFIG_SHELL=/bin/bash ‘configure’ Invocation ====================== ‘configure’ recognizes the following options to control how it operates. ‘--help’ ‘-h’ Print a summary of all of the options to ‘configure’, and exit. ‘--help=short’ ‘--help=recursive’ Print a summary of the options unique to this package’s ‘configure’, and exit. The ‘short’ variant lists options used only in the top level, while the ‘recursive’ variant lists options also present in any nested packages. ‘--version’ ‘-V’ Print the version of Autoconf used to generate the ‘configure’ script, and exit. ‘--cache-file=FILE’ Enable the cache: use and save the results of the tests in FILE, traditionally ‘config.cache’. FILE defaults to ‘/dev/null’ to disable caching. ‘--config-cache’ ‘-C’ Alias for ‘--cache-file=config.cache’. ‘--srcdir=DIR’ Look for the package’s source code in directory DIR. Usually ‘configure’ can determine that directory automatically. ‘--prefix=DIR’ Use DIR as the installation prefix. See “Installation Names†for more details, including other options available for fine-tuning the installation locations. ‘--host=TYPE’ Build binaries for system TYPE. See “Specifying a System Typeâ€. ‘--enable-FEATURE’ ‘--disable-FEATURE’ Enable or disable the optional FEATURE. See “Optional Featuresâ€. ‘--with-PACKAGE’ ‘--without-PACKAGE’ Use or omit PACKAGE when building. See “Optional Featuresâ€. ‘--quiet’ ‘--silent’ ‘-q’ Do not print messages saying which checks are being made. To suppress all normal output, redirect it to ‘/dev/null’ (any error messages will still be shown). ‘--no-create’ ‘-n’ Run the configure checks, but stop before creating any output files. ‘configure’ also recognizes several environment variables, and accepts some other, less widely useful, options. Run ‘configure --help’ for more details. Copyright notice ================ Copyright © 1994–1996, 1999–2002, 2004–2017, 2020–2024 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without warranty of any kind. gcl-2.7.1/PaxHeaders/Makefile.in0000644000000000000000000000013114776130437013424 xustar0030 mtime=1744351519.951049477 29 atime=1744351519.98704915 30 ctime=1744351535.438909613 gcl-2.7.1/Makefile.in0000644000175000017500000127472214776130437013042 0ustar00cammcamm# Makefile.in generated by automake 1.17 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2024 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@ VPATH = @srcdir@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } 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)) am__rm_f = rm -f $(am__rm_f_notfound) am__rm_rf = rm -rf $(am__rm_f_notfound) 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@ noinst_PROGRAMS = bin/dpp$(EXEEXT) o/grab_defs$(EXEEXT) my_unixport_PROGRAMS = unixport/saved_gcl$(EXEEXT) \ unixport/saved_ansi_gcl$(EXEEXT) $(am__EXEEXT_1) @AMM_GPROF_TRUE@am__append_1 = $(LIBGPROF) lib/libbase_gcl_gprof.a @AMM_GPROF_TRUE@am__append_2 = unixport/saved_gcl_gprof unixport/saved_ansi_gcl_gprof @AMM_GPROF_TRUE@am__append_3 = unixport/libgcl_gprof.a unixport/libansi_gcl_gprof.a @AMM_XGCL_TRUE@am__append_4 = $(X_LIB) @AMM_XGCL_TRUE@am__append_5 = $(addprefix xgcl-2/,dwdoc.tex gnu.license dec.copyright version\ @AMM_XGCL_TRUE@ $(patsubst %.o,%.lsp,$(X_OBJS))) @AMM_XGCL_TRUE@am__append_6 = info/gcl-dwdoc.texi @AMM_GPROF_TRUE@@AMM_XGCL_TRUE@am__append_7 = lib/libxgcl_gprof.a @AMM_TK_TRUE@my_gcltk_PROGRAMS = gcl-tk/gcltkaux$(EXEEXT) @AMM_TK_TRUE@am__append_8 = gcl-tk/tkl.lisp gcl-tk/tinfo.lsp @AMM_TK_TRUE@am__append_9 = info/gcl-tk.texi @AMM_GPROF_TRUE@am__append_10 = o/gprof.ini subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \ $(am__configure_deps) $(am__dist_gcltkdoc_DATA_DIST) \ $(am__dist_my_gcltk_DATA_DIST) $(am__dist_my_xgcl2_DATA_DIST) \ $(am__dist_noinst_DATA_DIST) $(am__dist_xgcl2doc_DATA_DIST) \ $(am__DIST_COMMON) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/h/gclincl.h CONFIG_CLEAN_FILES = gcl-tk/gcltksrv bin/gcl unixport/init_raw.lsp CONFIG_CLEAN_VPATH_FILES = am__installdirs = "$(DESTDIR)$(my_gcltkdir)" \ "$(DESTDIR)$(my_unixportdir)" "$(DESTDIR)$(my_unixportdir)" \ "$(DESTDIR)$(bindir)" "$(DESTDIR)$(my_gcltkdir)" \ "$(DESTDIR)$(infodir)" "$(DESTDIR)$(man1dir)" \ "$(DESTDIR)$(gcltkdocdir)" "$(DESTDIR)$(my_gcltkdir)" \ "$(DESTDIR)$(my_xgcl2dir)" "$(DESTDIR)$(xgcl2docdir)" \ "$(DESTDIR)$(gcltkdocdir)" "$(DESTDIR)$(lispdir)" \ "$(DESTDIR)$(my_clcsdir)" "$(DESTDIR)$(my_cmpnewdir)" \ "$(DESTDIR)$(my_gcltkdir)" "$(DESTDIR)$(my_hdir)" \ "$(DESTDIR)$(my_lspdir)" "$(DESTDIR)$(my_pcldir)" \ "$(DESTDIR)$(my_unixportdir)" @AMM_GPROF_TRUE@am__EXEEXT_1 = unixport/saved_gcl_gprof$(EXEEXT) \ @AMM_GPROF_TRUE@ unixport/saved_ansi_gcl_gprof$(EXEEXT) PROGRAMS = $(my_gcltk_PROGRAMS) $(my_unixport_PROGRAMS) \ $(noinst_PROGRAMS) am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__uninstall_files_from_dir = { \ { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ $(am__cd) "$$dir" && echo $$files | $(am__xargs_n) 40 $(am__rm_f); }; \ } LIBRARIES = $(my_unixport_LIBRARIES) $(noinst_LIBRARIES) AR = ar ARFLAGS = cr 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 = lib_libbase_gcl_a_AR = $(AR) $(ARFLAGS) lib_libbase_gcl_a_RANLIB = $(RANLIB) lib_libbase_gcl_a_LIBADD = am__dirstamp = $(am__leading_dot)dirstamp am__objects_1 = o/typespec.$(OBJEXT) o/alloc.$(OBJEXT) o/gbc.$(OBJEXT) \ o/bitop.$(OBJEXT) o/main.$(OBJEXT) o/eval.$(OBJEXT) \ o/macros.$(OBJEXT) o/lex.$(OBJEXT) o/bds.$(OBJEXT) \ o/frame.$(OBJEXT) o/predicate.$(OBJEXT) o/reference.$(OBJEXT) \ o/assignment.$(OBJEXT) o/bind.$(OBJEXT) o/let.$(OBJEXT) \ o/conditional.$(OBJEXT) o/block.$(OBJEXT) \ o/iteration.$(OBJEXT) o/prog.$(OBJEXT) o/multival.$(OBJEXT) \ o/catch.$(OBJEXT) o/cfun.$(OBJEXT) o/cmpaux.$(OBJEXT) \ o/big.$(OBJEXT) o/number.$(OBJEXT) o/num_pred.$(OBJEXT) \ o/num_comp.$(OBJEXT) o/num_arith.$(OBJEXT) \ o/num_sfun.$(OBJEXT) o/num_co.$(OBJEXT) o/num_log.$(OBJEXT) \ o/num_rand.$(OBJEXT) o/earith.$(OBJEXT) o/array.$(OBJEXT) \ o/regexpr.$(OBJEXT) o/structure.$(OBJEXT) o/toplevel.$(OBJEXT) \ o/backq.$(OBJEXT) o/format.$(OBJEXT) o/unixfsys.$(OBJEXT) \ o/unixfasl.$(OBJEXT) o/error.$(OBJEXT) o/unixtime.$(OBJEXT) \ o/unixsys.$(OBJEXT) o/unixsave.$(OBJEXT) o/funlink.$(OBJEXT) \ o/fat_string.$(OBJEXT) o/run_process.$(OBJEXT) \ o/nfunlink.$(OBJEXT) o/usig.$(OBJEXT) o/usig2.$(OBJEXT) \ o/utils.$(OBJEXT) o/makefun.$(OBJEXT) o/sockets.$(OBJEXT) \ o/gmp_wrappers.$(OBJEXT) o/clxsocket.$(OBJEXT) \ o/nsocket.$(OBJEXT) o/prelink.$(OBJEXT) o/sfasl.$(OBJEXT) \ o/msbrk.$(OBJEXT) o/bcmp.$(OBJEXT) o/bcopy.$(OBJEXT) \ o/bzero.$(OBJEXT) o/user_init.$(OBJEXT) o/user_match.$(OBJEXT) \ o/mapfun.$(OBJEXT) am__objects_2 = am_lib_libbase_gcl_a_OBJECTS = $(am__objects_1) $(am__objects_2) \ $(am__objects_2) $(am__objects_2) am__objects_3 = o/character.$(OBJEXT) o/file.$(OBJEXT) \ o/gcl_readline.$(OBJEXT) o/hash.$(OBJEXT) o/list.$(OBJEXT) \ o/package.$(OBJEXT) o/pathname.$(OBJEXT) o/print.$(OBJEXT) \ o/read.$(OBJEXT) o/sequence.$(OBJEXT) o/string.$(OBJEXT) \ o/symbol.$(OBJEXT) o/new_init.$(OBJEXT) nodist_lib_libbase_gcl_a_OBJECTS = $(am__objects_3) lib_libbase_gcl_a_OBJECTS = $(am_lib_libbase_gcl_a_OBJECTS) \ $(nodist_lib_libbase_gcl_a_OBJECTS) lib_libbase_gcl_gprof_a_AR = $(AR) $(ARFLAGS) lib_libbase_gcl_gprof_a_RANLIB = $(RANLIB) lib_libbase_gcl_gprof_a_LIBADD = am__objects_4 = o/lib_libbase_gcl_gprof_a-typespec.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-alloc.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-gbc.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-bitop.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-main.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-eval.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-macros.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-lex.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-bds.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-frame.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-predicate.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-reference.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-assignment.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-bind.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-let.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-conditional.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-block.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-iteration.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-prog.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-multival.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-catch.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-cfun.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-cmpaux.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-big.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-number.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-num_pred.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-num_comp.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-num_arith.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-num_sfun.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-num_co.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-num_log.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-num_rand.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-earith.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-array.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-regexpr.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-structure.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-toplevel.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-backq.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-format.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-unixfsys.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-unixfasl.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-error.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-unixtime.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-unixsys.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-unixsave.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-funlink.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-fat_string.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-run_process.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-nfunlink.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-usig.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-usig2.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-utils.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-makefun.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-sockets.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-gmp_wrappers.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-clxsocket.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-nsocket.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-prelink.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-sfasl.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-msbrk.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-bcmp.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-bcopy.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-bzero.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-user_init.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-user_match.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-mapfun.$(OBJEXT) am__objects_5 = $(am__objects_4) $(am__objects_2) $(am__objects_2) \ $(am__objects_2) am_lib_libbase_gcl_gprof_a_OBJECTS = $(am__objects_5) \ o/lib_libbase_gcl_gprof_a-gprof.$(OBJEXT) am__objects_6 = o/lib_libbase_gcl_gprof_a-character.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-file.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-gcl_readline.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-hash.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-list.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-package.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-pathname.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-print.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-read.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-sequence.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-string.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-symbol.$(OBJEXT) \ o/lib_libbase_gcl_gprof_a-new_init.$(OBJEXT) am__objects_7 = $(am__objects_6) nodist_lib_libbase_gcl_gprof_a_OBJECTS = $(am__objects_7) lib_libbase_gcl_gprof_a_OBJECTS = \ $(am_lib_libbase_gcl_gprof_a_OBJECTS) \ $(nodist_lib_libbase_gcl_gprof_a_OBJECTS) lib_libgprof_a_AR = $(AR) $(ARFLAGS) lib_libgprof_a_RANLIB = $(RANLIB) lib_libgprof_a_LIBADD = am_lib_libgprof_a_OBJECTS = o/lib_libgprof_a-gprof.$(OBJEXT) lib_libgprof_a_OBJECTS = $(am_lib_libgprof_a_OBJECTS) lib_libxgcl_a_AR = $(AR) $(ARFLAGS) lib_libxgcl_a_RANLIB = $(RANLIB) lib_libxgcl_a_LIBADD = am__objects_8 = xgcl-2/Events.$(OBJEXT) xgcl-2/general-c.$(OBJEXT) \ xgcl-2/XStruct-2.$(OBJEXT) xgcl-2/XStruct-4.$(OBJEXT) \ xgcl-2/Xutil-2.$(OBJEXT) am_lib_libxgcl_a_OBJECTS = $(am__objects_8) lib_libxgcl_a_OBJECTS = $(am_lib_libxgcl_a_OBJECTS) lib_libxgcl_gprof_a_AR = $(AR) $(ARFLAGS) lib_libxgcl_gprof_a_RANLIB = $(RANLIB) lib_libxgcl_gprof_a_LIBADD = am__objects_9 = xgcl-2/lib_libxgcl_gprof_a-Events.$(OBJEXT) \ xgcl-2/lib_libxgcl_gprof_a-general-c.$(OBJEXT) \ xgcl-2/lib_libxgcl_gprof_a-XStruct-2.$(OBJEXT) \ xgcl-2/lib_libxgcl_gprof_a-XStruct-4.$(OBJEXT) \ xgcl-2/lib_libxgcl_gprof_a-Xutil-2.$(OBJEXT) am_lib_libxgcl_gprof_a_OBJECTS = $(am__objects_9) lib_libxgcl_gprof_a_OBJECTS = $(am_lib_libxgcl_gprof_a_OBJECTS) unixport_libansi_gcl_a_AR = $(AR) $(ARFLAGS) unixport_libansi_gcl_a_RANLIB = $(RANLIB) unixport_libansi_gcl_a_LIBADD = am_unixport_libansi_gcl_a_OBJECTS = unixport_libansi_gcl_a_OBJECTS = $(am_unixport_libansi_gcl_a_OBJECTS) unixport_libansi_gcl_gprof_a_AR = $(AR) $(ARFLAGS) unixport_libansi_gcl_gprof_a_RANLIB = $(RANLIB) unixport_libansi_gcl_gprof_a_LIBADD = am_unixport_libansi_gcl_gprof_a_OBJECTS = unixport_libansi_gcl_gprof_a_OBJECTS = \ $(am_unixport_libansi_gcl_gprof_a_OBJECTS) unixport_libgcl_a_AR = $(AR) $(ARFLAGS) unixport_libgcl_a_RANLIB = $(RANLIB) unixport_libgcl_a_LIBADD = am_unixport_libgcl_a_OBJECTS = unixport_libgcl_a_OBJECTS = $(am_unixport_libgcl_a_OBJECTS) unixport_libgcl_gprof_a_AR = $(AR) $(ARFLAGS) unixport_libgcl_gprof_a_RANLIB = $(RANLIB) unixport_libgcl_gprof_a_LIBADD = am_unixport_libgcl_gprof_a_OBJECTS = unixport_libgcl_gprof_a_OBJECTS = \ $(am_unixport_libgcl_gprof_a_OBJECTS) bin_dpp_SOURCES = bin/dpp.c bin_dpp_OBJECTS = bin/dpp.$(OBJEXT) bin_dpp_LDADD = $(LDADD) am__objects_10 = gcl-tk/gcltkaux-guis.$(OBJEXT) \ gcl-tk/gcltkaux-tkAppInit.$(OBJEXT) \ gcl-tk/gcltkaux-tkMain.$(OBJEXT) am_gcl_tk_gcltkaux_OBJECTS = $(am__objects_10) gcl_tk_gcltkaux_OBJECTS = $(am_gcl_tk_gcltkaux_OBJECTS) am__DEPENDENCIES_1 = gcl_tk_gcltkaux_DEPENDENCIES = $(am__DEPENDENCIES_1) \ $(am__DEPENDENCIES_1) o_grab_defs_SOURCES = o/grab_defs.c o_grab_defs_OBJECTS = o/grab_defs.$(OBJEXT) o_grab_defs_LDADD = $(LDADD) am_unixport_saved_ansi_gcl_OBJECTS = unixport_saved_ansi_gcl_OBJECTS = \ $(am_unixport_saved_ansi_gcl_OBJECTS) unixport_saved_ansi_gcl_LDADD = $(LDADD) am_unixport_saved_ansi_gcl_gprof_OBJECTS = unixport_saved_ansi_gcl_gprof_OBJECTS = \ $(am_unixport_saved_ansi_gcl_gprof_OBJECTS) unixport_saved_ansi_gcl_gprof_LDADD = $(LDADD) am_unixport_saved_gcl_OBJECTS = unixport_saved_gcl_OBJECTS = $(am_unixport_saved_gcl_OBJECTS) unixport_saved_gcl_LDADD = $(LDADD) am_unixport_saved_gcl_gprof_OBJECTS = unixport_saved_gcl_gprof_OBJECTS = \ $(am_unixport_saved_gcl_gprof_OBJECTS) unixport_saved_gcl_gprof_LDADD = $(LDADD) SCRIPTS = $(bin_SCRIPTS) $(my_gcltk_SCRIPTS) 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)/h depcomp = $(SHELL) $(top_srcdir)/depcomp am__maybe_remake_depfiles = depfiles am__depfiles_remade = bin/$(DEPDIR)/dpp.Po \ gcl-tk/$(DEPDIR)/gcltkaux-guis.Po \ gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Po \ gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Po o/$(DEPDIR)/alloc.Po \ o/$(DEPDIR)/array.Po o/$(DEPDIR)/assignment.Po \ o/$(DEPDIR)/backq.Po o/$(DEPDIR)/bcmp.Po o/$(DEPDIR)/bcopy.Po \ o/$(DEPDIR)/bds.Po o/$(DEPDIR)/big.Po o/$(DEPDIR)/bind.Po \ o/$(DEPDIR)/bitop.Po o/$(DEPDIR)/block.Po o/$(DEPDIR)/bzero.Po \ o/$(DEPDIR)/catch.Po o/$(DEPDIR)/cfun.Po \ o/$(DEPDIR)/character.Po o/$(DEPDIR)/clxsocket.Po \ o/$(DEPDIR)/cmpaux.Po o/$(DEPDIR)/conditional.Po \ o/$(DEPDIR)/earith.Po o/$(DEPDIR)/error.Po o/$(DEPDIR)/eval.Po \ o/$(DEPDIR)/fat_string.Po o/$(DEPDIR)/file.Po \ o/$(DEPDIR)/format.Po o/$(DEPDIR)/frame.Po \ o/$(DEPDIR)/funlink.Po o/$(DEPDIR)/gbc.Po \ o/$(DEPDIR)/gcl_readline.Po o/$(DEPDIR)/gmp_wrappers.Po \ o/$(DEPDIR)/grab_defs.Po o/$(DEPDIR)/hash.Po \ o/$(DEPDIR)/iteration.Po o/$(DEPDIR)/let.Po o/$(DEPDIR)/lex.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Po \ o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Po \ o/$(DEPDIR)/lib_libgprof_a-gprof.Po o/$(DEPDIR)/list.Po \ o/$(DEPDIR)/macros.Po o/$(DEPDIR)/main.Po \ o/$(DEPDIR)/makefun.Po o/$(DEPDIR)/mapfun.Po \ o/$(DEPDIR)/msbrk.Po o/$(DEPDIR)/multival.Po \ o/$(DEPDIR)/new_init.Po o/$(DEPDIR)/nfunlink.Po \ o/$(DEPDIR)/nsocket.Po o/$(DEPDIR)/num_arith.Po \ o/$(DEPDIR)/num_co.Po o/$(DEPDIR)/num_comp.Po \ o/$(DEPDIR)/num_log.Po o/$(DEPDIR)/num_pred.Po \ o/$(DEPDIR)/num_rand.Po o/$(DEPDIR)/num_sfun.Po \ o/$(DEPDIR)/number.Po o/$(DEPDIR)/package.Po \ o/$(DEPDIR)/pathname.Po o/$(DEPDIR)/predicate.Po \ o/$(DEPDIR)/prelink.Po o/$(DEPDIR)/print.Po \ o/$(DEPDIR)/prog.Po o/$(DEPDIR)/read.Po \ o/$(DEPDIR)/reference.Po o/$(DEPDIR)/regexpr.Po \ o/$(DEPDIR)/run_process.Po o/$(DEPDIR)/sequence.Po \ o/$(DEPDIR)/sfasl.Po o/$(DEPDIR)/sockets.Po \ o/$(DEPDIR)/string.Po o/$(DEPDIR)/structure.Po \ o/$(DEPDIR)/symbol.Po o/$(DEPDIR)/toplevel.Po \ o/$(DEPDIR)/typespec.Po o/$(DEPDIR)/unixfasl.Po \ o/$(DEPDIR)/unixfsys.Po o/$(DEPDIR)/unixsave.Po \ o/$(DEPDIR)/unixsys.Po o/$(DEPDIR)/unixtime.Po \ o/$(DEPDIR)/user_init.Po o/$(DEPDIR)/user_match.Po \ o/$(DEPDIR)/usig.Po o/$(DEPDIR)/usig2.Po o/$(DEPDIR)/utils.Po \ xgcl-2/$(DEPDIR)/Events.Po xgcl-2/$(DEPDIR)/XStruct-2.Po \ xgcl-2/$(DEPDIR)/XStruct-4.Po xgcl-2/$(DEPDIR)/Xutil-2.Po \ xgcl-2/$(DEPDIR)/general-c.Po \ xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Po \ xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Po \ xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Po \ xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Po \ xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Po am__mv = mv -f 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 = 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 = $(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 = $(lib_libbase_gcl_a_SOURCES) \ $(nodist_lib_libbase_gcl_a_SOURCES) \ $(lib_libbase_gcl_gprof_a_SOURCES) \ $(nodist_lib_libbase_gcl_gprof_a_SOURCES) \ $(lib_libgprof_a_SOURCES) $(lib_libxgcl_a_SOURCES) \ $(lib_libxgcl_gprof_a_SOURCES) \ $(unixport_libansi_gcl_a_SOURCES) \ $(unixport_libansi_gcl_gprof_a_SOURCES) \ $(unixport_libgcl_a_SOURCES) \ $(unixport_libgcl_gprof_a_SOURCES) bin/dpp.c \ $(gcl_tk_gcltkaux_SOURCES) o/grab_defs.c \ $(unixport_saved_ansi_gcl_SOURCES) \ $(unixport_saved_ansi_gcl_gprof_SOURCES) \ $(unixport_saved_gcl_SOURCES) \ $(unixport_saved_gcl_gprof_SOURCES) DIST_SOURCES = $(lib_libbase_gcl_a_SOURCES) \ $(lib_libbase_gcl_gprof_a_SOURCES) $(lib_libgprof_a_SOURCES) \ $(lib_libxgcl_a_SOURCES) $(lib_libxgcl_gprof_a_SOURCES) \ $(unixport_libansi_gcl_a_SOURCES) \ $(unixport_libansi_gcl_gprof_a_SOURCES) \ $(unixport_libgcl_a_SOURCES) \ $(unixport_libgcl_gprof_a_SOURCES) bin/dpp.c \ $(gcl_tk_gcltkaux_SOURCES) o/grab_defs.c \ $(unixport_saved_ansi_gcl_SOURCES) \ $(unixport_saved_ansi_gcl_gprof_SOURCES) \ $(unixport_saved_gcl_SOURCES) \ $(unixport_saved_gcl_gprof_SOURCES) AM_V_DVIPS = $(am__v_DVIPS_@AM_V@) am__v_DVIPS_ = $(am__v_DVIPS_@AM_DEFAULT_V@) am__v_DVIPS_0 = @echo " DVIPS " $@; am__v_DVIPS_1 = AM_V_MAKEINFO = $(am__v_MAKEINFO_@AM_V@) am__v_MAKEINFO_ = $(am__v_MAKEINFO_@AM_DEFAULT_V@) am__v_MAKEINFO_0 = @echo " MAKEINFO" $@; am__v_MAKEINFO_1 = AM_V_INFOHTML = $(am__v_INFOHTML_@AM_V@) am__v_INFOHTML_ = $(am__v_INFOHTML_@AM_DEFAULT_V@) am__v_INFOHTML_0 = @echo " INFOHTML" $@; am__v_INFOHTML_1 = AM_V_TEXI2DVI = $(am__v_TEXI2DVI_@AM_V@) am__v_TEXI2DVI_ = $(am__v_TEXI2DVI_@AM_DEFAULT_V@) am__v_TEXI2DVI_0 = @echo " TEXI2DVI" $@; am__v_TEXI2DVI_1 = AM_V_TEXI2PDF = $(am__v_TEXI2PDF_@AM_V@) am__v_TEXI2PDF_ = $(am__v_TEXI2PDF_@AM_DEFAULT_V@) am__v_TEXI2PDF_0 = @echo " TEXI2PDF" $@; am__v_TEXI2PDF_1 = AM_V_texinfo = $(am__v_texinfo_@AM_V@) am__v_texinfo_ = $(am__v_texinfo_@AM_DEFAULT_V@) am__v_texinfo_0 = -q am__v_texinfo_1 = AM_V_texidevnull = $(am__v_texidevnull_@AM_V@) am__v_texidevnull_ = $(am__v_texidevnull_@AM_DEFAULT_V@) am__v_texidevnull_0 = > /dev/null am__v_texidevnull_1 = INFO_DEPS = info/gcl.info info/gcl-si.info info/gcl-dwdoc.info \ info/gcl-tk.info am__TEXINFO_TEX_DIR = $(srcdir) DVIS = info/gcl.dvi info/gcl-si.dvi info/gcl-dwdoc.dvi info/gcl-tk.dvi PDFS = info/gcl.pdf info/gcl-si.pdf info/gcl-dwdoc.pdf info/gcl-tk.pdf PSS = info/gcl.ps info/gcl-si.ps info/gcl-dwdoc.ps info/gcl-tk.ps HTMLS = info/gcl.html info/gcl-si.html info/gcl-dwdoc.html \ info/gcl-tk.html TEXINFOS = info/gcl.texi info/gcl-si.texi $(am__append_6) \ $(am__append_9) TEXI2DVI = texi2dvi TEXI2PDF = $(TEXI2DVI) --pdf --batch MAKEINFOHTML = $(MAKEINFO) --html AM_MAKEINFOHTMLFLAGS = $(AM_MAKEINFOFLAGS) DVIPS = dvips am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac man1dir = $(mandir)/man1 NROFF = nroff MANS = $(dist_man1_MANS) am__dist_gcltkdoc_DATA_DIST = $(addprefix gcl-tk/demos/,$(addsuffix \ .lisp, gc-monitor mkBasic mkCanvText mkdialog mkEntry2 mkEntry \ mkForm mkHScale mkItems mkLabel mkListbox mkPlot mkRadio \ mkRuler mkSearch mkStyles mkTextBind mkVScale nqthm-stack \ showVars widget)) am__dist_my_gcltk_DATA_DIST = gcl-tk/tk-package.lsp gcl-tk/gcl.tcl am__dist_my_xgcl2_DATA_DIST = xgcl-2/sysdef.lisp $(addprefix \ xgcl-2/gcl_,$(addsuffix .lsp, dwtest dwtestcases drawtrans \ editorstrans lispservertrans menu-settrans draw-gates)) am__dist_noinst_DATA_DIST = $(addprefix xgcl-2/,dwdoc.tex gnu.license \ dec.copyright version $(patsubst %.o,%.lsp,$(X_OBJS))) \ gcl-tk/tkl.lisp gcl-tk/tinfo.lsp am__dist_xgcl2doc_DATA_DIST = xgcl-2/Xakcl.paper xgcl-2/README \ $(addprefix xgcl-2/gcl_, $(addsuffix .lsp, menu-set pcalc draw \ dwindow editors ice-cream lispserver Xakcl.example)) DATA = $(dist_gcltkdoc_DATA) $(dist_my_gcltk_DATA) \ $(dist_my_xgcl2_DATA) $(dist_noinst_DATA) \ $(dist_xgcl2doc_DATA) $(gcltkdoc_DATA) $(lisp_DATA) \ $(my_clcs_DATA) $(my_cmpnew_DATA) $(my_gcltk_DATA) \ $(my_h_DATA) $(my_lsp_DATA) $(my_pcl_DATA) $(my_unixport_DATA) 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)` AM_RECURSIVE_TARGETS = cscope am__DIST_COMMON = $(dist_man1_MANS) $(srcdir)/Makefile.in \ $(top_srcdir)/bin/gcl.in $(top_srcdir)/gcl-tk/gcltksrv.in \ $(top_srcdir)/h/gclincl.h.in \ $(top_srcdir)/unixport/init_raw.lsp.in AUTHORS COPYING \ ChangeLog INSTALL NEWS README compile config.guess config.sub \ depcomp install-sh ltmain.sh missing texinfo.tex DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) am__remove_distdir = \ if test -d "$(distdir)"; then \ find "$(distdir)" -type d ! -perm -700 -exec chmod u+rwx {} ';' \ ; rm -rf "$(distdir)" \ || { sleep 5 && rm -rf "$(distdir)"; }; \ else :; fi am__post_remove_distdir = $(am__remove_distdir) DIST_ARCHIVES = $(distdir).tar.gz GZIP_ENV = -9 DIST_TARGETS = dist-gzip # Exists only to be overridden by the user if desired. AM_DISTCHECK_DVI_TARGET = dvi distuninstallcheck_listfiles = find . -type f -print am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' distcleancheck_listfiles = \ find . \( -type f -a \! \ \( -name .nfs* -o -name .smb* -o -name .__afs* \) \) -print ACLOCAL = @ACLOCAL@ ALLOCA = @ALLOCA@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ BASE_CFLAGS = @BASE_CFLAGS@ BASE_CPPFLAGS = @BASE_CPPFLAGS@ BASE_LDFLAGS = @BASE_LDFLAGS@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CSCOPE = @CSCOPE@ CTAGS = @CTAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DOUBLE_BIGENDIAN = @DOUBLE_BIGENDIAN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EMACS = @EMACS@ EMACSLOADPATH = @EMACSLOADPATH@ ETAGS = @ETAGS@ EXEEXT = @EXEEXT@ EXT = @EXT@ EXTRA_LOBJS = @EXTRA_LOBJS@ FINAL_CFLAGS = @FINAL_CFLAGS@ GCL_CC = @GCL_CC@ GMP = @GMP@ GMPDIR = @GMPDIR@ GNU_LD = @GNU_LD@ HAVE_LONG_LONG = @HAVE_LONG_LONG@ HAVE_MALLOC_ZONE_MEMALIGN = @HAVE_MALLOC_ZONE_MEMALIGN@ HAVE_PUTENV = @HAVE_PUTENV@ HAVE_SETENV = @HAVE_SETENV@ HAVE_SIGEMT = @HAVE_SIGEMT@ HAVE_SIGSYS = @HAVE_SIGSYS@ HAVE_SV_ONSTACK = @HAVE_SV_ONSTACK@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LDFLAGS = @LDFLAGS@ LEADING_UNDERSCORE = @LEADING_UNDERSCORE@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LI_CC = @LI_CC@ LI_DFP = @LI_DFP@ LI_EXTVERS = @LI_EXTVERS@ LI_GITTAG = @LI_GITTAG@ LI_INIT_LSP = @LI_INIT_LSP@ LI_LD = @LI_LD@ LI_LD_LIBS = @LI_LD_LIBS@ LI_MAJVERS = @LI_MAJVERS@ LI_MINVERS = @LI_MINVERS@ LI_OPT_THREE = @LI_OPT_THREE@ LI_OPT_TWO = @LI_OPT_TWO@ LI_RELEASE = @LI_RELEASE@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ NIFLAGS = @NIFLAGS@ NO_PROFILE = @NO_PROFILE@ O2FLAGS = @O2FLAGS@ O3FLAGS = @O3FLAGS@ OBJEXT = @OBJEXT@ 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@ PAGEWIDTH = @PAGEWIDTH@ PATH_SEPARATOR = @PATH_SEPARATOR@ PRELINK_CHECK = @PRELINK_CHECK@ RANLIB = @RANLIB@ RL_LIB = @RL_LIB@ RL_OBJS = @RL_OBJS@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ TCLSH = @TCLSH@ TCL_INCLUDE = @TCL_INCLUDE@ TCL_LIBRARY = @TCL_LIBRARY@ TCL_LIB_SPEC = @TCL_LIB_SPEC@ TK_CONFIG_PREFIX = @TK_CONFIG_PREFIX@ TK_INCLUDE = @TK_INCLUDE@ TK_LIBRARY = @TK_LIBRARY@ TK_LIB_SPEC = @TK_LIB_SPEC@ TK_XLIB_DIR = @TK_XLIB_DIR@ USE_CLEANUP = @USE_CLEANUP@ VERSION = @VERSION@ WORDS_BIGENDIAN = @WORDS_BIGENDIAN@ XMKMF = @XMKMF@ X_CFLAGS = @X_CFLAGS@ X_LIBS = @X_LIBS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__rm_f_notfound = @am__rm_f_notfound@ am__tar = @am__tar@ am__untar = @am__untar@ am__xargs_n = @am__xargs_n@ 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 = $(datarootdir)/doc/$(PACKAGE) dvidir = @dvidir@ exec_prefix = @exec_prefix@ 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@ lispdir = @lispdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ runstatedir = @runstatedir@ 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@ AM_CPPFLAGS = $(BASE_CPPFLAGS) AM_CFLAGS = $(BASE_CFLAGS) AM_LDFLAGS = $(BASE_LDFLAGS) AUTOMAKE_OPTIONS = subdir-objects info-in-builddir my_libdir = $(libdir)/$(PACKAGE)-$(PACKAGE_VERSION) my_unixportdir = $(my_libdir)/unixport my_gcltkdir = $(my_libdir)/gcl-tk my_xgcl2dir = $(my_libdir)/xgcl-2 my_pcldir = $(my_libdir)/pcl my_lspdir = $(my_libdir)/lsp my_hdir = $(my_libdir)/h my_cmpnewdir = $(my_libdir)/cmpnew my_clcsdir = $(my_libdir)/clcs xgcl2docdir = $(docdir)/xgcl-2 gcltkdocdir = $(docdir)/gcl-tk noinst_LIBRARIES = lib/libbase_gcl.a $(am__append_1) $(am__append_4) \ $(am__append_7) my_unixport_LIBRARIES = unixport/libgcl.a unixport/libansi_gcl.a \ $(am__append_3) bin_SCRIPTS = bin/gcl check_SCRIPTS = sb_ansi-tests/test_results sb_bench/timing_results info_TEXINFOS = info/gcl.texi info/gcl-si.texi $(am__append_6) \ $(am__append_9) my_unixport_DATA = $(addprefix unixport/,init_raw.lsp gcl.script libboot.so \ gcl_cmpnopt_gcl.lsp gcl_cmpnopt_ansi_gcl.lsp) my_h_DATA = h/cmpinclude.h my_cmpnew_DATA = sb_cmpnew/gcl_collectfn.o cmpnew/gcl_lfun_list.lsp cmpnew/gcl_cmpopt.lsp my_pcl_DATA = pcl/package.lisp my_lsp_DATA = lsp/gcl_auto_new.lsp lsp/gcl_autoload.lsp lsp/gcl_defmacro.lsp \ lsp/gcl_evalmacros.lsp lsp/gcl_export.lsp lsp/gcl_module.lsp lsp/gcl_top.lsp my_clcs_DATA = clcs/package.lisp dist_man1_MANS = man/man1/gcl.1 lisp_DATA = elisp/add-default.el elisp/ansi-doc.el elisp/dbl.el elisp/doc-to-texi.el \ elisp/gcl.el elisp/man1-to-texi.el elisp/smart-complete.el elisp/sshell.el dist_noinst_DATA = $(am__append_5) $(am__append_8) # conditionals @AMM_GPROF_TRUE@LIBGPROF = lib/libgprof.a #it would be nice someday to sandbox xgcl-2 and gcl-tk builds in tmpdirs @AMM_XGCL_TRUE@X_LIB = lib/libxgcl.a @AMM_XGCL_TRUE@dist_xgcl2doc_DATA = xgcl-2/Xakcl.paper xgcl-2/README \ @AMM_XGCL_TRUE@ $(addprefix xgcl-2/gcl_, $(addsuffix .lsp, \ @AMM_XGCL_TRUE@ menu-set pcalc draw dwindow editors ice-cream \ @AMM_XGCL_TRUE@ lispserver Xakcl.example)) @AMM_XGCL_TRUE@dist_my_xgcl2_DATA = xgcl-2/sysdef.lisp \ @AMM_XGCL_TRUE@ $(addprefix xgcl-2/gcl_,$(addsuffix .lsp,\ @AMM_XGCL_TRUE@ dwtest dwtestcases drawtrans editorstrans lispservertrans menu-settrans draw-gates)) @AMM_XGCL_TRUE@X_OBJS = $(addprefix gcl_,$(addsuffix .o,\ @AMM_XGCL_TRUE@ Xlib Xutil X XAtom defentry_events Xstruct XStruct_l_3 \ @AMM_XGCL_TRUE@ general keysymdef X10 Xinit dwtrans tohtml index)) @AMM_TK_TRUE@my_gcltk_SCRIPTS = gcl-tk/gcltksrv @AMM_TK_TRUE@my_gcltk_DATA = gcl-tk/tkl.o gcl-tk/tinfo.o gcl-tk/demos/gc-monitor.o @AMM_TK_TRUE@gcltkdoc_DATA = gcl-tk/demos/index.lsp @AMM_TK_TRUE@dist_my_gcltk_DATA = gcl-tk/tk-package.lsp gcl-tk/gcl.tcl @AMM_TK_TRUE@dist_gcltkdoc_DATA = $(addprefix gcl-tk/demos/,$(addsuffix .lisp,\ @AMM_TK_TRUE@ gc-monitor mkBasic mkCanvText mkdialog mkEntry2 mkEntry mkForm mkHScale mkItems \ @AMM_TK_TRUE@ mkLabel mkListbox mkPlot mkRadio mkRuler mkSearch mkStyles mkTextBind mkVScale \ @AMM_TK_TRUE@ nqthm-stack showVars widget)) EXTRA_DIST = $(D_SRC) $(INCL_C) $(INIT_L) $(INCL_TEXI)\ lsp cmpnew mod pcl clcs ansi-tests elisp xbin bench \ majvers minvers git.tag release # end of primaries INCL_TEXI = $(addprefix info/,$(addsuffix .texi,\ bind c-interface chap-1 chap-10 chap-11 chap-12 chap-13 chap-14 chap-15 chap-16 chap-17 chap-18 chap-19 \ chap-2 chap-20 chap-21 chap-22 chap-23 chap-24 chap-25 chap-26 chap-3 chap-4 chap-5 chap-6 chap-7 chap-8 \ chap-9 chap-a character compile compiler-defs control debug doc form \ general internal io iteration japi list misc number sequence si-defs structure symbol system type \ user-interface widgets)) INCL_C = o/sgbc.c o/gmp_big.c o/gmp.c o/gmp_num_log.c o/cmac.c o/regexp.c o/unexelf.c o/unexmacosx.c o/unexnt.c \ o/save.c o/xdrfuns.c o/fasdump.c o/usig2_aux.c o/sfaslelf.c o/sfaslmacho.c o/sfaslcoff.c gcl-tk/comm.c \ o/sfasli.c o/firstfile.c o/lastfile.c INIT_L = unixport/sys_init.c unixport/sys.c o/boot.c unixport/cinit.lisp BASE_H = h/compbas2.h h/compbas.h h/compprotos.h h/cstack.h h/enum.h h/error.h h/eval.h h/fixnum.h h/frame.h \ h/funlink.h h/globals.h h/gmp_wrappers.h h/immnum.h h/include.h h/lex.h h/linux.h h/lu.h h/make-init.h \ h/mp.h h/notcomp.h h/num_include.h h/object.h h/options.h h/page.h h/pageinfo.h h/pbits.h h/pool.h \ h/prelink.h h/protoize.h h/ptable.h h/rgbc.h h/sfun_argd.h h/stacks.h h/type.h h/usig.h h/vs.h \ h/writable.h o/regexp.h h/arth.h h/bsd.h h/bds.h h/att_ext.h h/bfdef.h h/compat.h h/apply_n.h \ gcl-tk/sheader.h h/make-decl.h h/defun.h o/ntheap.h CMPI_H = h/compdefs.h h/cmpincl1.h h/mgmp.h h/compprotos.h h/compbas2.h h/cmponly_last.h ARCHT_H = h/elf32_armhf_reloc.h h/elf32_armhf_reloc_special.h h/elf32_arm_reloc.h h/elf32_arm_reloc_special.h \ h/elf32_hppa_reloc.h h/elf32_hppa_reloc_special.h h/elf32_i386_reloc.h h/elf32_m68k_reloc.h \ h/elf32_mips_reloc.h h/elf32_mips_reloc_special.h h/elf32_ppc_reloc.h h/elf32_s390_reloc.h \ h/elf32_sh4_reloc.h h/elf32_sparc_reloc.h h/elf64_aarch64_reloc.h h/elf64_aarch64_reloc_special.h \ h/elf64_alpha_reloc.h h/elf64_alpha_reloc_special.h h/elf64_i386_reloc.h h/elf64_i386_reloc_special.h \ h/elf64_loongarch64_reloc.h h/elf64_loongarch64_reloc_special.h h/elf64_mips_reloc.h \ h/elf64_mips_reloc_special.h h/elf64_ppcle_reloc.h h/elf64_ppcle_reloc_special.h h/elf64_ppc_reloc.h \ h/elf64_ppc_reloc_special.h h/elf64_riscv64_reloc.h h/elf64_s390_reloc.h h/elf64_sparc_reloc.h \ h/elf64_sparc_reloc_special.h h/mach32_i386_reloc.h h/mach32_ppc_reloc.h h/mach64_i386_reloc.h \ h/sh4-linux.h h/amd64-linux.h h/amd64-kfreebsd.h h/386-linux.h h/riscv64-linux.h \ h/386-kfreebsd.h h/amd64-gnu.h h/386-gnu.h h/m68k-linux.h h/alpha-linux.h h/mips-linux.h \ h/mipsel-linux.h h/sparc-linux.h h/aarch64-linux.h h/armhf-linux.h h/arm-linux.h h/s390-linux.h \ h/ia64-linux.h h/hppa-linux.h h/loongarch64-linux.h h/powerpc-linux.h h/powerpc-macosx.h \ h/386-macosx.h h/mingw.h h/gnuwin95.h h/FreeBSD.h h/solaris.h h/solaris-i386.h BUILT_H = h/new_decl.h o/boot.h h/cmpinclude.h C_SRC = o/typespec.c o/alloc.c o/gbc.c o/bitop.c o/main.c o/eval.c o/macros.c o/lex.c o/bds.c o/frame.c\ o/predicate.c o/reference.c o/assignment.c o/bind.c o/let.c o/conditional.c o/block.c o/iteration.c\ o/prog.c o/multival.c o/catch.c o/cfun.c o/cmpaux.c o/big.c o/number.c o/num_pred.c o/num_comp.c\ o/num_arith.c o/num_sfun.c o/num_co.c o/num_log.c o/num_rand.c o/earith.c\ o/array.c o/regexpr.c o/structure.c o/toplevel.c o/backq.c o/format.c\ o/unixfsys.c o/unixfasl.c o/error.c o/unixtime.c o/unixsys.c o/unixsave.c o/funlink.c o/fat_string.c\ o/run_process.c o/nfunlink.c o/usig.c o/usig2.c o/utils.c o/makefun.c o/sockets.c o/gmp_wrappers.c\ o/clxsocket.c o/nsocket.c o/prelink.c o/sfasl.c o/msbrk.c \ o/bcmp.c o/bcopy.c o/bzero.c o/user_init.c o/user_match.c o/mapfun.c D_SRC = o/character.d o/file.d o/gcl_readline.d o/hash.d o/list.d o/package.d o/pathname.d o/print.d\ o/read.d o/sequence.d o/string.d o/symbol.d BUILT_C = o/character.c o/file.c o/gcl_readline.c o/hash.c o/list.c o/package.c o/pathname.c o/print.c\ o/read.c o/sequence.c o/string.c o/symbol.c o/new_init.c INI_FILES = $(patsubst %.c,%.ini,$(C_SRC)) $(patsubst \ %.d,%.ini,$(D_SRC)) $(am__append_10) BUILT_SOURCES = $(BUILT_H) $(BUILT_C) CLEANFILES = $(BUILT_SOURCES) $(INI_FILES) o/boot.ini $(addprefix \ unixport/raw_,gcl gcl_gprof ansi_gcl ansi_gcl_gprof) \ h/cmpinclude.h h/mstdint.h h/cmpincludea.h h/mcompdefs.h \ unixport/libboot.so gcl-tk/demos/index.lsp \ gcl-tk/demos/gc-monitor.o lib_libbase_gcl_a_SOURCES = $(C_SRC) $(BASE_H) $(CMPI_H) $(ARCHT_H) nodist_lib_libbase_gcl_a_SOURCES = $(BUILT_C) lib_libgprof_a_SOURCES = o/gprof.c lib_libgprof_a_CFLAGS = $(AM_CFLAGS) -fno-omit-frame-pointer -pg lib_libbase_gcl_gprof_a_SOURCES = $(lib_libbase_gcl_a_SOURCES) o/gprof.c nodist_lib_libbase_gcl_gprof_a_SOURCES = $(nodist_lib_libbase_gcl_a_SOURCES) lib_libbase_gcl_gprof_a_CFLAGS = $(AM_CFLAGS) -fno-omit-frame-pointer -pg lib_libbase_gcl_gprof_a_CPPFLAGS = $(AM_CPPFLAGS) -DGCL_GPROF X_SRC = xgcl-2/Events.c xgcl-2/general-c.c xgcl-2/XStruct-2.c xgcl-2/XStruct-4.c xgcl-2/Xutil-2.c lib_libxgcl_a_SOURCES = $(X_SRC) lib_libxgcl_gprof_a_SOURCES = $(X_SRC) lib_libxgcl_gprof_a_CFLAGS = $(AM_CFLAGS) -fno-omit-frame-pointer -pg unixport_saved_gcl_SOURCES = unixport_saved_ansi_gcl_SOURCES = unixport_saved_gcl_gprof_SOURCES = unixport_saved_ansi_gcl_gprof_SOURCES = unixport_libgcl_a_SOURCES = unixport_libansi_gcl_a_SOURCES = unixport_libgcl_gprof_a_SOURCES = unixport_libansi_gcl_gprof_a_SOURCES = GCLTK_SRC = gcl-tk/guis.c gcl-tk/tkAppInit.c gcl-tk/tkMain.c gcl-tk/guis.h gcl_tk_gcltkaux_SOURCES = $(GCLTK_SRC) gcl_tk_gcltkaux_CPPFLAGS = $(AM_CPPFLAGS) $(TK_INCLUDE) $(TCL_INCLUDE) $(TK_XINCLUDES) gcl_tk_gcltkaux_LDADD = $(TK_LIB_SPEC) $(TCL_LIB_SPEC) MY_DIRS = gcl0 gcl1 gcl2 gcl3 gcl mod_gcl0 mod_gcl pcl_gcl ansi_gcl L_STUBS = s sf c listlib predlib deftype typeof subtypep bit type typep typecase arraylib \ seq seqlib bnum fle dl rm nr lr sym hash sharp \ cmptype cmpeval cmpvar cmpwt cmpif \ cmplet cmptag cmpinline cmpenv cmplam cmptop cmpbind cmpblock cmpcall cmpcatch \ cmpflet cmpfun cmplabel cmploc cmpmap cmpmulti cmpspecial cmputil cmpvs cmpmain \ callhash assert defmacro defstruct \ describe evalmacros sc logical_pathname_translations make_pathname parse_namestring \ merge_pathnames pathname_match_p namestring wild_pathname_p translate_pathname \ truename directory rename_file restart iolib mislib module numlib packlib \ setf top trace sloop debug info serror mnum fpe L_OBJS = $(addprefix gcl_,$(addsuffix .o,$(L_STUBS))) LC_OBJS = $(filter gcl_cmp%,$(L_OBJS)) LL_OBJS = $(filter-out gcl_cmp%,$(L_OBJS)) L_FOBJS = $(addprefix gcl/,$(L_OBJS)) MOD_STUBS = ansi_io defpackage destructuring_bind loop make_defpackage MMOD_OBJS = $(addprefix gcl_,$(addsuffix .o,$(MOD_STUBS))) MOD_OBJS = $(MMOD_OBJS) $(X_OBJS) MOD_FOBJS = $(addprefix mod_gcl/,$(MOD_OBJS)) $(L_FOBJS) $(X_LIB) PCL_STUBS = boot braid cache combin compat cpl ctypes defclass defcombin defs dfun dlisp2\ dlisp env fast_init fin fixup fngen fsc generic_functions impl_low init iterate\ low macros methods pkg precom1 precom2 slots_boot slots std_class vector walk PCL_OBJS = $(addprefix gcl_pcl_,$(addsuffix .o,$(PCL_STUBS))) PCL_FOBJS = $(addprefix pcl_gcl/,$(PCL_OBJS)) $(MOD_FOBJS) CLCS_STUBS = condition_definitions conditions precom CLCS_OBJS = $(addprefix gcl_clcs_,$(addsuffix .o,$(CLCS_STUBS))) ANSI_FOBJS = $(addprefix ansi_gcl/,$(CLCS_OBJS)) $(PCL_FOBJS) E0 = s typep nr deftype cmptype cmpinline cmpflet L0 = c listlib seqlib type evalmacros E0_OBJS = $(addprefix gcl_,$(addsuffix .o,$(E0))) M0_OBJS = $(filter-out $(E0_OBJS) $(L0_OBJS),$(L_OBJS)) L0_OBJS = $(addprefix gcl_,$(addsuffix .o,$(L0))) CMPINCLUDE_FILES = h/cmpincl1.h h/gclincl.h h/compbas.h h/type.h h/mgmp.h \ h/lu.h h/globals.h h/vs.h h/bds.h h/frame.h h/lex.h \ h/mstdint.h h/compbas2.h h/compprotos.h h/immnum.h BENCH = boyer browse ctak dderiv deriv destru destru-mod div2 fft fft-mod fprint fread frpoly \ puzzle puzzle-mod stak tak takl tak-mod takr tprint traverse triang triang-mod AM_ETAGSFLAGS = --regex='/[ \n\t\#\.`]*(defun[ \n\t]+\([^ \n\t]+\)/' \ --regex='/[ \n\t\#\.`]*(defmfun[ \n\t]+"\([^ \n\t"]+\)"[ \n\t]*)/\1/' \ --regex='/[ \n\t\#\.`]*(defmfun[ \n\t]+"[^ \n\t"]+"[ \n\t]+\([^ \n\t]+\)/\1/' TAGS_FILES = lsp/*.lsp cmpnew/*.lsp mod/*.lsp pcl/*sp clcs/*sp xgcl-2/*p all: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) all-am .SUFFIXES: .SUFFIXES: .c .dvi .o .obj .ps am--refresh: Makefile @: $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ echo ' cd $(srcdir) && $(AUTOMAKE) --gnu'; \ $(am__cd) $(srcdir) && $(AUTOMAKE) --gnu \ && exit 0; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ echo ' $(SHELL) ./config.status'; \ $(SHELL) ./config.status;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__maybe_remake_depfiles)'; \ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__maybe_remake_depfiles);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) $(SHELL) ./config.status --recheck $(top_srcdir)/configure: $(am__configure_deps) $(am__cd) $(srcdir) && $(AUTOCONF) $(ACLOCAL_M4): $(am__aclocal_m4_deps) $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) $(am__aclocal_m4_deps): h/gclincl.h: h/stamp-h1 @test -f $@ || rm -f h/stamp-h1 @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) h/stamp-h1 h/stamp-h1: $(top_srcdir)/h/gclincl.h.in $(top_builddir)/config.status $(AM_V_at)rm -f h/stamp-h1 $(AM_V_GEN)cd $(top_builddir) && $(SHELL) ./config.status h/gclincl.h $(top_srcdir)/h/gclincl.h.in: $(am__configure_deps) $(AM_V_GEN)($(am__cd) $(top_srcdir) && $(AUTOHEADER)) $(AM_V_at)rm -f h/stamp-h1 $(AM_V_at)touch $@ distclean-hdr: -rm -f h/gclincl.h h/stamp-h1 gcl-tk/gcltksrv: $(top_builddir)/config.status $(top_srcdir)/gcl-tk/gcltksrv.in cd $(top_builddir) && $(SHELL) ./config.status $@ bin/gcl: $(top_builddir)/config.status $(top_srcdir)/bin/gcl.in cd $(top_builddir) && $(SHELL) ./config.status $@ unixport/init_raw.lsp: $(top_builddir)/config.status $(top_srcdir)/unixport/init_raw.lsp.in cd $(top_builddir) && $(SHELL) ./config.status $@ install-my_gcltkPROGRAMS: $(my_gcltk_PROGRAMS) @$(NORMAL_INSTALL) @list='$(my_gcltk_PROGRAMS)'; test -n "$(my_gcltkdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_gcltkdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_gcltkdir)" || exit 1; \ fi; \ for p in $$list; do echo "$$p $$p"; done | \ sed 's/$(EXEEXT)$$//' | \ while read p p1; do if test -f $$p \ ; then echo "$$p"; echo "$$p"; else :; fi; \ done | \ sed -e 'p;s,.*/,,;n;h' \ -e 's|.*|.|' \ -e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \ sed 'N;N;N;s,\n, ,g' | \ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ if ($$2 == $$4) files[d] = files[d] " " $$1; \ else { print "f", $$3 "/" $$4, $$1; } } \ END { for (d in files) print "f", d, files[d] }' | \ while read type dir files; do \ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ test -z "$$files" || { \ echo " $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files '$(DESTDIR)$(my_gcltkdir)$$dir'"; \ $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files "$(DESTDIR)$(my_gcltkdir)$$dir" || exit $$?; \ } \ ; done uninstall-my_gcltkPROGRAMS: @$(NORMAL_UNINSTALL) @list='$(my_gcltk_PROGRAMS)'; test -n "$(my_gcltkdir)" || list=; \ files=`for p in $$list; do echo "$$p"; done | \ sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \ -e 's/$$/$(EXEEXT)/' \ `; \ test -n "$$list" || exit 0; \ echo " ( cd '$(DESTDIR)$(my_gcltkdir)' && rm -f" $$files ")"; \ cd "$(DESTDIR)$(my_gcltkdir)" && $(am__rm_f) $$files clean-my_gcltkPROGRAMS: -$(am__rm_f) $(my_gcltk_PROGRAMS) install-my_unixportPROGRAMS: $(my_unixport_PROGRAMS) @$(NORMAL_INSTALL) @list='$(my_unixport_PROGRAMS)'; test -n "$(my_unixportdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_unixportdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_unixportdir)" || exit 1; \ fi; \ for p in $$list; do echo "$$p $$p"; done | \ sed 's/$(EXEEXT)$$//' | \ while read p p1; do if test -f $$p \ ; then echo "$$p"; echo "$$p"; else :; fi; \ done | \ sed -e 'p;s,.*/,,;n;h' \ -e 's|.*|.|' \ -e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \ sed 'N;N;N;s,\n, ,g' | \ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ if ($$2 == $$4) files[d] = files[d] " " $$1; \ else { print "f", $$3 "/" $$4, $$1; } } \ END { for (d in files) print "f", d, files[d] }' | \ while read type dir files; do \ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ test -z "$$files" || { \ echo " $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files '$(DESTDIR)$(my_unixportdir)$$dir'"; \ $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files "$(DESTDIR)$(my_unixportdir)$$dir" || exit $$?; \ } \ ; done uninstall-my_unixportPROGRAMS: @$(NORMAL_UNINSTALL) @list='$(my_unixport_PROGRAMS)'; test -n "$(my_unixportdir)" || list=; \ files=`for p in $$list; do echo "$$p"; done | \ sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \ -e 's/$$/$(EXEEXT)/' \ `; \ test -n "$$list" || exit 0; \ echo " ( cd '$(DESTDIR)$(my_unixportdir)' && rm -f" $$files ")"; \ cd "$(DESTDIR)$(my_unixportdir)" && $(am__rm_f) $$files clean-my_unixportPROGRAMS: -$(am__rm_f) $(my_unixport_PROGRAMS) clean-noinstPROGRAMS: -$(am__rm_f) $(noinst_PROGRAMS) install-my_unixportLIBRARIES: $(my_unixport_LIBRARIES) @$(NORMAL_INSTALL) @list='$(my_unixport_LIBRARIES)'; test -n "$(my_unixportdir)" || list=; \ list2=; for p in $$list; do \ if test -f $$p; then \ list2="$$list2 $$p"; \ else :; fi; \ done; \ test -z "$$list2" || { \ echo " $(MKDIR_P) '$(DESTDIR)$(my_unixportdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_unixportdir)" || exit 1; \ echo " $(INSTALL_DATA) $$list2 '$(DESTDIR)$(my_unixportdir)'"; \ $(INSTALL_DATA) $$list2 "$(DESTDIR)$(my_unixportdir)" || exit $$?; } @$(POST_INSTALL) @list='$(my_unixport_LIBRARIES)'; test -n "$(my_unixportdir)" || list=; \ for p in $$list; do \ if test -f $$p; then \ $(am__strip_dir) \ echo " ( cd '$(DESTDIR)$(my_unixportdir)' && $(RANLIB) $$f )"; \ ( cd "$(DESTDIR)$(my_unixportdir)" && $(RANLIB) $$f ) || exit $$?; \ else :; fi; \ done uninstall-my_unixportLIBRARIES: @$(NORMAL_UNINSTALL) @list='$(my_unixport_LIBRARIES)'; test -n "$(my_unixportdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_unixportdir)'; $(am__uninstall_files_from_dir) clean-my_unixportLIBRARIES: -$(am__rm_f) $(my_unixport_LIBRARIES) clean-noinstLIBRARIES: -$(am__rm_f) $(noinst_LIBRARIES) o/$(am__dirstamp): @$(MKDIR_P) o @: >>o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) o/$(DEPDIR) @: >>o/$(DEPDIR)/$(am__dirstamp) o/typespec.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/alloc.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/gbc.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/bitop.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/main.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/eval.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/macros.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/lex.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/bds.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/frame.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/predicate.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/reference.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/assignment.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/bind.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/let.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/conditional.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/block.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/iteration.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/prog.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/multival.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/catch.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/cfun.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/cmpaux.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/big.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/number.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/num_pred.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/num_comp.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/num_arith.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/num_sfun.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/num_co.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/num_log.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/num_rand.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/earith.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/array.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/regexpr.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/structure.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/toplevel.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/backq.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/format.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/unixfsys.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/unixfasl.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/error.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/unixtime.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/unixsys.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/unixsave.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/funlink.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/fat_string.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/run_process.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/nfunlink.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/usig.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/usig2.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/utils.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/makefun.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/sockets.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/gmp_wrappers.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/clxsocket.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/nsocket.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/prelink.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/sfasl.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/msbrk.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/bcmp.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/bcopy.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/bzero.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/user_init.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/user_match.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/mapfun.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/character.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/file.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/gcl_readline.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/hash.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/list.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/package.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/pathname.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/print.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/read.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/sequence.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/string.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/symbol.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/new_init.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) lib/$(am__dirstamp): @$(MKDIR_P) lib @: >>lib/$(am__dirstamp) lib/libbase_gcl.a: $(lib_libbase_gcl_a_OBJECTS) $(lib_libbase_gcl_a_DEPENDENCIES) $(EXTRA_lib_libbase_gcl_a_DEPENDENCIES) lib/$(am__dirstamp) $(AM_V_at)-rm -f lib/libbase_gcl.a $(AM_V_AR)$(lib_libbase_gcl_a_AR) lib/libbase_gcl.a $(lib_libbase_gcl_a_OBJECTS) $(lib_libbase_gcl_a_LIBADD) $(AM_V_at)$(lib_libbase_gcl_a_RANLIB) lib/libbase_gcl.a o/lib_libbase_gcl_gprof_a-typespec.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-alloc.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-gbc.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-bitop.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-main.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-eval.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-macros.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-lex.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-bds.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-frame.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-predicate.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-reference.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-assignment.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-bind.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-let.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-conditional.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-block.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-iteration.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-prog.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-multival.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-catch.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-cfun.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-cmpaux.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-big.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-number.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-num_pred.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-num_comp.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-num_arith.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-num_sfun.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-num_co.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-num_log.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-num_rand.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-earith.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-array.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-regexpr.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-structure.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-toplevel.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-backq.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-format.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-unixfsys.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-unixfasl.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-error.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-unixtime.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-unixsys.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-unixsave.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-funlink.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-fat_string.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-run_process.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-nfunlink.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-usig.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-usig2.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-utils.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-makefun.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-sockets.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-gmp_wrappers.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-clxsocket.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-nsocket.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-prelink.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-sfasl.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-msbrk.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-bcmp.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-bcopy.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-bzero.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-user_init.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-user_match.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-mapfun.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-gprof.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-character.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-file.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-gcl_readline.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-hash.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-list.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-package.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-pathname.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-print.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-read.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-sequence.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-string.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-symbol.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) o/lib_libbase_gcl_gprof_a-new_init.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) lib/libbase_gcl_gprof.a: $(lib_libbase_gcl_gprof_a_OBJECTS) $(lib_libbase_gcl_gprof_a_DEPENDENCIES) $(EXTRA_lib_libbase_gcl_gprof_a_DEPENDENCIES) lib/$(am__dirstamp) $(AM_V_at)-rm -f lib/libbase_gcl_gprof.a $(AM_V_AR)$(lib_libbase_gcl_gprof_a_AR) lib/libbase_gcl_gprof.a $(lib_libbase_gcl_gprof_a_OBJECTS) $(lib_libbase_gcl_gprof_a_LIBADD) $(AM_V_at)$(lib_libbase_gcl_gprof_a_RANLIB) lib/libbase_gcl_gprof.a o/lib_libgprof_a-gprof.$(OBJEXT): o/$(am__dirstamp) \ o/$(DEPDIR)/$(am__dirstamp) lib/libgprof.a: $(lib_libgprof_a_OBJECTS) $(lib_libgprof_a_DEPENDENCIES) $(EXTRA_lib_libgprof_a_DEPENDENCIES) lib/$(am__dirstamp) $(AM_V_at)-rm -f lib/libgprof.a $(AM_V_AR)$(lib_libgprof_a_AR) lib/libgprof.a $(lib_libgprof_a_OBJECTS) $(lib_libgprof_a_LIBADD) $(AM_V_at)$(lib_libgprof_a_RANLIB) lib/libgprof.a xgcl-2/$(am__dirstamp): @$(MKDIR_P) xgcl-2 @: >>xgcl-2/$(am__dirstamp) xgcl-2/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) xgcl-2/$(DEPDIR) @: >>xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/Events.$(OBJEXT): xgcl-2/$(am__dirstamp) \ xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/general-c.$(OBJEXT): xgcl-2/$(am__dirstamp) \ xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/XStruct-2.$(OBJEXT): xgcl-2/$(am__dirstamp) \ xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/XStruct-4.$(OBJEXT): xgcl-2/$(am__dirstamp) \ xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/Xutil-2.$(OBJEXT): xgcl-2/$(am__dirstamp) \ xgcl-2/$(DEPDIR)/$(am__dirstamp) lib/libxgcl.a: $(lib_libxgcl_a_OBJECTS) $(lib_libxgcl_a_DEPENDENCIES) $(EXTRA_lib_libxgcl_a_DEPENDENCIES) lib/$(am__dirstamp) $(AM_V_at)-rm -f lib/libxgcl.a $(AM_V_AR)$(lib_libxgcl_a_AR) lib/libxgcl.a $(lib_libxgcl_a_OBJECTS) $(lib_libxgcl_a_LIBADD) $(AM_V_at)$(lib_libxgcl_a_RANLIB) lib/libxgcl.a xgcl-2/lib_libxgcl_gprof_a-Events.$(OBJEXT): xgcl-2/$(am__dirstamp) \ xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/lib_libxgcl_gprof_a-general-c.$(OBJEXT): \ xgcl-2/$(am__dirstamp) xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/lib_libxgcl_gprof_a-XStruct-2.$(OBJEXT): \ xgcl-2/$(am__dirstamp) xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/lib_libxgcl_gprof_a-XStruct-4.$(OBJEXT): \ xgcl-2/$(am__dirstamp) xgcl-2/$(DEPDIR)/$(am__dirstamp) xgcl-2/lib_libxgcl_gprof_a-Xutil-2.$(OBJEXT): xgcl-2/$(am__dirstamp) \ xgcl-2/$(DEPDIR)/$(am__dirstamp) lib/libxgcl_gprof.a: $(lib_libxgcl_gprof_a_OBJECTS) $(lib_libxgcl_gprof_a_DEPENDENCIES) $(EXTRA_lib_libxgcl_gprof_a_DEPENDENCIES) lib/$(am__dirstamp) $(AM_V_at)-rm -f lib/libxgcl_gprof.a $(AM_V_AR)$(lib_libxgcl_gprof_a_AR) lib/libxgcl_gprof.a $(lib_libxgcl_gprof_a_OBJECTS) $(lib_libxgcl_gprof_a_LIBADD) $(AM_V_at)$(lib_libxgcl_gprof_a_RANLIB) lib/libxgcl_gprof.a unixport/$(am__dirstamp): @$(MKDIR_P) unixport @: >>unixport/$(am__dirstamp) bin/$(am__dirstamp): @$(MKDIR_P) bin @: >>bin/$(am__dirstamp) bin/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) bin/$(DEPDIR) @: >>bin/$(DEPDIR)/$(am__dirstamp) bin/dpp.$(OBJEXT): bin/$(am__dirstamp) bin/$(DEPDIR)/$(am__dirstamp) bin/dpp$(EXEEXT): $(bin_dpp_OBJECTS) $(bin_dpp_DEPENDENCIES) $(EXTRA_bin_dpp_DEPENDENCIES) bin/$(am__dirstamp) @rm -f bin/dpp$(EXEEXT) $(AM_V_CCLD)$(LINK) $(bin_dpp_OBJECTS) $(bin_dpp_LDADD) $(LIBS) gcl-tk/$(am__dirstamp): @$(MKDIR_P) gcl-tk @: >>gcl-tk/$(am__dirstamp) gcl-tk/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) gcl-tk/$(DEPDIR) @: >>gcl-tk/$(DEPDIR)/$(am__dirstamp) gcl-tk/gcltkaux-guis.$(OBJEXT): gcl-tk/$(am__dirstamp) \ gcl-tk/$(DEPDIR)/$(am__dirstamp) gcl-tk/gcltkaux-tkAppInit.$(OBJEXT): gcl-tk/$(am__dirstamp) \ gcl-tk/$(DEPDIR)/$(am__dirstamp) gcl-tk/gcltkaux-tkMain.$(OBJEXT): gcl-tk/$(am__dirstamp) \ gcl-tk/$(DEPDIR)/$(am__dirstamp) gcl-tk/gcltkaux$(EXEEXT): $(gcl_tk_gcltkaux_OBJECTS) $(gcl_tk_gcltkaux_DEPENDENCIES) $(EXTRA_gcl_tk_gcltkaux_DEPENDENCIES) gcl-tk/$(am__dirstamp) @rm -f gcl-tk/gcltkaux$(EXEEXT) $(AM_V_CCLD)$(LINK) $(gcl_tk_gcltkaux_OBJECTS) $(gcl_tk_gcltkaux_LDADD) $(LIBS) o/grab_defs.$(OBJEXT): o/$(am__dirstamp) o/$(DEPDIR)/$(am__dirstamp) o/grab_defs$(EXEEXT): $(o_grab_defs_OBJECTS) $(o_grab_defs_DEPENDENCIES) $(EXTRA_o_grab_defs_DEPENDENCIES) o/$(am__dirstamp) @rm -f o/grab_defs$(EXEEXT) $(AM_V_CCLD)$(LINK) $(o_grab_defs_OBJECTS) $(o_grab_defs_LDADD) $(LIBS) install-binSCRIPTS: $(bin_SCRIPTS) @$(NORMAL_INSTALL) @list='$(bin_SCRIPTS)'; test -n "$(bindir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \ $(MKDIR_P) "$(DESTDIR)$(bindir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ if test -f "$$d$$p"; then echo "$$d$$p"; echo "$$p"; else :; fi; \ done | \ sed -e 'p;s,.*/,,;n' \ -e 'h;s|.*|.|' \ -e 'p;x;s,.*/,,;$(transform)' | sed 'N;N;N;s,\n, ,g' | \ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1; } \ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ if ($$2 == $$4) { files[d] = files[d] " " $$1; \ if (++n[d] == $(am__install_max)) { \ print "f", d, files[d]; n[d] = 0; files[d] = "" } } \ else { print "f", d "/" $$4, $$1 } } \ END { for (d in files) print "f", d, files[d] }' | \ while read type dir files; do \ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ test -z "$$files" || { \ echo " $(INSTALL_SCRIPT) $$files '$(DESTDIR)$(bindir)$$dir'"; \ $(INSTALL_SCRIPT) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \ } \ ; done uninstall-binSCRIPTS: @$(NORMAL_UNINSTALL) @list='$(bin_SCRIPTS)'; test -n "$(bindir)" || exit 0; \ files=`for p in $$list; do echo "$$p"; done | \ sed -e 's,.*/,,;$(transform)'`; \ dir='$(DESTDIR)$(bindir)'; $(am__uninstall_files_from_dir) install-my_gcltkSCRIPTS: $(my_gcltk_SCRIPTS) @$(NORMAL_INSTALL) @list='$(my_gcltk_SCRIPTS)'; test -n "$(my_gcltkdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_gcltkdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_gcltkdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ if test -f "$$d$$p"; then echo "$$d$$p"; echo "$$p"; else :; fi; \ done | \ sed -e 'p;s,.*/,,;n' \ -e 'h;s|.*|.|' \ -e 'p;x;s,.*/,,;$(transform)' | sed 'N;N;N;s,\n, ,g' | \ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1; } \ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ if ($$2 == $$4) { files[d] = files[d] " " $$1; \ if (++n[d] == $(am__install_max)) { \ print "f", d, files[d]; n[d] = 0; files[d] = "" } } \ else { print "f", d "/" $$4, $$1 } } \ END { for (d in files) print "f", d, files[d] }' | \ while read type dir files; do \ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ test -z "$$files" || { \ echo " $(INSTALL_SCRIPT) $$files '$(DESTDIR)$(my_gcltkdir)$$dir'"; \ $(INSTALL_SCRIPT) $$files "$(DESTDIR)$(my_gcltkdir)$$dir" || exit $$?; \ } \ ; done uninstall-my_gcltkSCRIPTS: @$(NORMAL_UNINSTALL) @list='$(my_gcltk_SCRIPTS)'; test -n "$(my_gcltkdir)" || exit 0; \ files=`for p in $$list; do echo "$$p"; done | \ sed -e 's,.*/,,;$(transform)'`; \ dir='$(DESTDIR)$(my_gcltkdir)'; $(am__uninstall_files_from_dir) mostlyclean-compile: -rm -f *.$(OBJEXT) -rm -f bin/*.$(OBJEXT) -rm -f gcl-tk/*.$(OBJEXT) -rm -f o/*.$(OBJEXT) -rm -f xgcl-2/*.$(OBJEXT) distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@bin/$(DEPDIR)/dpp.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@gcl-tk/$(DEPDIR)/gcltkaux-guis.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/alloc.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/array.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/assignment.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/backq.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/bcmp.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/bcopy.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/bds.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/big.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/bind.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/bitop.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/block.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/bzero.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/catch.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/cfun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/character.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/clxsocket.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/cmpaux.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/conditional.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/earith.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/error.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/eval.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/fat_string.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/file.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/format.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/frame.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/funlink.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/gbc.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/gcl_readline.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/gmp_wrappers.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/grab_defs.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/hash.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/iteration.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/let.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lex.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/lib_libgprof_a-gprof.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/list.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/macros.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/main.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/makefun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/mapfun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/msbrk.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/multival.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/new_init.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/nfunlink.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/nsocket.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/num_arith.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/num_co.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/num_comp.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/num_log.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/num_pred.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/num_rand.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/num_sfun.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/number.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/package.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/pathname.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/predicate.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/prelink.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/print.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/prog.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/read.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/reference.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/regexpr.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/run_process.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/sequence.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/sfasl.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/sockets.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/string.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/structure.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/symbol.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/toplevel.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/typespec.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/unixfasl.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/unixfsys.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/unixsave.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/unixsys.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/unixtime.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/user_init.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/user_match.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/usig.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/usig2.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@o/$(DEPDIR)/utils.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/Events.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/XStruct-2.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/XStruct-4.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/Xutil-2.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/general-c.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Po@am__quote@ # am--include-marker $(am__depfiles_remade): @$(MKDIR_P) $(@D) @: >>$@ am--depfiles: $(am__depfiles_remade) .c.o: @am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ @am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $< .c.obj: @am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ @am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` o/lib_libbase_gcl_gprof_a-typespec.o: o/typespec.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-typespec.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Tpo -c -o o/lib_libbase_gcl_gprof_a-typespec.o `test -f 'o/typespec.c' || echo '$(srcdir)/'`o/typespec.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/typespec.c' object='o/lib_libbase_gcl_gprof_a-typespec.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-typespec.o `test -f 'o/typespec.c' || echo '$(srcdir)/'`o/typespec.c o/lib_libbase_gcl_gprof_a-typespec.obj: o/typespec.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-typespec.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Tpo -c -o o/lib_libbase_gcl_gprof_a-typespec.obj `if test -f 'o/typespec.c'; then $(CYGPATH_W) 'o/typespec.c'; else $(CYGPATH_W) '$(srcdir)/o/typespec.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/typespec.c' object='o/lib_libbase_gcl_gprof_a-typespec.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-typespec.obj `if test -f 'o/typespec.c'; then $(CYGPATH_W) 'o/typespec.c'; else $(CYGPATH_W) '$(srcdir)/o/typespec.c'; fi` o/lib_libbase_gcl_gprof_a-alloc.o: o/alloc.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-alloc.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Tpo -c -o o/lib_libbase_gcl_gprof_a-alloc.o `test -f 'o/alloc.c' || echo '$(srcdir)/'`o/alloc.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/alloc.c' object='o/lib_libbase_gcl_gprof_a-alloc.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-alloc.o `test -f 'o/alloc.c' || echo '$(srcdir)/'`o/alloc.c o/lib_libbase_gcl_gprof_a-alloc.obj: o/alloc.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-alloc.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Tpo -c -o o/lib_libbase_gcl_gprof_a-alloc.obj `if test -f 'o/alloc.c'; then $(CYGPATH_W) 'o/alloc.c'; else $(CYGPATH_W) '$(srcdir)/o/alloc.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/alloc.c' object='o/lib_libbase_gcl_gprof_a-alloc.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-alloc.obj `if test -f 'o/alloc.c'; then $(CYGPATH_W) 'o/alloc.c'; else $(CYGPATH_W) '$(srcdir)/o/alloc.c'; fi` o/lib_libbase_gcl_gprof_a-gbc.o: o/gbc.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gbc.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Tpo -c -o o/lib_libbase_gcl_gprof_a-gbc.o `test -f 'o/gbc.c' || echo '$(srcdir)/'`o/gbc.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gbc.c' object='o/lib_libbase_gcl_gprof_a-gbc.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gbc.o `test -f 'o/gbc.c' || echo '$(srcdir)/'`o/gbc.c o/lib_libbase_gcl_gprof_a-gbc.obj: o/gbc.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gbc.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Tpo -c -o o/lib_libbase_gcl_gprof_a-gbc.obj `if test -f 'o/gbc.c'; then $(CYGPATH_W) 'o/gbc.c'; else $(CYGPATH_W) '$(srcdir)/o/gbc.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gbc.c' object='o/lib_libbase_gcl_gprof_a-gbc.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gbc.obj `if test -f 'o/gbc.c'; then $(CYGPATH_W) 'o/gbc.c'; else $(CYGPATH_W) '$(srcdir)/o/gbc.c'; fi` o/lib_libbase_gcl_gprof_a-bitop.o: o/bitop.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bitop.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Tpo -c -o o/lib_libbase_gcl_gprof_a-bitop.o `test -f 'o/bitop.c' || echo '$(srcdir)/'`o/bitop.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bitop.c' object='o/lib_libbase_gcl_gprof_a-bitop.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bitop.o `test -f 'o/bitop.c' || echo '$(srcdir)/'`o/bitop.c o/lib_libbase_gcl_gprof_a-bitop.obj: o/bitop.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bitop.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Tpo -c -o o/lib_libbase_gcl_gprof_a-bitop.obj `if test -f 'o/bitop.c'; then $(CYGPATH_W) 'o/bitop.c'; else $(CYGPATH_W) '$(srcdir)/o/bitop.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bitop.c' object='o/lib_libbase_gcl_gprof_a-bitop.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bitop.obj `if test -f 'o/bitop.c'; then $(CYGPATH_W) 'o/bitop.c'; else $(CYGPATH_W) '$(srcdir)/o/bitop.c'; fi` o/lib_libbase_gcl_gprof_a-main.o: o/main.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-main.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Tpo -c -o o/lib_libbase_gcl_gprof_a-main.o `test -f 'o/main.c' || echo '$(srcdir)/'`o/main.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/main.c' object='o/lib_libbase_gcl_gprof_a-main.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-main.o `test -f 'o/main.c' || echo '$(srcdir)/'`o/main.c o/lib_libbase_gcl_gprof_a-main.obj: o/main.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-main.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Tpo -c -o o/lib_libbase_gcl_gprof_a-main.obj `if test -f 'o/main.c'; then $(CYGPATH_W) 'o/main.c'; else $(CYGPATH_W) '$(srcdir)/o/main.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/main.c' object='o/lib_libbase_gcl_gprof_a-main.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-main.obj `if test -f 'o/main.c'; then $(CYGPATH_W) 'o/main.c'; else $(CYGPATH_W) '$(srcdir)/o/main.c'; fi` o/lib_libbase_gcl_gprof_a-eval.o: o/eval.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-eval.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Tpo -c -o o/lib_libbase_gcl_gprof_a-eval.o `test -f 'o/eval.c' || echo '$(srcdir)/'`o/eval.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/eval.c' object='o/lib_libbase_gcl_gprof_a-eval.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-eval.o `test -f 'o/eval.c' || echo '$(srcdir)/'`o/eval.c o/lib_libbase_gcl_gprof_a-eval.obj: o/eval.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-eval.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Tpo -c -o o/lib_libbase_gcl_gprof_a-eval.obj `if test -f 'o/eval.c'; then $(CYGPATH_W) 'o/eval.c'; else $(CYGPATH_W) '$(srcdir)/o/eval.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/eval.c' object='o/lib_libbase_gcl_gprof_a-eval.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-eval.obj `if test -f 'o/eval.c'; then $(CYGPATH_W) 'o/eval.c'; else $(CYGPATH_W) '$(srcdir)/o/eval.c'; fi` o/lib_libbase_gcl_gprof_a-macros.o: o/macros.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-macros.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Tpo -c -o o/lib_libbase_gcl_gprof_a-macros.o `test -f 'o/macros.c' || echo '$(srcdir)/'`o/macros.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/macros.c' object='o/lib_libbase_gcl_gprof_a-macros.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-macros.o `test -f 'o/macros.c' || echo '$(srcdir)/'`o/macros.c o/lib_libbase_gcl_gprof_a-macros.obj: o/macros.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-macros.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Tpo -c -o o/lib_libbase_gcl_gprof_a-macros.obj `if test -f 'o/macros.c'; then $(CYGPATH_W) 'o/macros.c'; else $(CYGPATH_W) '$(srcdir)/o/macros.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/macros.c' object='o/lib_libbase_gcl_gprof_a-macros.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-macros.obj `if test -f 'o/macros.c'; then $(CYGPATH_W) 'o/macros.c'; else $(CYGPATH_W) '$(srcdir)/o/macros.c'; fi` o/lib_libbase_gcl_gprof_a-lex.o: o/lex.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-lex.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Tpo -c -o o/lib_libbase_gcl_gprof_a-lex.o `test -f 'o/lex.c' || echo '$(srcdir)/'`o/lex.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/lex.c' object='o/lib_libbase_gcl_gprof_a-lex.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-lex.o `test -f 'o/lex.c' || echo '$(srcdir)/'`o/lex.c o/lib_libbase_gcl_gprof_a-lex.obj: o/lex.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-lex.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Tpo -c -o o/lib_libbase_gcl_gprof_a-lex.obj `if test -f 'o/lex.c'; then $(CYGPATH_W) 'o/lex.c'; else $(CYGPATH_W) '$(srcdir)/o/lex.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/lex.c' object='o/lib_libbase_gcl_gprof_a-lex.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-lex.obj `if test -f 'o/lex.c'; then $(CYGPATH_W) 'o/lex.c'; else $(CYGPATH_W) '$(srcdir)/o/lex.c'; fi` o/lib_libbase_gcl_gprof_a-bds.o: o/bds.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bds.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Tpo -c -o o/lib_libbase_gcl_gprof_a-bds.o `test -f 'o/bds.c' || echo '$(srcdir)/'`o/bds.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bds.c' object='o/lib_libbase_gcl_gprof_a-bds.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bds.o `test -f 'o/bds.c' || echo '$(srcdir)/'`o/bds.c o/lib_libbase_gcl_gprof_a-bds.obj: o/bds.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bds.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Tpo -c -o o/lib_libbase_gcl_gprof_a-bds.obj `if test -f 'o/bds.c'; then $(CYGPATH_W) 'o/bds.c'; else $(CYGPATH_W) '$(srcdir)/o/bds.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bds.c' object='o/lib_libbase_gcl_gprof_a-bds.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bds.obj `if test -f 'o/bds.c'; then $(CYGPATH_W) 'o/bds.c'; else $(CYGPATH_W) '$(srcdir)/o/bds.c'; fi` o/lib_libbase_gcl_gprof_a-frame.o: o/frame.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-frame.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Tpo -c -o o/lib_libbase_gcl_gprof_a-frame.o `test -f 'o/frame.c' || echo '$(srcdir)/'`o/frame.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/frame.c' object='o/lib_libbase_gcl_gprof_a-frame.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-frame.o `test -f 'o/frame.c' || echo '$(srcdir)/'`o/frame.c o/lib_libbase_gcl_gprof_a-frame.obj: o/frame.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-frame.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Tpo -c -o o/lib_libbase_gcl_gprof_a-frame.obj `if test -f 'o/frame.c'; then $(CYGPATH_W) 'o/frame.c'; else $(CYGPATH_W) '$(srcdir)/o/frame.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/frame.c' object='o/lib_libbase_gcl_gprof_a-frame.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-frame.obj `if test -f 'o/frame.c'; then $(CYGPATH_W) 'o/frame.c'; else $(CYGPATH_W) '$(srcdir)/o/frame.c'; fi` o/lib_libbase_gcl_gprof_a-predicate.o: o/predicate.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-predicate.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Tpo -c -o o/lib_libbase_gcl_gprof_a-predicate.o `test -f 'o/predicate.c' || echo '$(srcdir)/'`o/predicate.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/predicate.c' object='o/lib_libbase_gcl_gprof_a-predicate.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-predicate.o `test -f 'o/predicate.c' || echo '$(srcdir)/'`o/predicate.c o/lib_libbase_gcl_gprof_a-predicate.obj: o/predicate.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-predicate.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Tpo -c -o o/lib_libbase_gcl_gprof_a-predicate.obj `if test -f 'o/predicate.c'; then $(CYGPATH_W) 'o/predicate.c'; else $(CYGPATH_W) '$(srcdir)/o/predicate.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/predicate.c' object='o/lib_libbase_gcl_gprof_a-predicate.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-predicate.obj `if test -f 'o/predicate.c'; then $(CYGPATH_W) 'o/predicate.c'; else $(CYGPATH_W) '$(srcdir)/o/predicate.c'; fi` o/lib_libbase_gcl_gprof_a-reference.o: o/reference.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-reference.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Tpo -c -o o/lib_libbase_gcl_gprof_a-reference.o `test -f 'o/reference.c' || echo '$(srcdir)/'`o/reference.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/reference.c' object='o/lib_libbase_gcl_gprof_a-reference.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-reference.o `test -f 'o/reference.c' || echo '$(srcdir)/'`o/reference.c o/lib_libbase_gcl_gprof_a-reference.obj: o/reference.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-reference.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Tpo -c -o o/lib_libbase_gcl_gprof_a-reference.obj `if test -f 'o/reference.c'; then $(CYGPATH_W) 'o/reference.c'; else $(CYGPATH_W) '$(srcdir)/o/reference.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/reference.c' object='o/lib_libbase_gcl_gprof_a-reference.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-reference.obj `if test -f 'o/reference.c'; then $(CYGPATH_W) 'o/reference.c'; else $(CYGPATH_W) '$(srcdir)/o/reference.c'; fi` o/lib_libbase_gcl_gprof_a-assignment.o: o/assignment.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-assignment.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Tpo -c -o o/lib_libbase_gcl_gprof_a-assignment.o `test -f 'o/assignment.c' || echo '$(srcdir)/'`o/assignment.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/assignment.c' object='o/lib_libbase_gcl_gprof_a-assignment.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-assignment.o `test -f 'o/assignment.c' || echo '$(srcdir)/'`o/assignment.c o/lib_libbase_gcl_gprof_a-assignment.obj: o/assignment.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-assignment.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Tpo -c -o o/lib_libbase_gcl_gprof_a-assignment.obj `if test -f 'o/assignment.c'; then $(CYGPATH_W) 'o/assignment.c'; else $(CYGPATH_W) '$(srcdir)/o/assignment.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/assignment.c' object='o/lib_libbase_gcl_gprof_a-assignment.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-assignment.obj `if test -f 'o/assignment.c'; then $(CYGPATH_W) 'o/assignment.c'; else $(CYGPATH_W) '$(srcdir)/o/assignment.c'; fi` o/lib_libbase_gcl_gprof_a-bind.o: o/bind.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bind.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Tpo -c -o o/lib_libbase_gcl_gprof_a-bind.o `test -f 'o/bind.c' || echo '$(srcdir)/'`o/bind.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bind.c' object='o/lib_libbase_gcl_gprof_a-bind.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bind.o `test -f 'o/bind.c' || echo '$(srcdir)/'`o/bind.c o/lib_libbase_gcl_gprof_a-bind.obj: o/bind.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bind.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Tpo -c -o o/lib_libbase_gcl_gprof_a-bind.obj `if test -f 'o/bind.c'; then $(CYGPATH_W) 'o/bind.c'; else $(CYGPATH_W) '$(srcdir)/o/bind.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bind.c' object='o/lib_libbase_gcl_gprof_a-bind.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bind.obj `if test -f 'o/bind.c'; then $(CYGPATH_W) 'o/bind.c'; else $(CYGPATH_W) '$(srcdir)/o/bind.c'; fi` o/lib_libbase_gcl_gprof_a-let.o: o/let.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-let.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Tpo -c -o o/lib_libbase_gcl_gprof_a-let.o `test -f 'o/let.c' || echo '$(srcdir)/'`o/let.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/let.c' object='o/lib_libbase_gcl_gprof_a-let.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-let.o `test -f 'o/let.c' || echo '$(srcdir)/'`o/let.c o/lib_libbase_gcl_gprof_a-let.obj: o/let.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-let.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Tpo -c -o o/lib_libbase_gcl_gprof_a-let.obj `if test -f 'o/let.c'; then $(CYGPATH_W) 'o/let.c'; else $(CYGPATH_W) '$(srcdir)/o/let.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/let.c' object='o/lib_libbase_gcl_gprof_a-let.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-let.obj `if test -f 'o/let.c'; then $(CYGPATH_W) 'o/let.c'; else $(CYGPATH_W) '$(srcdir)/o/let.c'; fi` o/lib_libbase_gcl_gprof_a-conditional.o: o/conditional.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-conditional.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Tpo -c -o o/lib_libbase_gcl_gprof_a-conditional.o `test -f 'o/conditional.c' || echo '$(srcdir)/'`o/conditional.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/conditional.c' object='o/lib_libbase_gcl_gprof_a-conditional.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-conditional.o `test -f 'o/conditional.c' || echo '$(srcdir)/'`o/conditional.c o/lib_libbase_gcl_gprof_a-conditional.obj: o/conditional.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-conditional.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Tpo -c -o o/lib_libbase_gcl_gprof_a-conditional.obj `if test -f 'o/conditional.c'; then $(CYGPATH_W) 'o/conditional.c'; else $(CYGPATH_W) '$(srcdir)/o/conditional.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/conditional.c' object='o/lib_libbase_gcl_gprof_a-conditional.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-conditional.obj `if test -f 'o/conditional.c'; then $(CYGPATH_W) 'o/conditional.c'; else $(CYGPATH_W) '$(srcdir)/o/conditional.c'; fi` o/lib_libbase_gcl_gprof_a-block.o: o/block.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-block.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Tpo -c -o o/lib_libbase_gcl_gprof_a-block.o `test -f 'o/block.c' || echo '$(srcdir)/'`o/block.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/block.c' object='o/lib_libbase_gcl_gprof_a-block.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-block.o `test -f 'o/block.c' || echo '$(srcdir)/'`o/block.c o/lib_libbase_gcl_gprof_a-block.obj: o/block.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-block.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Tpo -c -o o/lib_libbase_gcl_gprof_a-block.obj `if test -f 'o/block.c'; then $(CYGPATH_W) 'o/block.c'; else $(CYGPATH_W) '$(srcdir)/o/block.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/block.c' object='o/lib_libbase_gcl_gprof_a-block.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-block.obj `if test -f 'o/block.c'; then $(CYGPATH_W) 'o/block.c'; else $(CYGPATH_W) '$(srcdir)/o/block.c'; fi` o/lib_libbase_gcl_gprof_a-iteration.o: o/iteration.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-iteration.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Tpo -c -o o/lib_libbase_gcl_gprof_a-iteration.o `test -f 'o/iteration.c' || echo '$(srcdir)/'`o/iteration.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/iteration.c' object='o/lib_libbase_gcl_gprof_a-iteration.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-iteration.o `test -f 'o/iteration.c' || echo '$(srcdir)/'`o/iteration.c o/lib_libbase_gcl_gprof_a-iteration.obj: o/iteration.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-iteration.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Tpo -c -o o/lib_libbase_gcl_gprof_a-iteration.obj `if test -f 'o/iteration.c'; then $(CYGPATH_W) 'o/iteration.c'; else $(CYGPATH_W) '$(srcdir)/o/iteration.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/iteration.c' object='o/lib_libbase_gcl_gprof_a-iteration.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-iteration.obj `if test -f 'o/iteration.c'; then $(CYGPATH_W) 'o/iteration.c'; else $(CYGPATH_W) '$(srcdir)/o/iteration.c'; fi` o/lib_libbase_gcl_gprof_a-prog.o: o/prog.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-prog.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Tpo -c -o o/lib_libbase_gcl_gprof_a-prog.o `test -f 'o/prog.c' || echo '$(srcdir)/'`o/prog.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/prog.c' object='o/lib_libbase_gcl_gprof_a-prog.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-prog.o `test -f 'o/prog.c' || echo '$(srcdir)/'`o/prog.c o/lib_libbase_gcl_gprof_a-prog.obj: o/prog.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-prog.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Tpo -c -o o/lib_libbase_gcl_gprof_a-prog.obj `if test -f 'o/prog.c'; then $(CYGPATH_W) 'o/prog.c'; else $(CYGPATH_W) '$(srcdir)/o/prog.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/prog.c' object='o/lib_libbase_gcl_gprof_a-prog.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-prog.obj `if test -f 'o/prog.c'; then $(CYGPATH_W) 'o/prog.c'; else $(CYGPATH_W) '$(srcdir)/o/prog.c'; fi` o/lib_libbase_gcl_gprof_a-multival.o: o/multival.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-multival.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Tpo -c -o o/lib_libbase_gcl_gprof_a-multival.o `test -f 'o/multival.c' || echo '$(srcdir)/'`o/multival.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/multival.c' object='o/lib_libbase_gcl_gprof_a-multival.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-multival.o `test -f 'o/multival.c' || echo '$(srcdir)/'`o/multival.c o/lib_libbase_gcl_gprof_a-multival.obj: o/multival.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-multival.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Tpo -c -o o/lib_libbase_gcl_gprof_a-multival.obj `if test -f 'o/multival.c'; then $(CYGPATH_W) 'o/multival.c'; else $(CYGPATH_W) '$(srcdir)/o/multival.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/multival.c' object='o/lib_libbase_gcl_gprof_a-multival.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-multival.obj `if test -f 'o/multival.c'; then $(CYGPATH_W) 'o/multival.c'; else $(CYGPATH_W) '$(srcdir)/o/multival.c'; fi` o/lib_libbase_gcl_gprof_a-catch.o: o/catch.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-catch.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Tpo -c -o o/lib_libbase_gcl_gprof_a-catch.o `test -f 'o/catch.c' || echo '$(srcdir)/'`o/catch.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/catch.c' object='o/lib_libbase_gcl_gprof_a-catch.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-catch.o `test -f 'o/catch.c' || echo '$(srcdir)/'`o/catch.c o/lib_libbase_gcl_gprof_a-catch.obj: o/catch.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-catch.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Tpo -c -o o/lib_libbase_gcl_gprof_a-catch.obj `if test -f 'o/catch.c'; then $(CYGPATH_W) 'o/catch.c'; else $(CYGPATH_W) '$(srcdir)/o/catch.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/catch.c' object='o/lib_libbase_gcl_gprof_a-catch.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-catch.obj `if test -f 'o/catch.c'; then $(CYGPATH_W) 'o/catch.c'; else $(CYGPATH_W) '$(srcdir)/o/catch.c'; fi` o/lib_libbase_gcl_gprof_a-cfun.o: o/cfun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-cfun.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Tpo -c -o o/lib_libbase_gcl_gprof_a-cfun.o `test -f 'o/cfun.c' || echo '$(srcdir)/'`o/cfun.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/cfun.c' object='o/lib_libbase_gcl_gprof_a-cfun.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-cfun.o `test -f 'o/cfun.c' || echo '$(srcdir)/'`o/cfun.c o/lib_libbase_gcl_gprof_a-cfun.obj: o/cfun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-cfun.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Tpo -c -o o/lib_libbase_gcl_gprof_a-cfun.obj `if test -f 'o/cfun.c'; then $(CYGPATH_W) 'o/cfun.c'; else $(CYGPATH_W) '$(srcdir)/o/cfun.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/cfun.c' object='o/lib_libbase_gcl_gprof_a-cfun.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-cfun.obj `if test -f 'o/cfun.c'; then $(CYGPATH_W) 'o/cfun.c'; else $(CYGPATH_W) '$(srcdir)/o/cfun.c'; fi` o/lib_libbase_gcl_gprof_a-cmpaux.o: o/cmpaux.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-cmpaux.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Tpo -c -o o/lib_libbase_gcl_gprof_a-cmpaux.o `test -f 'o/cmpaux.c' || echo '$(srcdir)/'`o/cmpaux.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/cmpaux.c' object='o/lib_libbase_gcl_gprof_a-cmpaux.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-cmpaux.o `test -f 'o/cmpaux.c' || echo '$(srcdir)/'`o/cmpaux.c o/lib_libbase_gcl_gprof_a-cmpaux.obj: o/cmpaux.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-cmpaux.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Tpo -c -o o/lib_libbase_gcl_gprof_a-cmpaux.obj `if test -f 'o/cmpaux.c'; then $(CYGPATH_W) 'o/cmpaux.c'; else $(CYGPATH_W) '$(srcdir)/o/cmpaux.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/cmpaux.c' object='o/lib_libbase_gcl_gprof_a-cmpaux.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-cmpaux.obj `if test -f 'o/cmpaux.c'; then $(CYGPATH_W) 'o/cmpaux.c'; else $(CYGPATH_W) '$(srcdir)/o/cmpaux.c'; fi` o/lib_libbase_gcl_gprof_a-big.o: o/big.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-big.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Tpo -c -o o/lib_libbase_gcl_gprof_a-big.o `test -f 'o/big.c' || echo '$(srcdir)/'`o/big.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/big.c' object='o/lib_libbase_gcl_gprof_a-big.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-big.o `test -f 'o/big.c' || echo '$(srcdir)/'`o/big.c o/lib_libbase_gcl_gprof_a-big.obj: o/big.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-big.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Tpo -c -o o/lib_libbase_gcl_gprof_a-big.obj `if test -f 'o/big.c'; then $(CYGPATH_W) 'o/big.c'; else $(CYGPATH_W) '$(srcdir)/o/big.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/big.c' object='o/lib_libbase_gcl_gprof_a-big.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-big.obj `if test -f 'o/big.c'; then $(CYGPATH_W) 'o/big.c'; else $(CYGPATH_W) '$(srcdir)/o/big.c'; fi` o/lib_libbase_gcl_gprof_a-number.o: o/number.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-number.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Tpo -c -o o/lib_libbase_gcl_gprof_a-number.o `test -f 'o/number.c' || echo '$(srcdir)/'`o/number.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/number.c' object='o/lib_libbase_gcl_gprof_a-number.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-number.o `test -f 'o/number.c' || echo '$(srcdir)/'`o/number.c o/lib_libbase_gcl_gprof_a-number.obj: o/number.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-number.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Tpo -c -o o/lib_libbase_gcl_gprof_a-number.obj `if test -f 'o/number.c'; then $(CYGPATH_W) 'o/number.c'; else $(CYGPATH_W) '$(srcdir)/o/number.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/number.c' object='o/lib_libbase_gcl_gprof_a-number.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-number.obj `if test -f 'o/number.c'; then $(CYGPATH_W) 'o/number.c'; else $(CYGPATH_W) '$(srcdir)/o/number.c'; fi` o/lib_libbase_gcl_gprof_a-num_pred.o: o/num_pred.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_pred.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_pred.o `test -f 'o/num_pred.c' || echo '$(srcdir)/'`o/num_pred.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_pred.c' object='o/lib_libbase_gcl_gprof_a-num_pred.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_pred.o `test -f 'o/num_pred.c' || echo '$(srcdir)/'`o/num_pred.c o/lib_libbase_gcl_gprof_a-num_pred.obj: o/num_pred.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_pred.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_pred.obj `if test -f 'o/num_pred.c'; then $(CYGPATH_W) 'o/num_pred.c'; else $(CYGPATH_W) '$(srcdir)/o/num_pred.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_pred.c' object='o/lib_libbase_gcl_gprof_a-num_pred.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_pred.obj `if test -f 'o/num_pred.c'; then $(CYGPATH_W) 'o/num_pred.c'; else $(CYGPATH_W) '$(srcdir)/o/num_pred.c'; fi` o/lib_libbase_gcl_gprof_a-num_comp.o: o/num_comp.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_comp.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_comp.o `test -f 'o/num_comp.c' || echo '$(srcdir)/'`o/num_comp.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_comp.c' object='o/lib_libbase_gcl_gprof_a-num_comp.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_comp.o `test -f 'o/num_comp.c' || echo '$(srcdir)/'`o/num_comp.c o/lib_libbase_gcl_gprof_a-num_comp.obj: o/num_comp.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_comp.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_comp.obj `if test -f 'o/num_comp.c'; then $(CYGPATH_W) 'o/num_comp.c'; else $(CYGPATH_W) '$(srcdir)/o/num_comp.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_comp.c' object='o/lib_libbase_gcl_gprof_a-num_comp.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_comp.obj `if test -f 'o/num_comp.c'; then $(CYGPATH_W) 'o/num_comp.c'; else $(CYGPATH_W) '$(srcdir)/o/num_comp.c'; fi` o/lib_libbase_gcl_gprof_a-num_arith.o: o/num_arith.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_arith.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_arith.o `test -f 'o/num_arith.c' || echo '$(srcdir)/'`o/num_arith.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_arith.c' object='o/lib_libbase_gcl_gprof_a-num_arith.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_arith.o `test -f 'o/num_arith.c' || echo '$(srcdir)/'`o/num_arith.c o/lib_libbase_gcl_gprof_a-num_arith.obj: o/num_arith.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_arith.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_arith.obj `if test -f 'o/num_arith.c'; then $(CYGPATH_W) 'o/num_arith.c'; else $(CYGPATH_W) '$(srcdir)/o/num_arith.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_arith.c' object='o/lib_libbase_gcl_gprof_a-num_arith.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_arith.obj `if test -f 'o/num_arith.c'; then $(CYGPATH_W) 'o/num_arith.c'; else $(CYGPATH_W) '$(srcdir)/o/num_arith.c'; fi` o/lib_libbase_gcl_gprof_a-num_sfun.o: o/num_sfun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_sfun.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_sfun.o `test -f 'o/num_sfun.c' || echo '$(srcdir)/'`o/num_sfun.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_sfun.c' object='o/lib_libbase_gcl_gprof_a-num_sfun.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_sfun.o `test -f 'o/num_sfun.c' || echo '$(srcdir)/'`o/num_sfun.c o/lib_libbase_gcl_gprof_a-num_sfun.obj: o/num_sfun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_sfun.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_sfun.obj `if test -f 'o/num_sfun.c'; then $(CYGPATH_W) 'o/num_sfun.c'; else $(CYGPATH_W) '$(srcdir)/o/num_sfun.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_sfun.c' object='o/lib_libbase_gcl_gprof_a-num_sfun.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_sfun.obj `if test -f 'o/num_sfun.c'; then $(CYGPATH_W) 'o/num_sfun.c'; else $(CYGPATH_W) '$(srcdir)/o/num_sfun.c'; fi` o/lib_libbase_gcl_gprof_a-num_co.o: o/num_co.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_co.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_co.o `test -f 'o/num_co.c' || echo '$(srcdir)/'`o/num_co.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_co.c' object='o/lib_libbase_gcl_gprof_a-num_co.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_co.o `test -f 'o/num_co.c' || echo '$(srcdir)/'`o/num_co.c o/lib_libbase_gcl_gprof_a-num_co.obj: o/num_co.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_co.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_co.obj `if test -f 'o/num_co.c'; then $(CYGPATH_W) 'o/num_co.c'; else $(CYGPATH_W) '$(srcdir)/o/num_co.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_co.c' object='o/lib_libbase_gcl_gprof_a-num_co.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_co.obj `if test -f 'o/num_co.c'; then $(CYGPATH_W) 'o/num_co.c'; else $(CYGPATH_W) '$(srcdir)/o/num_co.c'; fi` o/lib_libbase_gcl_gprof_a-num_log.o: o/num_log.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_log.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_log.o `test -f 'o/num_log.c' || echo '$(srcdir)/'`o/num_log.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_log.c' object='o/lib_libbase_gcl_gprof_a-num_log.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_log.o `test -f 'o/num_log.c' || echo '$(srcdir)/'`o/num_log.c o/lib_libbase_gcl_gprof_a-num_log.obj: o/num_log.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_log.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_log.obj `if test -f 'o/num_log.c'; then $(CYGPATH_W) 'o/num_log.c'; else $(CYGPATH_W) '$(srcdir)/o/num_log.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_log.c' object='o/lib_libbase_gcl_gprof_a-num_log.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_log.obj `if test -f 'o/num_log.c'; then $(CYGPATH_W) 'o/num_log.c'; else $(CYGPATH_W) '$(srcdir)/o/num_log.c'; fi` o/lib_libbase_gcl_gprof_a-num_rand.o: o/num_rand.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_rand.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_rand.o `test -f 'o/num_rand.c' || echo '$(srcdir)/'`o/num_rand.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_rand.c' object='o/lib_libbase_gcl_gprof_a-num_rand.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_rand.o `test -f 'o/num_rand.c' || echo '$(srcdir)/'`o/num_rand.c o/lib_libbase_gcl_gprof_a-num_rand.obj: o/num_rand.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-num_rand.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Tpo -c -o o/lib_libbase_gcl_gprof_a-num_rand.obj `if test -f 'o/num_rand.c'; then $(CYGPATH_W) 'o/num_rand.c'; else $(CYGPATH_W) '$(srcdir)/o/num_rand.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/num_rand.c' object='o/lib_libbase_gcl_gprof_a-num_rand.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-num_rand.obj `if test -f 'o/num_rand.c'; then $(CYGPATH_W) 'o/num_rand.c'; else $(CYGPATH_W) '$(srcdir)/o/num_rand.c'; fi` o/lib_libbase_gcl_gprof_a-earith.o: o/earith.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-earith.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Tpo -c -o o/lib_libbase_gcl_gprof_a-earith.o `test -f 'o/earith.c' || echo '$(srcdir)/'`o/earith.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/earith.c' object='o/lib_libbase_gcl_gprof_a-earith.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-earith.o `test -f 'o/earith.c' || echo '$(srcdir)/'`o/earith.c o/lib_libbase_gcl_gprof_a-earith.obj: o/earith.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-earith.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Tpo -c -o o/lib_libbase_gcl_gprof_a-earith.obj `if test -f 'o/earith.c'; then $(CYGPATH_W) 'o/earith.c'; else $(CYGPATH_W) '$(srcdir)/o/earith.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/earith.c' object='o/lib_libbase_gcl_gprof_a-earith.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-earith.obj `if test -f 'o/earith.c'; then $(CYGPATH_W) 'o/earith.c'; else $(CYGPATH_W) '$(srcdir)/o/earith.c'; fi` o/lib_libbase_gcl_gprof_a-array.o: o/array.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-array.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Tpo -c -o o/lib_libbase_gcl_gprof_a-array.o `test -f 'o/array.c' || echo '$(srcdir)/'`o/array.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/array.c' object='o/lib_libbase_gcl_gprof_a-array.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-array.o `test -f 'o/array.c' || echo '$(srcdir)/'`o/array.c o/lib_libbase_gcl_gprof_a-array.obj: o/array.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-array.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Tpo -c -o o/lib_libbase_gcl_gprof_a-array.obj `if test -f 'o/array.c'; then $(CYGPATH_W) 'o/array.c'; else $(CYGPATH_W) '$(srcdir)/o/array.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/array.c' object='o/lib_libbase_gcl_gprof_a-array.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-array.obj `if test -f 'o/array.c'; then $(CYGPATH_W) 'o/array.c'; else $(CYGPATH_W) '$(srcdir)/o/array.c'; fi` o/lib_libbase_gcl_gprof_a-regexpr.o: o/regexpr.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-regexpr.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Tpo -c -o o/lib_libbase_gcl_gprof_a-regexpr.o `test -f 'o/regexpr.c' || echo '$(srcdir)/'`o/regexpr.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/regexpr.c' object='o/lib_libbase_gcl_gprof_a-regexpr.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-regexpr.o `test -f 'o/regexpr.c' || echo '$(srcdir)/'`o/regexpr.c o/lib_libbase_gcl_gprof_a-regexpr.obj: o/regexpr.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-regexpr.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Tpo -c -o o/lib_libbase_gcl_gprof_a-regexpr.obj `if test -f 'o/regexpr.c'; then $(CYGPATH_W) 'o/regexpr.c'; else $(CYGPATH_W) '$(srcdir)/o/regexpr.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/regexpr.c' object='o/lib_libbase_gcl_gprof_a-regexpr.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-regexpr.obj `if test -f 'o/regexpr.c'; then $(CYGPATH_W) 'o/regexpr.c'; else $(CYGPATH_W) '$(srcdir)/o/regexpr.c'; fi` o/lib_libbase_gcl_gprof_a-structure.o: o/structure.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-structure.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Tpo -c -o o/lib_libbase_gcl_gprof_a-structure.o `test -f 'o/structure.c' || echo '$(srcdir)/'`o/structure.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/structure.c' object='o/lib_libbase_gcl_gprof_a-structure.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-structure.o `test -f 'o/structure.c' || echo '$(srcdir)/'`o/structure.c o/lib_libbase_gcl_gprof_a-structure.obj: o/structure.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-structure.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Tpo -c -o o/lib_libbase_gcl_gprof_a-structure.obj `if test -f 'o/structure.c'; then $(CYGPATH_W) 'o/structure.c'; else $(CYGPATH_W) '$(srcdir)/o/structure.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/structure.c' object='o/lib_libbase_gcl_gprof_a-structure.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-structure.obj `if test -f 'o/structure.c'; then $(CYGPATH_W) 'o/structure.c'; else $(CYGPATH_W) '$(srcdir)/o/structure.c'; fi` o/lib_libbase_gcl_gprof_a-toplevel.o: o/toplevel.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-toplevel.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Tpo -c -o o/lib_libbase_gcl_gprof_a-toplevel.o `test -f 'o/toplevel.c' || echo '$(srcdir)/'`o/toplevel.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/toplevel.c' object='o/lib_libbase_gcl_gprof_a-toplevel.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-toplevel.o `test -f 'o/toplevel.c' || echo '$(srcdir)/'`o/toplevel.c o/lib_libbase_gcl_gprof_a-toplevel.obj: o/toplevel.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-toplevel.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Tpo -c -o o/lib_libbase_gcl_gprof_a-toplevel.obj `if test -f 'o/toplevel.c'; then $(CYGPATH_W) 'o/toplevel.c'; else $(CYGPATH_W) '$(srcdir)/o/toplevel.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/toplevel.c' object='o/lib_libbase_gcl_gprof_a-toplevel.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-toplevel.obj `if test -f 'o/toplevel.c'; then $(CYGPATH_W) 'o/toplevel.c'; else $(CYGPATH_W) '$(srcdir)/o/toplevel.c'; fi` o/lib_libbase_gcl_gprof_a-backq.o: o/backq.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-backq.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Tpo -c -o o/lib_libbase_gcl_gprof_a-backq.o `test -f 'o/backq.c' || echo '$(srcdir)/'`o/backq.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/backq.c' object='o/lib_libbase_gcl_gprof_a-backq.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-backq.o `test -f 'o/backq.c' || echo '$(srcdir)/'`o/backq.c o/lib_libbase_gcl_gprof_a-backq.obj: o/backq.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-backq.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Tpo -c -o o/lib_libbase_gcl_gprof_a-backq.obj `if test -f 'o/backq.c'; then $(CYGPATH_W) 'o/backq.c'; else $(CYGPATH_W) '$(srcdir)/o/backq.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/backq.c' object='o/lib_libbase_gcl_gprof_a-backq.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-backq.obj `if test -f 'o/backq.c'; then $(CYGPATH_W) 'o/backq.c'; else $(CYGPATH_W) '$(srcdir)/o/backq.c'; fi` o/lib_libbase_gcl_gprof_a-format.o: o/format.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-format.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Tpo -c -o o/lib_libbase_gcl_gprof_a-format.o `test -f 'o/format.c' || echo '$(srcdir)/'`o/format.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/format.c' object='o/lib_libbase_gcl_gprof_a-format.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-format.o `test -f 'o/format.c' || echo '$(srcdir)/'`o/format.c o/lib_libbase_gcl_gprof_a-format.obj: o/format.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-format.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Tpo -c -o o/lib_libbase_gcl_gprof_a-format.obj `if test -f 'o/format.c'; then $(CYGPATH_W) 'o/format.c'; else $(CYGPATH_W) '$(srcdir)/o/format.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/format.c' object='o/lib_libbase_gcl_gprof_a-format.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-format.obj `if test -f 'o/format.c'; then $(CYGPATH_W) 'o/format.c'; else $(CYGPATH_W) '$(srcdir)/o/format.c'; fi` o/lib_libbase_gcl_gprof_a-unixfsys.o: o/unixfsys.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixfsys.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixfsys.o `test -f 'o/unixfsys.c' || echo '$(srcdir)/'`o/unixfsys.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixfsys.c' object='o/lib_libbase_gcl_gprof_a-unixfsys.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixfsys.o `test -f 'o/unixfsys.c' || echo '$(srcdir)/'`o/unixfsys.c o/lib_libbase_gcl_gprof_a-unixfsys.obj: o/unixfsys.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixfsys.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixfsys.obj `if test -f 'o/unixfsys.c'; then $(CYGPATH_W) 'o/unixfsys.c'; else $(CYGPATH_W) '$(srcdir)/o/unixfsys.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixfsys.c' object='o/lib_libbase_gcl_gprof_a-unixfsys.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixfsys.obj `if test -f 'o/unixfsys.c'; then $(CYGPATH_W) 'o/unixfsys.c'; else $(CYGPATH_W) '$(srcdir)/o/unixfsys.c'; fi` o/lib_libbase_gcl_gprof_a-unixfasl.o: o/unixfasl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixfasl.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixfasl.o `test -f 'o/unixfasl.c' || echo '$(srcdir)/'`o/unixfasl.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixfasl.c' object='o/lib_libbase_gcl_gprof_a-unixfasl.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixfasl.o `test -f 'o/unixfasl.c' || echo '$(srcdir)/'`o/unixfasl.c o/lib_libbase_gcl_gprof_a-unixfasl.obj: o/unixfasl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixfasl.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixfasl.obj `if test -f 'o/unixfasl.c'; then $(CYGPATH_W) 'o/unixfasl.c'; else $(CYGPATH_W) '$(srcdir)/o/unixfasl.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixfasl.c' object='o/lib_libbase_gcl_gprof_a-unixfasl.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixfasl.obj `if test -f 'o/unixfasl.c'; then $(CYGPATH_W) 'o/unixfasl.c'; else $(CYGPATH_W) '$(srcdir)/o/unixfasl.c'; fi` o/lib_libbase_gcl_gprof_a-error.o: o/error.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-error.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Tpo -c -o o/lib_libbase_gcl_gprof_a-error.o `test -f 'o/error.c' || echo '$(srcdir)/'`o/error.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/error.c' object='o/lib_libbase_gcl_gprof_a-error.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-error.o `test -f 'o/error.c' || echo '$(srcdir)/'`o/error.c o/lib_libbase_gcl_gprof_a-error.obj: o/error.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-error.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Tpo -c -o o/lib_libbase_gcl_gprof_a-error.obj `if test -f 'o/error.c'; then $(CYGPATH_W) 'o/error.c'; else $(CYGPATH_W) '$(srcdir)/o/error.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/error.c' object='o/lib_libbase_gcl_gprof_a-error.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-error.obj `if test -f 'o/error.c'; then $(CYGPATH_W) 'o/error.c'; else $(CYGPATH_W) '$(srcdir)/o/error.c'; fi` o/lib_libbase_gcl_gprof_a-unixtime.o: o/unixtime.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixtime.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixtime.o `test -f 'o/unixtime.c' || echo '$(srcdir)/'`o/unixtime.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixtime.c' object='o/lib_libbase_gcl_gprof_a-unixtime.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixtime.o `test -f 'o/unixtime.c' || echo '$(srcdir)/'`o/unixtime.c o/lib_libbase_gcl_gprof_a-unixtime.obj: o/unixtime.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixtime.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixtime.obj `if test -f 'o/unixtime.c'; then $(CYGPATH_W) 'o/unixtime.c'; else $(CYGPATH_W) '$(srcdir)/o/unixtime.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixtime.c' object='o/lib_libbase_gcl_gprof_a-unixtime.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixtime.obj `if test -f 'o/unixtime.c'; then $(CYGPATH_W) 'o/unixtime.c'; else $(CYGPATH_W) '$(srcdir)/o/unixtime.c'; fi` o/lib_libbase_gcl_gprof_a-unixsys.o: o/unixsys.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixsys.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixsys.o `test -f 'o/unixsys.c' || echo '$(srcdir)/'`o/unixsys.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixsys.c' object='o/lib_libbase_gcl_gprof_a-unixsys.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixsys.o `test -f 'o/unixsys.c' || echo '$(srcdir)/'`o/unixsys.c o/lib_libbase_gcl_gprof_a-unixsys.obj: o/unixsys.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixsys.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixsys.obj `if test -f 'o/unixsys.c'; then $(CYGPATH_W) 'o/unixsys.c'; else $(CYGPATH_W) '$(srcdir)/o/unixsys.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixsys.c' object='o/lib_libbase_gcl_gprof_a-unixsys.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixsys.obj `if test -f 'o/unixsys.c'; then $(CYGPATH_W) 'o/unixsys.c'; else $(CYGPATH_W) '$(srcdir)/o/unixsys.c'; fi` o/lib_libbase_gcl_gprof_a-unixsave.o: o/unixsave.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixsave.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixsave.o `test -f 'o/unixsave.c' || echo '$(srcdir)/'`o/unixsave.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixsave.c' object='o/lib_libbase_gcl_gprof_a-unixsave.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixsave.o `test -f 'o/unixsave.c' || echo '$(srcdir)/'`o/unixsave.c o/lib_libbase_gcl_gprof_a-unixsave.obj: o/unixsave.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-unixsave.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Tpo -c -o o/lib_libbase_gcl_gprof_a-unixsave.obj `if test -f 'o/unixsave.c'; then $(CYGPATH_W) 'o/unixsave.c'; else $(CYGPATH_W) '$(srcdir)/o/unixsave.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/unixsave.c' object='o/lib_libbase_gcl_gprof_a-unixsave.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-unixsave.obj `if test -f 'o/unixsave.c'; then $(CYGPATH_W) 'o/unixsave.c'; else $(CYGPATH_W) '$(srcdir)/o/unixsave.c'; fi` o/lib_libbase_gcl_gprof_a-funlink.o: o/funlink.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-funlink.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Tpo -c -o o/lib_libbase_gcl_gprof_a-funlink.o `test -f 'o/funlink.c' || echo '$(srcdir)/'`o/funlink.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/funlink.c' object='o/lib_libbase_gcl_gprof_a-funlink.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-funlink.o `test -f 'o/funlink.c' || echo '$(srcdir)/'`o/funlink.c o/lib_libbase_gcl_gprof_a-funlink.obj: o/funlink.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-funlink.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Tpo -c -o o/lib_libbase_gcl_gprof_a-funlink.obj `if test -f 'o/funlink.c'; then $(CYGPATH_W) 'o/funlink.c'; else $(CYGPATH_W) '$(srcdir)/o/funlink.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/funlink.c' object='o/lib_libbase_gcl_gprof_a-funlink.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-funlink.obj `if test -f 'o/funlink.c'; then $(CYGPATH_W) 'o/funlink.c'; else $(CYGPATH_W) '$(srcdir)/o/funlink.c'; fi` o/lib_libbase_gcl_gprof_a-fat_string.o: o/fat_string.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-fat_string.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Tpo -c -o o/lib_libbase_gcl_gprof_a-fat_string.o `test -f 'o/fat_string.c' || echo '$(srcdir)/'`o/fat_string.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/fat_string.c' object='o/lib_libbase_gcl_gprof_a-fat_string.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-fat_string.o `test -f 'o/fat_string.c' || echo '$(srcdir)/'`o/fat_string.c o/lib_libbase_gcl_gprof_a-fat_string.obj: o/fat_string.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-fat_string.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Tpo -c -o o/lib_libbase_gcl_gprof_a-fat_string.obj `if test -f 'o/fat_string.c'; then $(CYGPATH_W) 'o/fat_string.c'; else $(CYGPATH_W) '$(srcdir)/o/fat_string.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/fat_string.c' object='o/lib_libbase_gcl_gprof_a-fat_string.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-fat_string.obj `if test -f 'o/fat_string.c'; then $(CYGPATH_W) 'o/fat_string.c'; else $(CYGPATH_W) '$(srcdir)/o/fat_string.c'; fi` o/lib_libbase_gcl_gprof_a-run_process.o: o/run_process.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-run_process.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Tpo -c -o o/lib_libbase_gcl_gprof_a-run_process.o `test -f 'o/run_process.c' || echo '$(srcdir)/'`o/run_process.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/run_process.c' object='o/lib_libbase_gcl_gprof_a-run_process.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-run_process.o `test -f 'o/run_process.c' || echo '$(srcdir)/'`o/run_process.c o/lib_libbase_gcl_gprof_a-run_process.obj: o/run_process.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-run_process.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Tpo -c -o o/lib_libbase_gcl_gprof_a-run_process.obj `if test -f 'o/run_process.c'; then $(CYGPATH_W) 'o/run_process.c'; else $(CYGPATH_W) '$(srcdir)/o/run_process.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/run_process.c' object='o/lib_libbase_gcl_gprof_a-run_process.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-run_process.obj `if test -f 'o/run_process.c'; then $(CYGPATH_W) 'o/run_process.c'; else $(CYGPATH_W) '$(srcdir)/o/run_process.c'; fi` o/lib_libbase_gcl_gprof_a-nfunlink.o: o/nfunlink.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-nfunlink.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Tpo -c -o o/lib_libbase_gcl_gprof_a-nfunlink.o `test -f 'o/nfunlink.c' || echo '$(srcdir)/'`o/nfunlink.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/nfunlink.c' object='o/lib_libbase_gcl_gprof_a-nfunlink.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-nfunlink.o `test -f 'o/nfunlink.c' || echo '$(srcdir)/'`o/nfunlink.c o/lib_libbase_gcl_gprof_a-nfunlink.obj: o/nfunlink.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-nfunlink.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Tpo -c -o o/lib_libbase_gcl_gprof_a-nfunlink.obj `if test -f 'o/nfunlink.c'; then $(CYGPATH_W) 'o/nfunlink.c'; else $(CYGPATH_W) '$(srcdir)/o/nfunlink.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/nfunlink.c' object='o/lib_libbase_gcl_gprof_a-nfunlink.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-nfunlink.obj `if test -f 'o/nfunlink.c'; then $(CYGPATH_W) 'o/nfunlink.c'; else $(CYGPATH_W) '$(srcdir)/o/nfunlink.c'; fi` o/lib_libbase_gcl_gprof_a-usig.o: o/usig.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-usig.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Tpo -c -o o/lib_libbase_gcl_gprof_a-usig.o `test -f 'o/usig.c' || echo '$(srcdir)/'`o/usig.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/usig.c' object='o/lib_libbase_gcl_gprof_a-usig.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-usig.o `test -f 'o/usig.c' || echo '$(srcdir)/'`o/usig.c o/lib_libbase_gcl_gprof_a-usig.obj: o/usig.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-usig.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Tpo -c -o o/lib_libbase_gcl_gprof_a-usig.obj `if test -f 'o/usig.c'; then $(CYGPATH_W) 'o/usig.c'; else $(CYGPATH_W) '$(srcdir)/o/usig.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/usig.c' object='o/lib_libbase_gcl_gprof_a-usig.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-usig.obj `if test -f 'o/usig.c'; then $(CYGPATH_W) 'o/usig.c'; else $(CYGPATH_W) '$(srcdir)/o/usig.c'; fi` o/lib_libbase_gcl_gprof_a-usig2.o: o/usig2.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-usig2.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Tpo -c -o o/lib_libbase_gcl_gprof_a-usig2.o `test -f 'o/usig2.c' || echo '$(srcdir)/'`o/usig2.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/usig2.c' object='o/lib_libbase_gcl_gprof_a-usig2.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-usig2.o `test -f 'o/usig2.c' || echo '$(srcdir)/'`o/usig2.c o/lib_libbase_gcl_gprof_a-usig2.obj: o/usig2.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-usig2.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Tpo -c -o o/lib_libbase_gcl_gprof_a-usig2.obj `if test -f 'o/usig2.c'; then $(CYGPATH_W) 'o/usig2.c'; else $(CYGPATH_W) '$(srcdir)/o/usig2.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/usig2.c' object='o/lib_libbase_gcl_gprof_a-usig2.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-usig2.obj `if test -f 'o/usig2.c'; then $(CYGPATH_W) 'o/usig2.c'; else $(CYGPATH_W) '$(srcdir)/o/usig2.c'; fi` o/lib_libbase_gcl_gprof_a-utils.o: o/utils.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-utils.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Tpo -c -o o/lib_libbase_gcl_gprof_a-utils.o `test -f 'o/utils.c' || echo '$(srcdir)/'`o/utils.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/utils.c' object='o/lib_libbase_gcl_gprof_a-utils.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-utils.o `test -f 'o/utils.c' || echo '$(srcdir)/'`o/utils.c o/lib_libbase_gcl_gprof_a-utils.obj: o/utils.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-utils.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Tpo -c -o o/lib_libbase_gcl_gprof_a-utils.obj `if test -f 'o/utils.c'; then $(CYGPATH_W) 'o/utils.c'; else $(CYGPATH_W) '$(srcdir)/o/utils.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/utils.c' object='o/lib_libbase_gcl_gprof_a-utils.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-utils.obj `if test -f 'o/utils.c'; then $(CYGPATH_W) 'o/utils.c'; else $(CYGPATH_W) '$(srcdir)/o/utils.c'; fi` o/lib_libbase_gcl_gprof_a-makefun.o: o/makefun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-makefun.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Tpo -c -o o/lib_libbase_gcl_gprof_a-makefun.o `test -f 'o/makefun.c' || echo '$(srcdir)/'`o/makefun.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/makefun.c' object='o/lib_libbase_gcl_gprof_a-makefun.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-makefun.o `test -f 'o/makefun.c' || echo '$(srcdir)/'`o/makefun.c o/lib_libbase_gcl_gprof_a-makefun.obj: o/makefun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-makefun.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Tpo -c -o o/lib_libbase_gcl_gprof_a-makefun.obj `if test -f 'o/makefun.c'; then $(CYGPATH_W) 'o/makefun.c'; else $(CYGPATH_W) '$(srcdir)/o/makefun.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/makefun.c' object='o/lib_libbase_gcl_gprof_a-makefun.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-makefun.obj `if test -f 'o/makefun.c'; then $(CYGPATH_W) 'o/makefun.c'; else $(CYGPATH_W) '$(srcdir)/o/makefun.c'; fi` o/lib_libbase_gcl_gprof_a-sockets.o: o/sockets.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-sockets.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Tpo -c -o o/lib_libbase_gcl_gprof_a-sockets.o `test -f 'o/sockets.c' || echo '$(srcdir)/'`o/sockets.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/sockets.c' object='o/lib_libbase_gcl_gprof_a-sockets.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-sockets.o `test -f 'o/sockets.c' || echo '$(srcdir)/'`o/sockets.c o/lib_libbase_gcl_gprof_a-sockets.obj: o/sockets.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-sockets.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Tpo -c -o o/lib_libbase_gcl_gprof_a-sockets.obj `if test -f 'o/sockets.c'; then $(CYGPATH_W) 'o/sockets.c'; else $(CYGPATH_W) '$(srcdir)/o/sockets.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/sockets.c' object='o/lib_libbase_gcl_gprof_a-sockets.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-sockets.obj `if test -f 'o/sockets.c'; then $(CYGPATH_W) 'o/sockets.c'; else $(CYGPATH_W) '$(srcdir)/o/sockets.c'; fi` o/lib_libbase_gcl_gprof_a-gmp_wrappers.o: o/gmp_wrappers.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gmp_wrappers.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Tpo -c -o o/lib_libbase_gcl_gprof_a-gmp_wrappers.o `test -f 'o/gmp_wrappers.c' || echo '$(srcdir)/'`o/gmp_wrappers.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gmp_wrappers.c' object='o/lib_libbase_gcl_gprof_a-gmp_wrappers.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gmp_wrappers.o `test -f 'o/gmp_wrappers.c' || echo '$(srcdir)/'`o/gmp_wrappers.c o/lib_libbase_gcl_gprof_a-gmp_wrappers.obj: o/gmp_wrappers.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gmp_wrappers.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Tpo -c -o o/lib_libbase_gcl_gprof_a-gmp_wrappers.obj `if test -f 'o/gmp_wrappers.c'; then $(CYGPATH_W) 'o/gmp_wrappers.c'; else $(CYGPATH_W) '$(srcdir)/o/gmp_wrappers.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gmp_wrappers.c' object='o/lib_libbase_gcl_gprof_a-gmp_wrappers.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gmp_wrappers.obj `if test -f 'o/gmp_wrappers.c'; then $(CYGPATH_W) 'o/gmp_wrappers.c'; else $(CYGPATH_W) '$(srcdir)/o/gmp_wrappers.c'; fi` o/lib_libbase_gcl_gprof_a-clxsocket.o: o/clxsocket.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-clxsocket.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Tpo -c -o o/lib_libbase_gcl_gprof_a-clxsocket.o `test -f 'o/clxsocket.c' || echo '$(srcdir)/'`o/clxsocket.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/clxsocket.c' object='o/lib_libbase_gcl_gprof_a-clxsocket.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-clxsocket.o `test -f 'o/clxsocket.c' || echo '$(srcdir)/'`o/clxsocket.c o/lib_libbase_gcl_gprof_a-clxsocket.obj: o/clxsocket.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-clxsocket.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Tpo -c -o o/lib_libbase_gcl_gprof_a-clxsocket.obj `if test -f 'o/clxsocket.c'; then $(CYGPATH_W) 'o/clxsocket.c'; else $(CYGPATH_W) '$(srcdir)/o/clxsocket.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/clxsocket.c' object='o/lib_libbase_gcl_gprof_a-clxsocket.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-clxsocket.obj `if test -f 'o/clxsocket.c'; then $(CYGPATH_W) 'o/clxsocket.c'; else $(CYGPATH_W) '$(srcdir)/o/clxsocket.c'; fi` o/lib_libbase_gcl_gprof_a-nsocket.o: o/nsocket.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-nsocket.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Tpo -c -o o/lib_libbase_gcl_gprof_a-nsocket.o `test -f 'o/nsocket.c' || echo '$(srcdir)/'`o/nsocket.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/nsocket.c' object='o/lib_libbase_gcl_gprof_a-nsocket.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-nsocket.o `test -f 'o/nsocket.c' || echo '$(srcdir)/'`o/nsocket.c o/lib_libbase_gcl_gprof_a-nsocket.obj: o/nsocket.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-nsocket.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Tpo -c -o o/lib_libbase_gcl_gprof_a-nsocket.obj `if test -f 'o/nsocket.c'; then $(CYGPATH_W) 'o/nsocket.c'; else $(CYGPATH_W) '$(srcdir)/o/nsocket.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/nsocket.c' object='o/lib_libbase_gcl_gprof_a-nsocket.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-nsocket.obj `if test -f 'o/nsocket.c'; then $(CYGPATH_W) 'o/nsocket.c'; else $(CYGPATH_W) '$(srcdir)/o/nsocket.c'; fi` o/lib_libbase_gcl_gprof_a-prelink.o: o/prelink.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-prelink.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Tpo -c -o o/lib_libbase_gcl_gprof_a-prelink.o `test -f 'o/prelink.c' || echo '$(srcdir)/'`o/prelink.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/prelink.c' object='o/lib_libbase_gcl_gprof_a-prelink.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-prelink.o `test -f 'o/prelink.c' || echo '$(srcdir)/'`o/prelink.c o/lib_libbase_gcl_gprof_a-prelink.obj: o/prelink.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-prelink.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Tpo -c -o o/lib_libbase_gcl_gprof_a-prelink.obj `if test -f 'o/prelink.c'; then $(CYGPATH_W) 'o/prelink.c'; else $(CYGPATH_W) '$(srcdir)/o/prelink.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/prelink.c' object='o/lib_libbase_gcl_gprof_a-prelink.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-prelink.obj `if test -f 'o/prelink.c'; then $(CYGPATH_W) 'o/prelink.c'; else $(CYGPATH_W) '$(srcdir)/o/prelink.c'; fi` o/lib_libbase_gcl_gprof_a-sfasl.o: o/sfasl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-sfasl.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Tpo -c -o o/lib_libbase_gcl_gprof_a-sfasl.o `test -f 'o/sfasl.c' || echo '$(srcdir)/'`o/sfasl.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/sfasl.c' object='o/lib_libbase_gcl_gprof_a-sfasl.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-sfasl.o `test -f 'o/sfasl.c' || echo '$(srcdir)/'`o/sfasl.c o/lib_libbase_gcl_gprof_a-sfasl.obj: o/sfasl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-sfasl.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Tpo -c -o o/lib_libbase_gcl_gprof_a-sfasl.obj `if test -f 'o/sfasl.c'; then $(CYGPATH_W) 'o/sfasl.c'; else $(CYGPATH_W) '$(srcdir)/o/sfasl.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/sfasl.c' object='o/lib_libbase_gcl_gprof_a-sfasl.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-sfasl.obj `if test -f 'o/sfasl.c'; then $(CYGPATH_W) 'o/sfasl.c'; else $(CYGPATH_W) '$(srcdir)/o/sfasl.c'; fi` o/lib_libbase_gcl_gprof_a-msbrk.o: o/msbrk.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-msbrk.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Tpo -c -o o/lib_libbase_gcl_gprof_a-msbrk.o `test -f 'o/msbrk.c' || echo '$(srcdir)/'`o/msbrk.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/msbrk.c' object='o/lib_libbase_gcl_gprof_a-msbrk.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-msbrk.o `test -f 'o/msbrk.c' || echo '$(srcdir)/'`o/msbrk.c o/lib_libbase_gcl_gprof_a-msbrk.obj: o/msbrk.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-msbrk.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Tpo -c -o o/lib_libbase_gcl_gprof_a-msbrk.obj `if test -f 'o/msbrk.c'; then $(CYGPATH_W) 'o/msbrk.c'; else $(CYGPATH_W) '$(srcdir)/o/msbrk.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/msbrk.c' object='o/lib_libbase_gcl_gprof_a-msbrk.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-msbrk.obj `if test -f 'o/msbrk.c'; then $(CYGPATH_W) 'o/msbrk.c'; else $(CYGPATH_W) '$(srcdir)/o/msbrk.c'; fi` o/lib_libbase_gcl_gprof_a-bcmp.o: o/bcmp.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bcmp.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Tpo -c -o o/lib_libbase_gcl_gprof_a-bcmp.o `test -f 'o/bcmp.c' || echo '$(srcdir)/'`o/bcmp.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bcmp.c' object='o/lib_libbase_gcl_gprof_a-bcmp.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bcmp.o `test -f 'o/bcmp.c' || echo '$(srcdir)/'`o/bcmp.c o/lib_libbase_gcl_gprof_a-bcmp.obj: o/bcmp.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bcmp.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Tpo -c -o o/lib_libbase_gcl_gprof_a-bcmp.obj `if test -f 'o/bcmp.c'; then $(CYGPATH_W) 'o/bcmp.c'; else $(CYGPATH_W) '$(srcdir)/o/bcmp.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bcmp.c' object='o/lib_libbase_gcl_gprof_a-bcmp.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bcmp.obj `if test -f 'o/bcmp.c'; then $(CYGPATH_W) 'o/bcmp.c'; else $(CYGPATH_W) '$(srcdir)/o/bcmp.c'; fi` o/lib_libbase_gcl_gprof_a-bcopy.o: o/bcopy.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bcopy.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Tpo -c -o o/lib_libbase_gcl_gprof_a-bcopy.o `test -f 'o/bcopy.c' || echo '$(srcdir)/'`o/bcopy.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bcopy.c' object='o/lib_libbase_gcl_gprof_a-bcopy.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bcopy.o `test -f 'o/bcopy.c' || echo '$(srcdir)/'`o/bcopy.c o/lib_libbase_gcl_gprof_a-bcopy.obj: o/bcopy.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bcopy.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Tpo -c -o o/lib_libbase_gcl_gprof_a-bcopy.obj `if test -f 'o/bcopy.c'; then $(CYGPATH_W) 'o/bcopy.c'; else $(CYGPATH_W) '$(srcdir)/o/bcopy.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bcopy.c' object='o/lib_libbase_gcl_gprof_a-bcopy.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bcopy.obj `if test -f 'o/bcopy.c'; then $(CYGPATH_W) 'o/bcopy.c'; else $(CYGPATH_W) '$(srcdir)/o/bcopy.c'; fi` o/lib_libbase_gcl_gprof_a-bzero.o: o/bzero.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bzero.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Tpo -c -o o/lib_libbase_gcl_gprof_a-bzero.o `test -f 'o/bzero.c' || echo '$(srcdir)/'`o/bzero.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bzero.c' object='o/lib_libbase_gcl_gprof_a-bzero.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bzero.o `test -f 'o/bzero.c' || echo '$(srcdir)/'`o/bzero.c o/lib_libbase_gcl_gprof_a-bzero.obj: o/bzero.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-bzero.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Tpo -c -o o/lib_libbase_gcl_gprof_a-bzero.obj `if test -f 'o/bzero.c'; then $(CYGPATH_W) 'o/bzero.c'; else $(CYGPATH_W) '$(srcdir)/o/bzero.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/bzero.c' object='o/lib_libbase_gcl_gprof_a-bzero.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-bzero.obj `if test -f 'o/bzero.c'; then $(CYGPATH_W) 'o/bzero.c'; else $(CYGPATH_W) '$(srcdir)/o/bzero.c'; fi` o/lib_libbase_gcl_gprof_a-user_init.o: o/user_init.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-user_init.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Tpo -c -o o/lib_libbase_gcl_gprof_a-user_init.o `test -f 'o/user_init.c' || echo '$(srcdir)/'`o/user_init.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/user_init.c' object='o/lib_libbase_gcl_gprof_a-user_init.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-user_init.o `test -f 'o/user_init.c' || echo '$(srcdir)/'`o/user_init.c o/lib_libbase_gcl_gprof_a-user_init.obj: o/user_init.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-user_init.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Tpo -c -o o/lib_libbase_gcl_gprof_a-user_init.obj `if test -f 'o/user_init.c'; then $(CYGPATH_W) 'o/user_init.c'; else $(CYGPATH_W) '$(srcdir)/o/user_init.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/user_init.c' object='o/lib_libbase_gcl_gprof_a-user_init.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-user_init.obj `if test -f 'o/user_init.c'; then $(CYGPATH_W) 'o/user_init.c'; else $(CYGPATH_W) '$(srcdir)/o/user_init.c'; fi` o/lib_libbase_gcl_gprof_a-user_match.o: o/user_match.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-user_match.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Tpo -c -o o/lib_libbase_gcl_gprof_a-user_match.o `test -f 'o/user_match.c' || echo '$(srcdir)/'`o/user_match.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/user_match.c' object='o/lib_libbase_gcl_gprof_a-user_match.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-user_match.o `test -f 'o/user_match.c' || echo '$(srcdir)/'`o/user_match.c o/lib_libbase_gcl_gprof_a-user_match.obj: o/user_match.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-user_match.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Tpo -c -o o/lib_libbase_gcl_gprof_a-user_match.obj `if test -f 'o/user_match.c'; then $(CYGPATH_W) 'o/user_match.c'; else $(CYGPATH_W) '$(srcdir)/o/user_match.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/user_match.c' object='o/lib_libbase_gcl_gprof_a-user_match.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-user_match.obj `if test -f 'o/user_match.c'; then $(CYGPATH_W) 'o/user_match.c'; else $(CYGPATH_W) '$(srcdir)/o/user_match.c'; fi` o/lib_libbase_gcl_gprof_a-mapfun.o: o/mapfun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-mapfun.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Tpo -c -o o/lib_libbase_gcl_gprof_a-mapfun.o `test -f 'o/mapfun.c' || echo '$(srcdir)/'`o/mapfun.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/mapfun.c' object='o/lib_libbase_gcl_gprof_a-mapfun.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-mapfun.o `test -f 'o/mapfun.c' || echo '$(srcdir)/'`o/mapfun.c o/lib_libbase_gcl_gprof_a-mapfun.obj: o/mapfun.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-mapfun.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Tpo -c -o o/lib_libbase_gcl_gprof_a-mapfun.obj `if test -f 'o/mapfun.c'; then $(CYGPATH_W) 'o/mapfun.c'; else $(CYGPATH_W) '$(srcdir)/o/mapfun.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/mapfun.c' object='o/lib_libbase_gcl_gprof_a-mapfun.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-mapfun.obj `if test -f 'o/mapfun.c'; then $(CYGPATH_W) 'o/mapfun.c'; else $(CYGPATH_W) '$(srcdir)/o/mapfun.c'; fi` o/lib_libbase_gcl_gprof_a-gprof.o: o/gprof.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gprof.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Tpo -c -o o/lib_libbase_gcl_gprof_a-gprof.o `test -f 'o/gprof.c' || echo '$(srcdir)/'`o/gprof.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gprof.c' object='o/lib_libbase_gcl_gprof_a-gprof.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gprof.o `test -f 'o/gprof.c' || echo '$(srcdir)/'`o/gprof.c o/lib_libbase_gcl_gprof_a-gprof.obj: o/gprof.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gprof.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Tpo -c -o o/lib_libbase_gcl_gprof_a-gprof.obj `if test -f 'o/gprof.c'; then $(CYGPATH_W) 'o/gprof.c'; else $(CYGPATH_W) '$(srcdir)/o/gprof.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gprof.c' object='o/lib_libbase_gcl_gprof_a-gprof.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gprof.obj `if test -f 'o/gprof.c'; then $(CYGPATH_W) 'o/gprof.c'; else $(CYGPATH_W) '$(srcdir)/o/gprof.c'; fi` o/lib_libbase_gcl_gprof_a-character.o: o/character.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-character.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Tpo -c -o o/lib_libbase_gcl_gprof_a-character.o `test -f 'o/character.c' || echo '$(srcdir)/'`o/character.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/character.c' object='o/lib_libbase_gcl_gprof_a-character.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-character.o `test -f 'o/character.c' || echo '$(srcdir)/'`o/character.c o/lib_libbase_gcl_gprof_a-character.obj: o/character.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-character.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Tpo -c -o o/lib_libbase_gcl_gprof_a-character.obj `if test -f 'o/character.c'; then $(CYGPATH_W) 'o/character.c'; else $(CYGPATH_W) '$(srcdir)/o/character.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/character.c' object='o/lib_libbase_gcl_gprof_a-character.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-character.obj `if test -f 'o/character.c'; then $(CYGPATH_W) 'o/character.c'; else $(CYGPATH_W) '$(srcdir)/o/character.c'; fi` o/lib_libbase_gcl_gprof_a-file.o: o/file.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-file.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Tpo -c -o o/lib_libbase_gcl_gprof_a-file.o `test -f 'o/file.c' || echo '$(srcdir)/'`o/file.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/file.c' object='o/lib_libbase_gcl_gprof_a-file.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-file.o `test -f 'o/file.c' || echo '$(srcdir)/'`o/file.c o/lib_libbase_gcl_gprof_a-file.obj: o/file.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-file.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Tpo -c -o o/lib_libbase_gcl_gprof_a-file.obj `if test -f 'o/file.c'; then $(CYGPATH_W) 'o/file.c'; else $(CYGPATH_W) '$(srcdir)/o/file.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/file.c' object='o/lib_libbase_gcl_gprof_a-file.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-file.obj `if test -f 'o/file.c'; then $(CYGPATH_W) 'o/file.c'; else $(CYGPATH_W) '$(srcdir)/o/file.c'; fi` o/lib_libbase_gcl_gprof_a-gcl_readline.o: o/gcl_readline.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gcl_readline.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Tpo -c -o o/lib_libbase_gcl_gprof_a-gcl_readline.o `test -f 'o/gcl_readline.c' || echo '$(srcdir)/'`o/gcl_readline.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gcl_readline.c' object='o/lib_libbase_gcl_gprof_a-gcl_readline.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gcl_readline.o `test -f 'o/gcl_readline.c' || echo '$(srcdir)/'`o/gcl_readline.c o/lib_libbase_gcl_gprof_a-gcl_readline.obj: o/gcl_readline.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-gcl_readline.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Tpo -c -o o/lib_libbase_gcl_gprof_a-gcl_readline.obj `if test -f 'o/gcl_readline.c'; then $(CYGPATH_W) 'o/gcl_readline.c'; else $(CYGPATH_W) '$(srcdir)/o/gcl_readline.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gcl_readline.c' object='o/lib_libbase_gcl_gprof_a-gcl_readline.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-gcl_readline.obj `if test -f 'o/gcl_readline.c'; then $(CYGPATH_W) 'o/gcl_readline.c'; else $(CYGPATH_W) '$(srcdir)/o/gcl_readline.c'; fi` o/lib_libbase_gcl_gprof_a-hash.o: o/hash.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-hash.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Tpo -c -o o/lib_libbase_gcl_gprof_a-hash.o `test -f 'o/hash.c' || echo '$(srcdir)/'`o/hash.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/hash.c' object='o/lib_libbase_gcl_gprof_a-hash.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-hash.o `test -f 'o/hash.c' || echo '$(srcdir)/'`o/hash.c o/lib_libbase_gcl_gprof_a-hash.obj: o/hash.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-hash.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Tpo -c -o o/lib_libbase_gcl_gprof_a-hash.obj `if test -f 'o/hash.c'; then $(CYGPATH_W) 'o/hash.c'; else $(CYGPATH_W) '$(srcdir)/o/hash.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/hash.c' object='o/lib_libbase_gcl_gprof_a-hash.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-hash.obj `if test -f 'o/hash.c'; then $(CYGPATH_W) 'o/hash.c'; else $(CYGPATH_W) '$(srcdir)/o/hash.c'; fi` o/lib_libbase_gcl_gprof_a-list.o: o/list.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-list.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Tpo -c -o o/lib_libbase_gcl_gprof_a-list.o `test -f 'o/list.c' || echo '$(srcdir)/'`o/list.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/list.c' object='o/lib_libbase_gcl_gprof_a-list.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-list.o `test -f 'o/list.c' || echo '$(srcdir)/'`o/list.c o/lib_libbase_gcl_gprof_a-list.obj: o/list.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-list.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Tpo -c -o o/lib_libbase_gcl_gprof_a-list.obj `if test -f 'o/list.c'; then $(CYGPATH_W) 'o/list.c'; else $(CYGPATH_W) '$(srcdir)/o/list.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/list.c' object='o/lib_libbase_gcl_gprof_a-list.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-list.obj `if test -f 'o/list.c'; then $(CYGPATH_W) 'o/list.c'; else $(CYGPATH_W) '$(srcdir)/o/list.c'; fi` o/lib_libbase_gcl_gprof_a-package.o: o/package.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-package.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Tpo -c -o o/lib_libbase_gcl_gprof_a-package.o `test -f 'o/package.c' || echo '$(srcdir)/'`o/package.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/package.c' object='o/lib_libbase_gcl_gprof_a-package.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-package.o `test -f 'o/package.c' || echo '$(srcdir)/'`o/package.c o/lib_libbase_gcl_gprof_a-package.obj: o/package.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-package.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Tpo -c -o o/lib_libbase_gcl_gprof_a-package.obj `if test -f 'o/package.c'; then $(CYGPATH_W) 'o/package.c'; else $(CYGPATH_W) '$(srcdir)/o/package.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/package.c' object='o/lib_libbase_gcl_gprof_a-package.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-package.obj `if test -f 'o/package.c'; then $(CYGPATH_W) 'o/package.c'; else $(CYGPATH_W) '$(srcdir)/o/package.c'; fi` o/lib_libbase_gcl_gprof_a-pathname.o: o/pathname.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-pathname.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Tpo -c -o o/lib_libbase_gcl_gprof_a-pathname.o `test -f 'o/pathname.c' || echo '$(srcdir)/'`o/pathname.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/pathname.c' object='o/lib_libbase_gcl_gprof_a-pathname.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-pathname.o `test -f 'o/pathname.c' || echo '$(srcdir)/'`o/pathname.c o/lib_libbase_gcl_gprof_a-pathname.obj: o/pathname.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-pathname.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Tpo -c -o o/lib_libbase_gcl_gprof_a-pathname.obj `if test -f 'o/pathname.c'; then $(CYGPATH_W) 'o/pathname.c'; else $(CYGPATH_W) '$(srcdir)/o/pathname.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/pathname.c' object='o/lib_libbase_gcl_gprof_a-pathname.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-pathname.obj `if test -f 'o/pathname.c'; then $(CYGPATH_W) 'o/pathname.c'; else $(CYGPATH_W) '$(srcdir)/o/pathname.c'; fi` o/lib_libbase_gcl_gprof_a-print.o: o/print.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-print.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Tpo -c -o o/lib_libbase_gcl_gprof_a-print.o `test -f 'o/print.c' || echo '$(srcdir)/'`o/print.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/print.c' object='o/lib_libbase_gcl_gprof_a-print.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-print.o `test -f 'o/print.c' || echo '$(srcdir)/'`o/print.c o/lib_libbase_gcl_gprof_a-print.obj: o/print.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-print.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Tpo -c -o o/lib_libbase_gcl_gprof_a-print.obj `if test -f 'o/print.c'; then $(CYGPATH_W) 'o/print.c'; else $(CYGPATH_W) '$(srcdir)/o/print.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/print.c' object='o/lib_libbase_gcl_gprof_a-print.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-print.obj `if test -f 'o/print.c'; then $(CYGPATH_W) 'o/print.c'; else $(CYGPATH_W) '$(srcdir)/o/print.c'; fi` o/lib_libbase_gcl_gprof_a-read.o: o/read.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-read.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Tpo -c -o o/lib_libbase_gcl_gprof_a-read.o `test -f 'o/read.c' || echo '$(srcdir)/'`o/read.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/read.c' object='o/lib_libbase_gcl_gprof_a-read.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-read.o `test -f 'o/read.c' || echo '$(srcdir)/'`o/read.c o/lib_libbase_gcl_gprof_a-read.obj: o/read.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-read.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Tpo -c -o o/lib_libbase_gcl_gprof_a-read.obj `if test -f 'o/read.c'; then $(CYGPATH_W) 'o/read.c'; else $(CYGPATH_W) '$(srcdir)/o/read.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/read.c' object='o/lib_libbase_gcl_gprof_a-read.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-read.obj `if test -f 'o/read.c'; then $(CYGPATH_W) 'o/read.c'; else $(CYGPATH_W) '$(srcdir)/o/read.c'; fi` o/lib_libbase_gcl_gprof_a-sequence.o: o/sequence.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-sequence.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Tpo -c -o o/lib_libbase_gcl_gprof_a-sequence.o `test -f 'o/sequence.c' || echo '$(srcdir)/'`o/sequence.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/sequence.c' object='o/lib_libbase_gcl_gprof_a-sequence.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-sequence.o `test -f 'o/sequence.c' || echo '$(srcdir)/'`o/sequence.c o/lib_libbase_gcl_gprof_a-sequence.obj: o/sequence.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-sequence.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Tpo -c -o o/lib_libbase_gcl_gprof_a-sequence.obj `if test -f 'o/sequence.c'; then $(CYGPATH_W) 'o/sequence.c'; else $(CYGPATH_W) '$(srcdir)/o/sequence.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/sequence.c' object='o/lib_libbase_gcl_gprof_a-sequence.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-sequence.obj `if test -f 'o/sequence.c'; then $(CYGPATH_W) 'o/sequence.c'; else $(CYGPATH_W) '$(srcdir)/o/sequence.c'; fi` o/lib_libbase_gcl_gprof_a-string.o: o/string.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-string.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Tpo -c -o o/lib_libbase_gcl_gprof_a-string.o `test -f 'o/string.c' || echo '$(srcdir)/'`o/string.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/string.c' object='o/lib_libbase_gcl_gprof_a-string.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-string.o `test -f 'o/string.c' || echo '$(srcdir)/'`o/string.c o/lib_libbase_gcl_gprof_a-string.obj: o/string.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-string.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Tpo -c -o o/lib_libbase_gcl_gprof_a-string.obj `if test -f 'o/string.c'; then $(CYGPATH_W) 'o/string.c'; else $(CYGPATH_W) '$(srcdir)/o/string.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/string.c' object='o/lib_libbase_gcl_gprof_a-string.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-string.obj `if test -f 'o/string.c'; then $(CYGPATH_W) 'o/string.c'; else $(CYGPATH_W) '$(srcdir)/o/string.c'; fi` o/lib_libbase_gcl_gprof_a-symbol.o: o/symbol.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-symbol.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Tpo -c -o o/lib_libbase_gcl_gprof_a-symbol.o `test -f 'o/symbol.c' || echo '$(srcdir)/'`o/symbol.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/symbol.c' object='o/lib_libbase_gcl_gprof_a-symbol.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-symbol.o `test -f 'o/symbol.c' || echo '$(srcdir)/'`o/symbol.c o/lib_libbase_gcl_gprof_a-symbol.obj: o/symbol.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-symbol.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Tpo -c -o o/lib_libbase_gcl_gprof_a-symbol.obj `if test -f 'o/symbol.c'; then $(CYGPATH_W) 'o/symbol.c'; else $(CYGPATH_W) '$(srcdir)/o/symbol.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/symbol.c' object='o/lib_libbase_gcl_gprof_a-symbol.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-symbol.obj `if test -f 'o/symbol.c'; then $(CYGPATH_W) 'o/symbol.c'; else $(CYGPATH_W) '$(srcdir)/o/symbol.c'; fi` o/lib_libbase_gcl_gprof_a-new_init.o: o/new_init.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-new_init.o -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Tpo -c -o o/lib_libbase_gcl_gprof_a-new_init.o `test -f 'o/new_init.c' || echo '$(srcdir)/'`o/new_init.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/new_init.c' object='o/lib_libbase_gcl_gprof_a-new_init.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-new_init.o `test -f 'o/new_init.c' || echo '$(srcdir)/'`o/new_init.c o/lib_libbase_gcl_gprof_a-new_init.obj: o/new_init.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libbase_gcl_gprof_a-new_init.obj -MD -MP -MF o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Tpo -c -o o/lib_libbase_gcl_gprof_a-new_init.obj `if test -f 'o/new_init.c'; then $(CYGPATH_W) 'o/new_init.c'; else $(CYGPATH_W) '$(srcdir)/o/new_init.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Tpo o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/new_init.c' object='o/lib_libbase_gcl_gprof_a-new_init.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(lib_libbase_gcl_gprof_a_CPPFLAGS) $(CPPFLAGS) $(lib_libbase_gcl_gprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libbase_gcl_gprof_a-new_init.obj `if test -f 'o/new_init.c'; then $(CYGPATH_W) 'o/new_init.c'; else $(CYGPATH_W) '$(srcdir)/o/new_init.c'; fi` o/lib_libgprof_a-gprof.o: o/gprof.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libgprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libgprof_a-gprof.o -MD -MP -MF o/$(DEPDIR)/lib_libgprof_a-gprof.Tpo -c -o o/lib_libgprof_a-gprof.o `test -f 'o/gprof.c' || echo '$(srcdir)/'`o/gprof.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libgprof_a-gprof.Tpo o/$(DEPDIR)/lib_libgprof_a-gprof.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gprof.c' object='o/lib_libgprof_a-gprof.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libgprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libgprof_a-gprof.o `test -f 'o/gprof.c' || echo '$(srcdir)/'`o/gprof.c o/lib_libgprof_a-gprof.obj: o/gprof.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libgprof_a_CFLAGS) $(CFLAGS) -MT o/lib_libgprof_a-gprof.obj -MD -MP -MF o/$(DEPDIR)/lib_libgprof_a-gprof.Tpo -c -o o/lib_libgprof_a-gprof.obj `if test -f 'o/gprof.c'; then $(CYGPATH_W) 'o/gprof.c'; else $(CYGPATH_W) '$(srcdir)/o/gprof.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) o/$(DEPDIR)/lib_libgprof_a-gprof.Tpo o/$(DEPDIR)/lib_libgprof_a-gprof.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='o/gprof.c' object='o/lib_libgprof_a-gprof.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libgprof_a_CFLAGS) $(CFLAGS) -c -o o/lib_libgprof_a-gprof.obj `if test -f 'o/gprof.c'; then $(CYGPATH_W) 'o/gprof.c'; else $(CYGPATH_W) '$(srcdir)/o/gprof.c'; fi` xgcl-2/lib_libxgcl_gprof_a-Events.o: xgcl-2/Events.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-Events.o -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-Events.o `test -f 'xgcl-2/Events.c' || echo '$(srcdir)/'`xgcl-2/Events.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/Events.c' object='xgcl-2/lib_libxgcl_gprof_a-Events.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-Events.o `test -f 'xgcl-2/Events.c' || echo '$(srcdir)/'`xgcl-2/Events.c xgcl-2/lib_libxgcl_gprof_a-Events.obj: xgcl-2/Events.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-Events.obj -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-Events.obj `if test -f 'xgcl-2/Events.c'; then $(CYGPATH_W) 'xgcl-2/Events.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/Events.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/Events.c' object='xgcl-2/lib_libxgcl_gprof_a-Events.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-Events.obj `if test -f 'xgcl-2/Events.c'; then $(CYGPATH_W) 'xgcl-2/Events.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/Events.c'; fi` xgcl-2/lib_libxgcl_gprof_a-general-c.o: xgcl-2/general-c.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-general-c.o -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-general-c.o `test -f 'xgcl-2/general-c.c' || echo '$(srcdir)/'`xgcl-2/general-c.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/general-c.c' object='xgcl-2/lib_libxgcl_gprof_a-general-c.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-general-c.o `test -f 'xgcl-2/general-c.c' || echo '$(srcdir)/'`xgcl-2/general-c.c xgcl-2/lib_libxgcl_gprof_a-general-c.obj: xgcl-2/general-c.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-general-c.obj -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-general-c.obj `if test -f 'xgcl-2/general-c.c'; then $(CYGPATH_W) 'xgcl-2/general-c.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/general-c.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/general-c.c' object='xgcl-2/lib_libxgcl_gprof_a-general-c.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-general-c.obj `if test -f 'xgcl-2/general-c.c'; then $(CYGPATH_W) 'xgcl-2/general-c.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/general-c.c'; fi` xgcl-2/lib_libxgcl_gprof_a-XStruct-2.o: xgcl-2/XStruct-2.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-XStruct-2.o -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-2.o `test -f 'xgcl-2/XStruct-2.c' || echo '$(srcdir)/'`xgcl-2/XStruct-2.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/XStruct-2.c' object='xgcl-2/lib_libxgcl_gprof_a-XStruct-2.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-2.o `test -f 'xgcl-2/XStruct-2.c' || echo '$(srcdir)/'`xgcl-2/XStruct-2.c xgcl-2/lib_libxgcl_gprof_a-XStruct-2.obj: xgcl-2/XStruct-2.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-XStruct-2.obj -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-2.obj `if test -f 'xgcl-2/XStruct-2.c'; then $(CYGPATH_W) 'xgcl-2/XStruct-2.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/XStruct-2.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/XStruct-2.c' object='xgcl-2/lib_libxgcl_gprof_a-XStruct-2.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-2.obj `if test -f 'xgcl-2/XStruct-2.c'; then $(CYGPATH_W) 'xgcl-2/XStruct-2.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/XStruct-2.c'; fi` xgcl-2/lib_libxgcl_gprof_a-XStruct-4.o: xgcl-2/XStruct-4.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-XStruct-4.o -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-4.o `test -f 'xgcl-2/XStruct-4.c' || echo '$(srcdir)/'`xgcl-2/XStruct-4.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/XStruct-4.c' object='xgcl-2/lib_libxgcl_gprof_a-XStruct-4.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-4.o `test -f 'xgcl-2/XStruct-4.c' || echo '$(srcdir)/'`xgcl-2/XStruct-4.c xgcl-2/lib_libxgcl_gprof_a-XStruct-4.obj: xgcl-2/XStruct-4.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-XStruct-4.obj -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-4.obj `if test -f 'xgcl-2/XStruct-4.c'; then $(CYGPATH_W) 'xgcl-2/XStruct-4.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/XStruct-4.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/XStruct-4.c' object='xgcl-2/lib_libxgcl_gprof_a-XStruct-4.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-XStruct-4.obj `if test -f 'xgcl-2/XStruct-4.c'; then $(CYGPATH_W) 'xgcl-2/XStruct-4.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/XStruct-4.c'; fi` xgcl-2/lib_libxgcl_gprof_a-Xutil-2.o: xgcl-2/Xutil-2.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-Xutil-2.o -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-Xutil-2.o `test -f 'xgcl-2/Xutil-2.c' || echo '$(srcdir)/'`xgcl-2/Xutil-2.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/Xutil-2.c' object='xgcl-2/lib_libxgcl_gprof_a-Xutil-2.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-Xutil-2.o `test -f 'xgcl-2/Xutil-2.c' || echo '$(srcdir)/'`xgcl-2/Xutil-2.c xgcl-2/lib_libxgcl_gprof_a-Xutil-2.obj: xgcl-2/Xutil-2.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -MT xgcl-2/lib_libxgcl_gprof_a-Xutil-2.obj -MD -MP -MF xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Tpo -c -o xgcl-2/lib_libxgcl_gprof_a-Xutil-2.obj `if test -f 'xgcl-2/Xutil-2.c'; then $(CYGPATH_W) 'xgcl-2/Xutil-2.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/Xutil-2.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Tpo xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='xgcl-2/Xutil-2.c' object='xgcl-2/lib_libxgcl_gprof_a-Xutil-2.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(lib_libxgcl_gprof_a_CFLAGS) $(CFLAGS) -c -o xgcl-2/lib_libxgcl_gprof_a-Xutil-2.obj `if test -f 'xgcl-2/Xutil-2.c'; then $(CYGPATH_W) 'xgcl-2/Xutil-2.c'; else $(CYGPATH_W) '$(srcdir)/xgcl-2/Xutil-2.c'; fi` gcl-tk/gcltkaux-guis.o: gcl-tk/guis.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT gcl-tk/gcltkaux-guis.o -MD -MP -MF gcl-tk/$(DEPDIR)/gcltkaux-guis.Tpo -c -o gcl-tk/gcltkaux-guis.o `test -f 'gcl-tk/guis.c' || echo '$(srcdir)/'`gcl-tk/guis.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) gcl-tk/$(DEPDIR)/gcltkaux-guis.Tpo gcl-tk/$(DEPDIR)/gcltkaux-guis.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gcl-tk/guis.c' object='gcl-tk/gcltkaux-guis.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o gcl-tk/gcltkaux-guis.o `test -f 'gcl-tk/guis.c' || echo '$(srcdir)/'`gcl-tk/guis.c gcl-tk/gcltkaux-guis.obj: gcl-tk/guis.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT gcl-tk/gcltkaux-guis.obj -MD -MP -MF gcl-tk/$(DEPDIR)/gcltkaux-guis.Tpo -c -o gcl-tk/gcltkaux-guis.obj `if test -f 'gcl-tk/guis.c'; then $(CYGPATH_W) 'gcl-tk/guis.c'; else $(CYGPATH_W) '$(srcdir)/gcl-tk/guis.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) gcl-tk/$(DEPDIR)/gcltkaux-guis.Tpo gcl-tk/$(DEPDIR)/gcltkaux-guis.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gcl-tk/guis.c' object='gcl-tk/gcltkaux-guis.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o gcl-tk/gcltkaux-guis.obj `if test -f 'gcl-tk/guis.c'; then $(CYGPATH_W) 'gcl-tk/guis.c'; else $(CYGPATH_W) '$(srcdir)/gcl-tk/guis.c'; fi` gcl-tk/gcltkaux-tkAppInit.o: gcl-tk/tkAppInit.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT gcl-tk/gcltkaux-tkAppInit.o -MD -MP -MF gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Tpo -c -o gcl-tk/gcltkaux-tkAppInit.o `test -f 'gcl-tk/tkAppInit.c' || echo '$(srcdir)/'`gcl-tk/tkAppInit.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Tpo gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gcl-tk/tkAppInit.c' object='gcl-tk/gcltkaux-tkAppInit.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o gcl-tk/gcltkaux-tkAppInit.o `test -f 'gcl-tk/tkAppInit.c' || echo '$(srcdir)/'`gcl-tk/tkAppInit.c gcl-tk/gcltkaux-tkAppInit.obj: gcl-tk/tkAppInit.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT gcl-tk/gcltkaux-tkAppInit.obj -MD -MP -MF gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Tpo -c -o gcl-tk/gcltkaux-tkAppInit.obj `if test -f 'gcl-tk/tkAppInit.c'; then $(CYGPATH_W) 'gcl-tk/tkAppInit.c'; else $(CYGPATH_W) '$(srcdir)/gcl-tk/tkAppInit.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Tpo gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gcl-tk/tkAppInit.c' object='gcl-tk/gcltkaux-tkAppInit.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o gcl-tk/gcltkaux-tkAppInit.obj `if test -f 'gcl-tk/tkAppInit.c'; then $(CYGPATH_W) 'gcl-tk/tkAppInit.c'; else $(CYGPATH_W) '$(srcdir)/gcl-tk/tkAppInit.c'; fi` gcl-tk/gcltkaux-tkMain.o: gcl-tk/tkMain.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT gcl-tk/gcltkaux-tkMain.o -MD -MP -MF gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Tpo -c -o gcl-tk/gcltkaux-tkMain.o `test -f 'gcl-tk/tkMain.c' || echo '$(srcdir)/'`gcl-tk/tkMain.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Tpo gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gcl-tk/tkMain.c' object='gcl-tk/gcltkaux-tkMain.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o gcl-tk/gcltkaux-tkMain.o `test -f 'gcl-tk/tkMain.c' || echo '$(srcdir)/'`gcl-tk/tkMain.c gcl-tk/gcltkaux-tkMain.obj: gcl-tk/tkMain.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT gcl-tk/gcltkaux-tkMain.obj -MD -MP -MF gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Tpo -c -o gcl-tk/gcltkaux-tkMain.obj `if test -f 'gcl-tk/tkMain.c'; then $(CYGPATH_W) 'gcl-tk/tkMain.c'; else $(CYGPATH_W) '$(srcdir)/gcl-tk/tkMain.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Tpo gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='gcl-tk/tkMain.c' object='gcl-tk/gcltkaux-tkMain.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(gcl_tk_gcltkaux_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o gcl-tk/gcltkaux-tkMain.obj `if test -f 'gcl-tk/tkMain.c'; then $(CYGPATH_W) 'gcl-tk/tkMain.c'; else $(CYGPATH_W) '$(srcdir)/gcl-tk/tkMain.c'; fi` info/$(am__dirstamp): @$(MKDIR_P) info @: >>info/$(am__dirstamp) info/gcl.info: info/gcl.texi @test -f info/$(am__dirstamp) || $(MAKE) $(AM_MAKEFLAGS) info/$(am__dirstamp) $(AM_V_MAKEINFO)restore=: && backupdir="$(am__leading_dot)am$$$$" && \ rm -rf $$backupdir && mkdir $$backupdir && \ if ($(MAKEINFO) --version) >/dev/null 2>&1; then \ for f in $@ $@-[0-9] $@-[0-9][0-9] $(@:.info=).i[0-9] $(@:.info=).i[0-9][0-9]; do \ if test -f $$f; then mv $$f $$backupdir; restore=mv; else :; fi; \ done; \ else :; fi && \ if $(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $@ `test -f 'info/gcl.texi' || echo '$(srcdir)/'`info/gcl.texi; \ then \ rc=0; \ else \ rc=$$?; \ $$restore $$backupdir/* `echo "./$@" | sed 's|[^/]*$$||'`; \ fi; \ rm -rf $$backupdir; exit $$rc info/gcl.dvi: info/gcl.texi info/$(am__dirstamp) $(AM_V_TEXI2DVI)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2DVI) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.dvi=.t2d) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl.texi' || echo '$(srcdir)/'`info/gcl.texi info/gcl.pdf: info/gcl.texi info/$(am__dirstamp) $(AM_V_TEXI2PDF)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2PDF) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.pdf=.t2p) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl.texi' || echo '$(srcdir)/'`info/gcl.texi info/gcl.html: info/gcl.texi info/$(am__dirstamp) $(AM_V_MAKEINFO)rm -rf $(@:.html=.htp) $(AM_V_at)if $(MAKEINFOHTML) $(AM_MAKEINFOHTMLFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $(@:.html=.htp) `test -f 'info/gcl.texi' || echo '$(srcdir)/'`info/gcl.texi; \ then \ rm -rf $@ && mv $(@:.html=.htp) $@; \ else \ rm -rf $(@:.html=.htp); exit 1; \ fi info/gcl-si.info: info/gcl-si.texi @test -f info/$(am__dirstamp) || $(MAKE) $(AM_MAKEFLAGS) info/$(am__dirstamp) $(AM_V_MAKEINFO)restore=: && backupdir="$(am__leading_dot)am$$$$" && \ rm -rf $$backupdir && mkdir $$backupdir && \ if ($(MAKEINFO) --version) >/dev/null 2>&1; then \ for f in $@ $@-[0-9] $@-[0-9][0-9] $(@:.info=).i[0-9] $(@:.info=).i[0-9][0-9]; do \ if test -f $$f; then mv $$f $$backupdir; restore=mv; else :; fi; \ done; \ else :; fi && \ if $(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $@ `test -f 'info/gcl-si.texi' || echo '$(srcdir)/'`info/gcl-si.texi; \ then \ rc=0; \ else \ rc=$$?; \ $$restore $$backupdir/* `echo "./$@" | sed 's|[^/]*$$||'`; \ fi; \ rm -rf $$backupdir; exit $$rc info/gcl-si.dvi: info/gcl-si.texi info/$(am__dirstamp) $(AM_V_TEXI2DVI)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2DVI) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.dvi=.t2d) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl-si.texi' || echo '$(srcdir)/'`info/gcl-si.texi info/gcl-si.pdf: info/gcl-si.texi info/$(am__dirstamp) $(AM_V_TEXI2PDF)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2PDF) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.pdf=.t2p) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl-si.texi' || echo '$(srcdir)/'`info/gcl-si.texi info/gcl-si.html: info/gcl-si.texi info/$(am__dirstamp) $(AM_V_MAKEINFO)rm -rf $(@:.html=.htp) $(AM_V_at)if $(MAKEINFOHTML) $(AM_MAKEINFOHTMLFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $(@:.html=.htp) `test -f 'info/gcl-si.texi' || echo '$(srcdir)/'`info/gcl-si.texi; \ then \ rm -rf $@ && mv $(@:.html=.htp) $@; \ else \ rm -rf $(@:.html=.htp); exit 1; \ fi info/gcl-dwdoc.info: info/gcl-dwdoc.texi @test -f info/$(am__dirstamp) || $(MAKE) $(AM_MAKEFLAGS) info/$(am__dirstamp) $(AM_V_MAKEINFO)restore=: && backupdir="$(am__leading_dot)am$$$$" && \ rm -rf $$backupdir && mkdir $$backupdir && \ if ($(MAKEINFO) --version) >/dev/null 2>&1; then \ for f in $@ $@-[0-9] $@-[0-9][0-9] $(@:.info=).i[0-9] $(@:.info=).i[0-9][0-9]; do \ if test -f $$f; then mv $$f $$backupdir; restore=mv; else :; fi; \ done; \ else :; fi && \ if $(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $@ `test -f 'info/gcl-dwdoc.texi' || echo '$(srcdir)/'`info/gcl-dwdoc.texi; \ then \ rc=0; \ else \ rc=$$?; \ $$restore $$backupdir/* `echo "./$@" | sed 's|[^/]*$$||'`; \ fi; \ rm -rf $$backupdir; exit $$rc info/gcl-dwdoc.dvi: info/gcl-dwdoc.texi info/$(am__dirstamp) $(AM_V_TEXI2DVI)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2DVI) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.dvi=.t2d) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl-dwdoc.texi' || echo '$(srcdir)/'`info/gcl-dwdoc.texi info/gcl-dwdoc.pdf: info/gcl-dwdoc.texi info/$(am__dirstamp) $(AM_V_TEXI2PDF)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2PDF) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.pdf=.t2p) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl-dwdoc.texi' || echo '$(srcdir)/'`info/gcl-dwdoc.texi info/gcl-dwdoc.html: info/gcl-dwdoc.texi info/$(am__dirstamp) $(AM_V_MAKEINFO)rm -rf $(@:.html=.htp) $(AM_V_at)if $(MAKEINFOHTML) $(AM_MAKEINFOHTMLFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $(@:.html=.htp) `test -f 'info/gcl-dwdoc.texi' || echo '$(srcdir)/'`info/gcl-dwdoc.texi; \ then \ rm -rf $@ && mv $(@:.html=.htp) $@; \ else \ rm -rf $(@:.html=.htp); exit 1; \ fi info/gcl-tk.info: info/gcl-tk.texi @test -f info/$(am__dirstamp) || $(MAKE) $(AM_MAKEFLAGS) info/$(am__dirstamp) $(AM_V_MAKEINFO)restore=: && backupdir="$(am__leading_dot)am$$$$" && \ rm -rf $$backupdir && mkdir $$backupdir && \ if ($(MAKEINFO) --version) >/dev/null 2>&1; then \ for f in $@ $@-[0-9] $@-[0-9][0-9] $(@:.info=).i[0-9] $(@:.info=).i[0-9][0-9]; do \ if test -f $$f; then mv $$f $$backupdir; restore=mv; else :; fi; \ done; \ else :; fi && \ if $(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $@ `test -f 'info/gcl-tk.texi' || echo '$(srcdir)/'`info/gcl-tk.texi; \ then \ rc=0; \ else \ rc=$$?; \ $$restore $$backupdir/* `echo "./$@" | sed 's|[^/]*$$||'`; \ fi; \ rm -rf $$backupdir; exit $$rc info/gcl-tk.dvi: info/gcl-tk.texi info/$(am__dirstamp) $(AM_V_TEXI2DVI)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2DVI) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.dvi=.t2d) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl-tk.texi' || echo '$(srcdir)/'`info/gcl-tk.texi info/gcl-tk.pdf: info/gcl-tk.texi info/$(am__dirstamp) $(AM_V_TEXI2PDF)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info' \ $(TEXI2PDF) $(AM_TEXI2FLAGS) -I info -I $(srcdir)/info $(AM_V_texinfo) --build-dir=$(@:.pdf=.t2p) -o $@ $(AM_V_texidevnull) \ `test -f 'info/gcl-tk.texi' || echo '$(srcdir)/'`info/gcl-tk.texi info/gcl-tk.html: info/gcl-tk.texi info/$(am__dirstamp) $(AM_V_MAKEINFO)rm -rf $(@:.html=.htp) $(AM_V_at)if $(MAKEINFOHTML) $(AM_MAKEINFOHTMLFLAGS) $(MAKEINFOFLAGS) -I info -I $(srcdir)/info \ -o $(@:.html=.htp) `test -f 'info/gcl-tk.texi' || echo '$(srcdir)/'`info/gcl-tk.texi; \ then \ rm -rf $@ && mv $(@:.html=.htp) $@; \ else \ rm -rf $(@:.html=.htp); exit 1; \ fi .dvi.ps: $(AM_V_DVIPS)TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ $(DVIPS) $(AM_V_texinfo) -o $@ $< uninstall-dvi-am: @$(NORMAL_UNINSTALL) @list='$(DVIS)'; test -n "$(dvidir)" || list=; \ for p in $$list; do \ $(am__strip_dir) \ echo " rm -f '$(DESTDIR)$(dvidir)/$$f'"; \ rm -f "$(DESTDIR)$(dvidir)/$$f"; \ done uninstall-html-am: @$(NORMAL_UNINSTALL) @list='$(HTMLS)'; test -n "$(htmldir)" || list=; \ for p in $$list; do \ $(am__strip_dir) \ echo " rm -rf '$(DESTDIR)$(htmldir)/$$f'"; \ rm -rf "$(DESTDIR)$(htmldir)/$$f"; \ done uninstall-info-am: @$(PRE_UNINSTALL) @if test -d '$(DESTDIR)$(infodir)' && $(am__can_run_installinfo); then \ list='$(INFO_DEPS)'; \ for file in $$list; do \ relfile=`echo "$$file" | sed 's|^.*/||'`; \ echo " install-info --info-dir='$(DESTDIR)$(infodir)' --remove '$(DESTDIR)$(infodir)/$$relfile'"; \ if install-info --info-dir="$(DESTDIR)$(infodir)" --remove "$(DESTDIR)$(infodir)/$$relfile"; \ then :; else test ! -f "$(DESTDIR)$(infodir)/$$relfile" || exit 1; fi; \ done; \ else :; fi @$(NORMAL_UNINSTALL) @list='$(INFO_DEPS)'; \ for file in $$list; do \ relfile=`echo "$$file" | sed 's|^.*/||'`; \ relfile_i=`echo "$$relfile" | sed 's|\.info$$||;s|$$|.i|'`; \ (if test -d "$(DESTDIR)$(infodir)" && cd "$(DESTDIR)$(infodir)"; then \ echo " cd '$(DESTDIR)$(infodir)' && rm -f $$relfile $$relfile-[0-9] $$relfile-[0-9][0-9] $$relfile_i[0-9] $$relfile_i[0-9][0-9]"; \ rm -f $$relfile $$relfile-[0-9] $$relfile-[0-9][0-9] $$relfile_i[0-9] $$relfile_i[0-9][0-9]; \ else :; fi); \ done uninstall-pdf-am: @$(NORMAL_UNINSTALL) @list='$(PDFS)'; test -n "$(pdfdir)" || list=; \ for p in $$list; do \ $(am__strip_dir) \ echo " rm -f '$(DESTDIR)$(pdfdir)/$$f'"; \ rm -f "$(DESTDIR)$(pdfdir)/$$f"; \ done uninstall-ps-am: @$(NORMAL_UNINSTALL) @list='$(PSS)'; test -n "$(psdir)" || list=; \ for p in $$list; do \ $(am__strip_dir) \ echo " rm -f '$(DESTDIR)$(psdir)/$$f'"; \ rm -f "$(DESTDIR)$(psdir)/$$f"; \ done dist-info: $(INFO_DEPS) @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ list='$(INFO_DEPS)'; \ for base in $$list; do \ case $$base in \ $(srcdir)/*) base=`echo "$$base" | sed "s|^$$srcdirstrip/||"`;; \ esac; \ if test -f $$base; then d=.; else d=$(srcdir); fi; \ base_i=`echo "$$base" | sed 's|\.info$$||;s|$$|.i|'`; \ for file in $$d/$$base $$d/$$base-[0-9] $$d/$$base-[0-9][0-9] $$d/$$base_i[0-9] $$d/$$base_i[0-9][0-9]; do \ if test -f $$file; then \ relfile=`expr "$$file" : "$$d/\(.*\)"`; \ test -f "$(distdir)/$$relfile" || \ cp -p $$file "$(distdir)/$$relfile"; \ else :; fi; \ done; \ done mostlyclean-aminfo: -$(am__rm_rf) info/gcl.t2d info/gcl.t2p info/gcl-si.t2d info/gcl-si.t2p \ info/gcl-dwdoc.t2d info/gcl-dwdoc.t2p info/gcl-tk.t2d \ info/gcl-tk.t2p clean-aminfo: -$(am__rm_rf) info/gcl.dvi info/gcl.pdf info/gcl.ps info/gcl.html info/gcl-si.dvi \ info/gcl-si.pdf info/gcl-si.ps info/gcl-si.html \ info/gcl-dwdoc.dvi info/gcl-dwdoc.pdf info/gcl-dwdoc.ps \ info/gcl-dwdoc.html info/gcl-tk.dvi info/gcl-tk.pdf \ info/gcl-tk.ps info/gcl-tk.html maintainer-clean-aminfo: @list='$(INFO_DEPS)'; for i in $$list; do \ i_i=`echo "$$i" | sed 's|\.info$$||;s|$$|.i|'`; \ echo " rm -f $$i $$i-[0-9] $$i-[0-9][0-9] $$i_i[0-9] $$i_i[0-9][0-9]"; \ rm -f $$i $$i-[0-9] $$i-[0-9][0-9] $$i_i[0-9] $$i_i[0-9][0-9]; \ done install-man1: $(dist_man1_MANS) @$(NORMAL_INSTALL) @list1='$(dist_man1_MANS)'; \ list2=''; \ test -n "$(man1dir)" \ && test -n "`echo $$list1$$list2`" \ || exit 0; \ echo " $(MKDIR_P) '$(DESTDIR)$(man1dir)'"; \ $(MKDIR_P) "$(DESTDIR)$(man1dir)" || exit 1; \ { for i in $$list1; do echo "$$i"; done; \ if test -n "$$list2"; then \ for i in $$list2; do echo "$$i"; done \ | sed -n '/\.1[a-z]*$$/p'; \ fi; \ } | while read p; do \ if test -f $$p; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; echo "$$p"; \ done | \ sed -e 'n;s,.*/,,;p;h;s,.*\.,,;s,^[^1][0-9a-z]*$$,1,;x' \ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,' | \ sed 'N;N;s,\n, ,g' | { \ list=; while read file base inst; do \ if test "$$base" = "$$inst"; then list="$$list $$file"; else \ echo " $(INSTALL_DATA) '$$file' '$(DESTDIR)$(man1dir)/$$inst'"; \ $(INSTALL_DATA) "$$file" "$(DESTDIR)$(man1dir)/$$inst" || exit $$?; \ fi; \ done; \ for i in $$list; do echo "$$i"; done | $(am__base_list) | \ while read files; do \ test -z "$$files" || { \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(man1dir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(man1dir)" || exit $$?; }; \ done; } uninstall-man1: @$(NORMAL_UNINSTALL) @list='$(dist_man1_MANS)'; test -n "$(man1dir)" || exit 0; \ files=`{ for i in $$list; do echo "$$i"; done; \ } | sed -e 's,.*/,,;h;s,.*\.,,;s,^[^1][0-9a-z]*$$,1,;x' \ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,'`; \ dir='$(DESTDIR)$(man1dir)'; $(am__uninstall_files_from_dir) install-dist_gcltkdocDATA: $(dist_gcltkdoc_DATA) @$(NORMAL_INSTALL) @list='$(dist_gcltkdoc_DATA)'; test -n "$(gcltkdocdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(gcltkdocdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(gcltkdocdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(gcltkdocdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(gcltkdocdir)" || exit $$?; \ done uninstall-dist_gcltkdocDATA: @$(NORMAL_UNINSTALL) @list='$(dist_gcltkdoc_DATA)'; test -n "$(gcltkdocdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(gcltkdocdir)'; $(am__uninstall_files_from_dir) install-dist_my_gcltkDATA: $(dist_my_gcltk_DATA) @$(NORMAL_INSTALL) @list='$(dist_my_gcltk_DATA)'; test -n "$(my_gcltkdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_gcltkdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_gcltkdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_gcltkdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_gcltkdir)" || exit $$?; \ done uninstall-dist_my_gcltkDATA: @$(NORMAL_UNINSTALL) @list='$(dist_my_gcltk_DATA)'; test -n "$(my_gcltkdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_gcltkdir)'; $(am__uninstall_files_from_dir) install-dist_my_xgcl2DATA: $(dist_my_xgcl2_DATA) @$(NORMAL_INSTALL) @list='$(dist_my_xgcl2_DATA)'; test -n "$(my_xgcl2dir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_xgcl2dir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_xgcl2dir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_xgcl2dir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_xgcl2dir)" || exit $$?; \ done uninstall-dist_my_xgcl2DATA: @$(NORMAL_UNINSTALL) @list='$(dist_my_xgcl2_DATA)'; test -n "$(my_xgcl2dir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_xgcl2dir)'; $(am__uninstall_files_from_dir) install-dist_xgcl2docDATA: $(dist_xgcl2doc_DATA) @$(NORMAL_INSTALL) @list='$(dist_xgcl2doc_DATA)'; test -n "$(xgcl2docdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(xgcl2docdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(xgcl2docdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(xgcl2docdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(xgcl2docdir)" || exit $$?; \ done uninstall-dist_xgcl2docDATA: @$(NORMAL_UNINSTALL) @list='$(dist_xgcl2doc_DATA)'; test -n "$(xgcl2docdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(xgcl2docdir)'; $(am__uninstall_files_from_dir) install-gcltkdocDATA: $(gcltkdoc_DATA) @$(NORMAL_INSTALL) @list='$(gcltkdoc_DATA)'; test -n "$(gcltkdocdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(gcltkdocdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(gcltkdocdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(gcltkdocdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(gcltkdocdir)" || exit $$?; \ done uninstall-gcltkdocDATA: @$(NORMAL_UNINSTALL) @list='$(gcltkdoc_DATA)'; test -n "$(gcltkdocdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(gcltkdocdir)'; $(am__uninstall_files_from_dir) install-lispDATA: $(lisp_DATA) @$(NORMAL_INSTALL) @list='$(lisp_DATA)'; test -n "$(lispdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(lispdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(lispdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(lispdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(lispdir)" || exit $$?; \ done uninstall-lispDATA: @$(NORMAL_UNINSTALL) @list='$(lisp_DATA)'; test -n "$(lispdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(lispdir)'; $(am__uninstall_files_from_dir) install-my_clcsDATA: $(my_clcs_DATA) @$(NORMAL_INSTALL) @list='$(my_clcs_DATA)'; test -n "$(my_clcsdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_clcsdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_clcsdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_clcsdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_clcsdir)" || exit $$?; \ done uninstall-my_clcsDATA: @$(NORMAL_UNINSTALL) @list='$(my_clcs_DATA)'; test -n "$(my_clcsdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_clcsdir)'; $(am__uninstall_files_from_dir) install-my_cmpnewDATA: $(my_cmpnew_DATA) @$(NORMAL_INSTALL) @list='$(my_cmpnew_DATA)'; test -n "$(my_cmpnewdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_cmpnewdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_cmpnewdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_cmpnewdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_cmpnewdir)" || exit $$?; \ done uninstall-my_cmpnewDATA: @$(NORMAL_UNINSTALL) @list='$(my_cmpnew_DATA)'; test -n "$(my_cmpnewdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_cmpnewdir)'; $(am__uninstall_files_from_dir) install-my_gcltkDATA: $(my_gcltk_DATA) @$(NORMAL_INSTALL) @list='$(my_gcltk_DATA)'; test -n "$(my_gcltkdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_gcltkdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_gcltkdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_gcltkdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_gcltkdir)" || exit $$?; \ done uninstall-my_gcltkDATA: @$(NORMAL_UNINSTALL) @list='$(my_gcltk_DATA)'; test -n "$(my_gcltkdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_gcltkdir)'; $(am__uninstall_files_from_dir) install-my_hDATA: $(my_h_DATA) @$(NORMAL_INSTALL) @list='$(my_h_DATA)'; test -n "$(my_hdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_hdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_hdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_hdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_hdir)" || exit $$?; \ done uninstall-my_hDATA: @$(NORMAL_UNINSTALL) @list='$(my_h_DATA)'; test -n "$(my_hdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_hdir)'; $(am__uninstall_files_from_dir) install-my_lspDATA: $(my_lsp_DATA) @$(NORMAL_INSTALL) @list='$(my_lsp_DATA)'; test -n "$(my_lspdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_lspdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_lspdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_lspdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_lspdir)" || exit $$?; \ done uninstall-my_lspDATA: @$(NORMAL_UNINSTALL) @list='$(my_lsp_DATA)'; test -n "$(my_lspdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_lspdir)'; $(am__uninstall_files_from_dir) install-my_pclDATA: $(my_pcl_DATA) @$(NORMAL_INSTALL) @list='$(my_pcl_DATA)'; test -n "$(my_pcldir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_pcldir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_pcldir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_pcldir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_pcldir)" || exit $$?; \ done uninstall-my_pclDATA: @$(NORMAL_UNINSTALL) @list='$(my_pcl_DATA)'; test -n "$(my_pcldir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_pcldir)'; $(am__uninstall_files_from_dir) install-my_unixportDATA: $(my_unixport_DATA) @$(NORMAL_INSTALL) @list='$(my_unixport_DATA)'; test -n "$(my_unixportdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(my_unixportdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(my_unixportdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(my_unixportdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(my_unixportdir)" || exit $$?; \ done uninstall-my_unixportDATA: @$(NORMAL_UNINSTALL) @list='$(my_unixport_DATA)'; test -n "$(my_unixportdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(my_unixportdir)'; $(am__uninstall_files_from_dir) 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" cscope: cscope.files test ! -s cscope.files \ || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) clean-cscope: -rm -f cscope.files cscope.files: clean-cscope cscopelist 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 -rm -f cscope.out cscope.in.out cscope.po.out cscope.files distdir: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) distdir-am distdir-am: $(DISTFILES) $(am__remove_distdir) $(AM_V_at)$(MKDIR_P) "$(distdir)" @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 $(MAKE) $(AM_MAKEFLAGS) \ top_distdir="$(top_distdir)" distdir="$(distdir)" \ dist-info -test -n "$(am__skip_mode_fix)" \ || find "$(distdir)" -type d ! -perm -755 \ -exec chmod u+rwx,go+rx {} \; -o \ ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ || chmod -R a+r "$(distdir)" dist-gzip: distdir tardir=$(distdir) && $(am__tar) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).tar.gz $(am__post_remove_distdir) dist-bzip2: distdir tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 $(am__post_remove_distdir) dist-lzip: distdir tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz $(am__post_remove_distdir) dist-xz: distdir tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz $(am__post_remove_distdir) dist-zstd: distdir tardir=$(distdir) && $(am__tar) | zstd -c $${ZSTD_CLEVEL-$${ZSTD_OPT--19}} >$(distdir).tar.zst $(am__post_remove_distdir) dist-tarZ: distdir @echo WARNING: "Support for distribution archives compressed with" \ "legacy program 'compress' is deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__post_remove_distdir) dist-shar: distdir @echo WARNING: "Support for shar distribution archives is" \ "deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 shar $(distdir) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).shar.gz $(am__post_remove_distdir) dist-zip: distdir -rm -f $(distdir).zip zip -rq $(distdir).zip $(distdir) $(am__post_remove_distdir) dist dist-all: $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' $(am__post_remove_distdir) # This target untars the dist file and tries a VPATH configuration. Then # it guarantees that the distribution is self-contained by making another # tarfile. distcheck: dist case '$(DIST_ARCHIVES)' in \ *.tar.gz*) \ eval GZIP= gzip -dc $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lz*) \ lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ *.tar.xz*) \ xz -dc $(distdir).tar.xz | $(am__untar) ;;\ *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ eval GZIP= gzip -dc $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ *.tar.zst*) \ zstd -dc $(distdir).tar.zst | $(am__untar) ;;\ esac chmod -R a-w $(distdir) chmod u+w $(distdir) mkdir $(distdir)/_build $(distdir)/_build/sub $(distdir)/_inst chmod a-w $(distdir) test -d $(distdir)/_build || exit 0; \ dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && am__cwd=`pwd` \ && $(am__cd) $(distdir)/_build/sub \ && ../../configure \ $(AM_DISTCHECK_CONFIGURE_FLAGS) \ $(DISTCHECK_CONFIGURE_FLAGS) \ --srcdir=../.. --prefix="$$dc_install_base" \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) $(AM_DISTCHECK_DVI_TARGET) \ && $(MAKE) $(AM_MAKEFLAGS) check \ && $(MAKE) $(AM_MAKEFLAGS) install \ && $(MAKE) $(AM_MAKEFLAGS) installcheck \ && $(MAKE) $(AM_MAKEFLAGS) uninstall \ && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ distuninstallcheck \ && chmod -R a-w "$$dc_install_base" \ && ({ \ (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ } || { rm -rf "$$dc_destdir"; exit 1; }) \ && rm -rf "$$dc_destdir" \ && $(MAKE) $(AM_MAKEFLAGS) dist \ && rm -rf $(DIST_ARCHIVES) \ && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ && cd "$$am__cwd" \ || exit 1 $(am__post_remove_distdir) @(echo "$(distdir) archives ready for distribution: "; \ list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' distuninstallcheck: @test -n '$(distuninstallcheck_dir)' || { \ echo 'ERROR: trying to run $@ with an empty' \ '$$(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ $(am__cd) '$(distuninstallcheck_dir)' || { \ echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left after uninstall:" ; \ if test -n "$(DESTDIR)"; then \ echo " (check DESTDIR support)"; \ fi ; \ $(distuninstallcheck_listfiles) ; \ exit 1; } >&2 distcleancheck: distclean @if test '$(srcdir)' = . ; then \ echo "ERROR: distcleancheck can only run from a VPATH build" ; \ exit 1 ; \ fi @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left in build directory after distclean:" ; \ $(distcleancheck_listfiles) ; \ exit 1; } >&2 check-am: all-am $(MAKE) $(AM_MAKEFLAGS) $(check_SCRIPTS) check: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) check-am all-am: Makefile $(INFO_DEPS) $(PROGRAMS) $(LIBRARIES) $(SCRIPTS) \ $(MANS) $(DATA) installdirs: for dir in "$(DESTDIR)$(my_gcltkdir)" "$(DESTDIR)$(my_unixportdir)" "$(DESTDIR)$(my_unixportdir)" "$(DESTDIR)$(bindir)" "$(DESTDIR)$(my_gcltkdir)" "$(DESTDIR)$(infodir)" "$(DESTDIR)$(man1dir)" "$(DESTDIR)$(gcltkdocdir)" "$(DESTDIR)$(my_gcltkdir)" "$(DESTDIR)$(my_xgcl2dir)" "$(DESTDIR)$(xgcl2docdir)" "$(DESTDIR)$(gcltkdocdir)" "$(DESTDIR)$(lispdir)" "$(DESTDIR)$(my_clcsdir)" "$(DESTDIR)$(my_cmpnewdir)" "$(DESTDIR)$(my_gcltkdir)" "$(DESTDIR)$(my_hdir)" "$(DESTDIR)$(my_lspdir)" "$(DESTDIR)$(my_pcldir)" "$(DESTDIR)$(my_unixportdir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) install-am install-exec: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) 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: -$(am__rm_f) $(CLEANFILES) distclean-generic: -$(am__rm_f) $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || $(am__rm_f) $(CONFIG_CLEAN_VPATH_FILES) -$(am__rm_f) bin/$(DEPDIR)/$(am__dirstamp) -$(am__rm_f) bin/$(am__dirstamp) -$(am__rm_f) gcl-tk/$(DEPDIR)/$(am__dirstamp) -$(am__rm_f) gcl-tk/$(am__dirstamp) -$(am__rm_f) info/$(am__dirstamp) -$(am__rm_f) lib/$(am__dirstamp) -$(am__rm_f) o/$(DEPDIR)/$(am__dirstamp) -$(am__rm_f) o/$(am__dirstamp) -$(am__rm_f) unixport/$(am__dirstamp) -$(am__rm_f) xgcl-2/$(DEPDIR)/$(am__dirstamp) -$(am__rm_f) xgcl-2/$(am__dirstamp) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." -$(am__rm_f) $(BUILT_SOURCES) clean: clean-am clean-am: clean-aminfo clean-generic clean-local \ clean-my_gcltkPROGRAMS clean-my_unixportLIBRARIES \ clean-my_unixportPROGRAMS clean-noinstLIBRARIES \ clean-noinstPROGRAMS mostlyclean-am distclean: distclean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -f bin/$(DEPDIR)/dpp.Po -rm -f gcl-tk/$(DEPDIR)/gcltkaux-guis.Po -rm -f gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Po -rm -f gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Po -rm -f o/$(DEPDIR)/alloc.Po -rm -f o/$(DEPDIR)/array.Po -rm -f o/$(DEPDIR)/assignment.Po -rm -f o/$(DEPDIR)/backq.Po -rm -f o/$(DEPDIR)/bcmp.Po -rm -f o/$(DEPDIR)/bcopy.Po -rm -f o/$(DEPDIR)/bds.Po -rm -f o/$(DEPDIR)/big.Po -rm -f o/$(DEPDIR)/bind.Po -rm -f o/$(DEPDIR)/bitop.Po -rm -f o/$(DEPDIR)/block.Po -rm -f o/$(DEPDIR)/bzero.Po -rm -f o/$(DEPDIR)/catch.Po -rm -f o/$(DEPDIR)/cfun.Po -rm -f o/$(DEPDIR)/character.Po -rm -f o/$(DEPDIR)/clxsocket.Po -rm -f o/$(DEPDIR)/cmpaux.Po -rm -f o/$(DEPDIR)/conditional.Po -rm -f o/$(DEPDIR)/earith.Po -rm -f o/$(DEPDIR)/error.Po -rm -f o/$(DEPDIR)/eval.Po -rm -f o/$(DEPDIR)/fat_string.Po -rm -f o/$(DEPDIR)/file.Po -rm -f o/$(DEPDIR)/format.Po -rm -f o/$(DEPDIR)/frame.Po -rm -f o/$(DEPDIR)/funlink.Po -rm -f o/$(DEPDIR)/gbc.Po -rm -f o/$(DEPDIR)/gcl_readline.Po -rm -f o/$(DEPDIR)/gmp_wrappers.Po -rm -f o/$(DEPDIR)/grab_defs.Po -rm -f o/$(DEPDIR)/hash.Po -rm -f o/$(DEPDIR)/iteration.Po -rm -f o/$(DEPDIR)/let.Po -rm -f o/$(DEPDIR)/lex.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Po -rm -f o/$(DEPDIR)/lib_libgprof_a-gprof.Po -rm -f o/$(DEPDIR)/list.Po -rm -f o/$(DEPDIR)/macros.Po -rm -f o/$(DEPDIR)/main.Po -rm -f o/$(DEPDIR)/makefun.Po -rm -f o/$(DEPDIR)/mapfun.Po -rm -f o/$(DEPDIR)/msbrk.Po -rm -f o/$(DEPDIR)/multival.Po -rm -f o/$(DEPDIR)/new_init.Po -rm -f o/$(DEPDIR)/nfunlink.Po -rm -f o/$(DEPDIR)/nsocket.Po -rm -f o/$(DEPDIR)/num_arith.Po -rm -f o/$(DEPDIR)/num_co.Po -rm -f o/$(DEPDIR)/num_comp.Po -rm -f o/$(DEPDIR)/num_log.Po -rm -f o/$(DEPDIR)/num_pred.Po -rm -f o/$(DEPDIR)/num_rand.Po -rm -f o/$(DEPDIR)/num_sfun.Po -rm -f o/$(DEPDIR)/number.Po -rm -f o/$(DEPDIR)/package.Po -rm -f o/$(DEPDIR)/pathname.Po -rm -f o/$(DEPDIR)/predicate.Po -rm -f o/$(DEPDIR)/prelink.Po -rm -f o/$(DEPDIR)/print.Po -rm -f o/$(DEPDIR)/prog.Po -rm -f o/$(DEPDIR)/read.Po -rm -f o/$(DEPDIR)/reference.Po -rm -f o/$(DEPDIR)/regexpr.Po -rm -f o/$(DEPDIR)/run_process.Po -rm -f o/$(DEPDIR)/sequence.Po -rm -f o/$(DEPDIR)/sfasl.Po -rm -f o/$(DEPDIR)/sockets.Po -rm -f o/$(DEPDIR)/string.Po -rm -f o/$(DEPDIR)/structure.Po -rm -f o/$(DEPDIR)/symbol.Po -rm -f o/$(DEPDIR)/toplevel.Po -rm -f o/$(DEPDIR)/typespec.Po -rm -f o/$(DEPDIR)/unixfasl.Po -rm -f o/$(DEPDIR)/unixfsys.Po -rm -f o/$(DEPDIR)/unixsave.Po -rm -f o/$(DEPDIR)/unixsys.Po -rm -f o/$(DEPDIR)/unixtime.Po -rm -f o/$(DEPDIR)/user_init.Po -rm -f o/$(DEPDIR)/user_match.Po -rm -f o/$(DEPDIR)/usig.Po -rm -f o/$(DEPDIR)/usig2.Po -rm -f o/$(DEPDIR)/utils.Po -rm -f xgcl-2/$(DEPDIR)/Events.Po -rm -f xgcl-2/$(DEPDIR)/XStruct-2.Po -rm -f xgcl-2/$(DEPDIR)/XStruct-4.Po -rm -f xgcl-2/$(DEPDIR)/Xutil-2.Po -rm -f xgcl-2/$(DEPDIR)/general-c.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Po -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-local distclean-tags dvi: dvi-am dvi-am: $(DVIS) html: html-am html-am: $(HTMLS) info: info-am info-am: $(INFO_DEPS) install-data-am: install-dist_gcltkdocDATA install-dist_my_gcltkDATA \ install-dist_my_xgcl2DATA install-dist_xgcl2docDATA \ install-gcltkdocDATA install-info-am install-lispDATA \ install-man install-my_clcsDATA install-my_cmpnewDATA \ install-my_gcltkDATA install-my_gcltkPROGRAMS \ install-my_gcltkSCRIPTS install-my_hDATA install-my_lspDATA \ install-my_pclDATA install-my_unixportDATA \ install-my_unixportLIBRARIES install-my_unixportPROGRAMS install-dvi: install-dvi-am install-dvi-am: $(DVIS) @$(NORMAL_INSTALL) @list='$(DVIS)'; test -n "$(dvidir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(dvidir)'"; \ $(MKDIR_P) "$(DESTDIR)$(dvidir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(dvidir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(dvidir)" || exit $$?; \ done install-exec-am: install-binSCRIPTS install-html: install-html-am install-html-am: $(HTMLS) @$(NORMAL_INSTALL) @list='$(HTMLS)'; list2=; test -n "$(htmldir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(htmldir)'"; \ $(MKDIR_P) "$(DESTDIR)$(htmldir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p" || test -d "$$p"; then d=; else d="$(srcdir)/"; fi; \ $(am__strip_dir) \ d2=$$d$$p; \ if test -d "$$d2"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(htmldir)/$$f'"; \ $(MKDIR_P) "$(DESTDIR)$(htmldir)/$$f" || exit 1; \ echo " $(INSTALL_DATA) '$$d2'/* '$(DESTDIR)$(htmldir)/$$f'"; \ $(INSTALL_DATA) "$$d2"/* "$(DESTDIR)$(htmldir)/$$f" || exit $$?; \ else \ list2="$$list2 $$d2"; \ fi; \ done; \ test -z "$$list2" || { echo "$$list2" | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(htmldir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(htmldir)" || exit $$?; \ done; } install-info: install-info-am install-info-am: $(INFO_DEPS) @$(NORMAL_INSTALL) @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ list='$(INFO_DEPS)'; test -n "$(infodir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(infodir)'"; \ $(MKDIR_P) "$(DESTDIR)$(infodir)" || exit 1; \ fi; \ for file in $$list; do \ case $$file in \ $(srcdir)/*) file=`echo "$$file" | sed "s|^$$srcdirstrip/||"`;; \ esac; \ if test -f $$file; then d=.; else d=$(srcdir); fi; \ file_i=`echo "$$file" | sed 's|\.info$$||;s|$$|.i|'`; \ for ifile in $$d/$$file $$d/$$file-[0-9] $$d/$$file-[0-9][0-9] \ $$d/$$file_i[0-9] $$d/$$file_i[0-9][0-9] ; do \ if test -f $$ifile; then \ echo "$$ifile"; \ else : ; fi; \ done; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(infodir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(infodir)" || exit $$?; done @$(POST_INSTALL) @if $(am__can_run_installinfo); then \ list='$(INFO_DEPS)'; test -n "$(infodir)" || list=; \ for file in $$list; do \ relfile=`echo "$$file" | sed 's|^.*/||'`; \ echo " install-info --info-dir='$(DESTDIR)$(infodir)' '$(DESTDIR)$(infodir)/$$relfile'";\ install-info --info-dir="$(DESTDIR)$(infodir)" "$(DESTDIR)$(infodir)/$$relfile" || :;\ done; \ else : ; fi install-man: install-man1 install-pdf: install-pdf-am install-pdf-am: $(PDFS) @$(NORMAL_INSTALL) @list='$(PDFS)'; test -n "$(pdfdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(pdfdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(pdfdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pdfdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(pdfdir)" || exit $$?; done install-ps: install-ps-am install-ps-am: $(PSS) @$(NORMAL_INSTALL) @list='$(PSS)'; test -n "$(psdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(psdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(psdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(psdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(psdir)" || exit $$?; done installcheck-am: maintainer-clean: maintainer-clean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache -rm -f bin/$(DEPDIR)/dpp.Po -rm -f gcl-tk/$(DEPDIR)/gcltkaux-guis.Po -rm -f gcl-tk/$(DEPDIR)/gcltkaux-tkAppInit.Po -rm -f gcl-tk/$(DEPDIR)/gcltkaux-tkMain.Po -rm -f o/$(DEPDIR)/alloc.Po -rm -f o/$(DEPDIR)/array.Po -rm -f o/$(DEPDIR)/assignment.Po -rm -f o/$(DEPDIR)/backq.Po -rm -f o/$(DEPDIR)/bcmp.Po -rm -f o/$(DEPDIR)/bcopy.Po -rm -f o/$(DEPDIR)/bds.Po -rm -f o/$(DEPDIR)/big.Po -rm -f o/$(DEPDIR)/bind.Po -rm -f o/$(DEPDIR)/bitop.Po -rm -f o/$(DEPDIR)/block.Po -rm -f o/$(DEPDIR)/bzero.Po -rm -f o/$(DEPDIR)/catch.Po -rm -f o/$(DEPDIR)/cfun.Po -rm -f o/$(DEPDIR)/character.Po -rm -f o/$(DEPDIR)/clxsocket.Po -rm -f o/$(DEPDIR)/cmpaux.Po -rm -f o/$(DEPDIR)/conditional.Po -rm -f o/$(DEPDIR)/earith.Po -rm -f o/$(DEPDIR)/error.Po -rm -f o/$(DEPDIR)/eval.Po -rm -f o/$(DEPDIR)/fat_string.Po -rm -f o/$(DEPDIR)/file.Po -rm -f o/$(DEPDIR)/format.Po -rm -f o/$(DEPDIR)/frame.Po -rm -f o/$(DEPDIR)/funlink.Po -rm -f o/$(DEPDIR)/gbc.Po -rm -f o/$(DEPDIR)/gcl_readline.Po -rm -f o/$(DEPDIR)/gmp_wrappers.Po -rm -f o/$(DEPDIR)/grab_defs.Po -rm -f o/$(DEPDIR)/hash.Po -rm -f o/$(DEPDIR)/iteration.Po -rm -f o/$(DEPDIR)/let.Po -rm -f o/$(DEPDIR)/lex.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-alloc.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-array.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-assignment.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-backq.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcmp.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bcopy.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bds.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-big.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bind.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bitop.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-block.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-bzero.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-catch.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cfun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-character.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-clxsocket.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-cmpaux.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-conditional.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-earith.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-error.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-eval.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-fat_string.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-file.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-format.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-frame.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-funlink.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gbc.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gcl_readline.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gmp_wrappers.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-gprof.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-hash.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-iteration.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-let.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-lex.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-list.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-macros.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-main.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-makefun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-mapfun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-msbrk.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-multival.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-new_init.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nfunlink.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-nsocket.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_arith.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_co.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_comp.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_log.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_pred.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_rand.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-num_sfun.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-number.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-package.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-pathname.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-predicate.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prelink.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-print.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-prog.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-read.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-reference.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-regexpr.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-run_process.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sequence.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sfasl.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-sockets.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-string.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-structure.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-symbol.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-toplevel.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-typespec.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfasl.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixfsys.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsave.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixsys.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-unixtime.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_init.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-user_match.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-usig2.Po -rm -f o/$(DEPDIR)/lib_libbase_gcl_gprof_a-utils.Po -rm -f o/$(DEPDIR)/lib_libgprof_a-gprof.Po -rm -f o/$(DEPDIR)/list.Po -rm -f o/$(DEPDIR)/macros.Po -rm -f o/$(DEPDIR)/main.Po -rm -f o/$(DEPDIR)/makefun.Po -rm -f o/$(DEPDIR)/mapfun.Po -rm -f o/$(DEPDIR)/msbrk.Po -rm -f o/$(DEPDIR)/multival.Po -rm -f o/$(DEPDIR)/new_init.Po -rm -f o/$(DEPDIR)/nfunlink.Po -rm -f o/$(DEPDIR)/nsocket.Po -rm -f o/$(DEPDIR)/num_arith.Po -rm -f o/$(DEPDIR)/num_co.Po -rm -f o/$(DEPDIR)/num_comp.Po -rm -f o/$(DEPDIR)/num_log.Po -rm -f o/$(DEPDIR)/num_pred.Po -rm -f o/$(DEPDIR)/num_rand.Po -rm -f o/$(DEPDIR)/num_sfun.Po -rm -f o/$(DEPDIR)/number.Po -rm -f o/$(DEPDIR)/package.Po -rm -f o/$(DEPDIR)/pathname.Po -rm -f o/$(DEPDIR)/predicate.Po -rm -f o/$(DEPDIR)/prelink.Po -rm -f o/$(DEPDIR)/print.Po -rm -f o/$(DEPDIR)/prog.Po -rm -f o/$(DEPDIR)/read.Po -rm -f o/$(DEPDIR)/reference.Po -rm -f o/$(DEPDIR)/regexpr.Po -rm -f o/$(DEPDIR)/run_process.Po -rm -f o/$(DEPDIR)/sequence.Po -rm -f o/$(DEPDIR)/sfasl.Po -rm -f o/$(DEPDIR)/sockets.Po -rm -f o/$(DEPDIR)/string.Po -rm -f o/$(DEPDIR)/structure.Po -rm -f o/$(DEPDIR)/symbol.Po -rm -f o/$(DEPDIR)/toplevel.Po -rm -f o/$(DEPDIR)/typespec.Po -rm -f o/$(DEPDIR)/unixfasl.Po -rm -f o/$(DEPDIR)/unixfsys.Po -rm -f o/$(DEPDIR)/unixsave.Po -rm -f o/$(DEPDIR)/unixsys.Po -rm -f o/$(DEPDIR)/unixtime.Po -rm -f o/$(DEPDIR)/user_init.Po -rm -f o/$(DEPDIR)/user_match.Po -rm -f o/$(DEPDIR)/usig.Po -rm -f o/$(DEPDIR)/usig2.Po -rm -f o/$(DEPDIR)/utils.Po -rm -f xgcl-2/$(DEPDIR)/Events.Po -rm -f xgcl-2/$(DEPDIR)/XStruct-2.Po -rm -f xgcl-2/$(DEPDIR)/XStruct-4.Po -rm -f xgcl-2/$(DEPDIR)/Xutil-2.Po -rm -f xgcl-2/$(DEPDIR)/general-c.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Events.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-2.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-XStruct-4.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-Xutil-2.Po -rm -f xgcl-2/$(DEPDIR)/lib_libxgcl_gprof_a-general-c.Po -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-aminfo \ maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-aminfo mostlyclean-compile \ mostlyclean-generic pdf: pdf-am pdf-am: $(PDFS) ps: ps-am ps-am: $(PSS) uninstall-am: uninstall-binSCRIPTS uninstall-dist_gcltkdocDATA \ uninstall-dist_my_gcltkDATA uninstall-dist_my_xgcl2DATA \ uninstall-dist_xgcl2docDATA uninstall-dvi-am \ uninstall-gcltkdocDATA uninstall-html-am uninstall-info-am \ uninstall-lispDATA uninstall-man uninstall-my_clcsDATA \ uninstall-my_cmpnewDATA uninstall-my_gcltkDATA \ uninstall-my_gcltkPROGRAMS uninstall-my_gcltkSCRIPTS \ uninstall-my_hDATA uninstall-my_lspDATA uninstall-my_pclDATA \ uninstall-my_unixportDATA uninstall-my_unixportLIBRARIES \ uninstall-my_unixportPROGRAMS uninstall-pdf-am uninstall-ps-am uninstall-man: uninstall-man1 .MAKE: all check check-am install install-am install-exec \ install-strip .PHONY: CTAGS GTAGS TAGS all all-am am--depfiles am--refresh check \ check-am clean clean-aminfo clean-cscope clean-generic \ clean-local clean-my_gcltkPROGRAMS clean-my_unixportLIBRARIES \ clean-my_unixportPROGRAMS clean-noinstLIBRARIES \ clean-noinstPROGRAMS cscope cscopelist-am ctags ctags-am dist \ dist-all dist-bzip2 dist-gzip dist-info dist-lzip dist-shar \ dist-tarZ dist-xz dist-zip dist-zstd distcheck distclean \ distclean-compile distclean-generic distclean-hdr \ distclean-local distclean-tags distcleancheck distdir \ distuninstallcheck dvi dvi-am html html-am info info-am \ install install-am install-binSCRIPTS install-data \ install-data-am install-dist_gcltkdocDATA \ install-dist_my_gcltkDATA install-dist_my_xgcl2DATA \ install-dist_xgcl2docDATA install-dvi install-dvi-am \ install-exec install-exec-am install-gcltkdocDATA install-html \ install-html-am install-info install-info-am install-lispDATA \ install-man install-man1 install-my_clcsDATA \ install-my_cmpnewDATA install-my_gcltkDATA \ install-my_gcltkPROGRAMS install-my_gcltkSCRIPTS \ install-my_hDATA install-my_lspDATA install-my_pclDATA \ install-my_unixportDATA install-my_unixportLIBRARIES \ install-my_unixportPROGRAMS install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-aminfo maintainer-clean-generic mostlyclean \ mostlyclean-aminfo mostlyclean-compile mostlyclean-generic pdf \ pdf-am ps ps-am tags tags-am uninstall uninstall-am \ uninstall-binSCRIPTS uninstall-dist_gcltkdocDATA \ uninstall-dist_my_gcltkDATA uninstall-dist_my_xgcl2DATA \ uninstall-dist_xgcl2docDATA uninstall-dvi-am \ uninstall-gcltkdocDATA uninstall-html-am uninstall-info-am \ uninstall-lispDATA uninstall-man uninstall-man1 \ uninstall-my_clcsDATA uninstall-my_cmpnewDATA \ uninstall-my_gcltkDATA uninstall-my_gcltkPROGRAMS \ uninstall-my_gcltkSCRIPTS uninstall-my_hDATA \ uninstall-my_lspDATA uninstall-my_pclDATA \ uninstall-my_unixportDATA uninstall-my_unixportLIBRARIES \ uninstall-my_unixportPROGRAMS uninstall-pdf-am uninstall-ps-am .PRECIOUS: Makefile export C_INCLUDE_PATH=$(srcdir)/h:$(srcdir)/gcl-tk unixport/saved_gcl$(EXEEXT): unixport/saved_ansi_gcl$(EXEEXT): unixport/saved_gcl_gprof$(EXEEXT): unixport/saved_ansi_gcl_gprof$(EXEEXT): unixport/libgcl.a: unixport/libansi_gcl.a: unixport/libgcl_gprof.a: unixport/libansi_gcl_gprof.a: $(addprefix unixport/saved_,gcl ansi_gcl gcl_gprof ansi_gcl_gprof):\ unixport/saved_%: unixport/raw_% # rebuild these only when out of date unixport/saved_%: | unixport/raw_% unixport/gcl_cmpnopt_%.lsp \ unixport/libboot.so unixport/init_raw.lsp rm -rf sb_$* # FIXME sandbox ugliness for parallel builds mkdir sb_$* cd sb_$* && \ ar x ../unixport/lib$*.a $$(ar t ../unixport/lib$*.a |grep ^gcl_) && \ ln -snf gcl_cmpnopt_$*.lsp ../unixport/gcl_cmpnopt.lsp && \ mkdir h && \ ln -snf ../../h/cmpinclude.h h/ && \ GCL_LSPSYSDIR=../$(srcdir)/unixport/ \ ../unixport/raw_$* $$(dirname $$(pwd))/unixport/ -libdir $$(dirname $$(pwd))/ \ < <(cat ../unixport/init_raw.lsp <(echo "(system:save-system \"../$@\")")) && \ rm -f ../unixport/gcl_cmpnopt.lsp rm -rf sb_$* unixport/raw_%: unixport/lib%.a $(CC) $(AM_LDFLAGS) -rdynamic -Wl,-z,relro $(LDFLAGS) -o $@ $< $(LIBS) #FIXME relro unixport/gcl_cmpnopt_gcl_gprof.lsp unixport/gcl_cmpnopt_ansi_gcl_gprof.lsp:\ unixport/gcl_cmpnopt_%_gprof.lsp: unixport/gcl_cmpnopt_%.lsp ln -snf $$(basename $<) $@ unixport/gcl_cmpnopt_pre_gcl.lsp: # FIXME necessary? touch $@ unixport/gcl_cmpnopt_%.lsp: unixport/lib%.a | unixport/% echo "(mapc (quote load) (directory \"$*/*.hsh\"))" \ "(compiler::dump-inl-hash \"$@\")" | $| $(addprefix unixport/lib,$(addsuffix .a,pre_gcl $(MY_DIRS))): \ unixport/lib%.a: lib/libbase_gcl.a $(LIBGPROF) unixport/sys_%.o $(addprefix unixport/lib,$(addsuffix .a,gcl_gprof ansi_gcl_gprof)): \ unixport/lib%.a:lib/libbase_gcl_gprof.a unixport/sys_%.o .POSIX: # parallel job ordering unixport/libgcl0.a: $(addprefix gcl0/,$(E0_OBJS) $(M0_OBJS) $(L0_OBJS)) $(addprefix unixport/lib,$(addsuffix .a,gcl1 gcl2 gcl3 gcl)):\ unixport/lib%.a: $(addprefix %/,$(L_OBJS)) unixport/libmod_gcl0.a unixport/libmod_gcl.a:\ unixport/lib%.a: $(addprefix %/,$(MOD_OBJS)) $(L_FOBJS) $(X_LIB) unixport/libgcl.a unixport/libmod_gcl.a: unixport/lib%.a: %/recompile unixport/libpcl_gcl.a: $(PCL_FOBJS) unixport/libansi_gcl.a: $(ANSI_FOBJS) unixport/libgcl_gprof.a: $(patsubst %.o,%.go,$(L_FOBJS)) unixport/libansi_gcl_gprof.a: $(patsubst %.o,%.go,$(ANSI_FOBJS)) unixport/lib%.a: | xbin/ar_merge $| $(ARFLAGS)s $@ $^ %/recompile: | unixport/% $| -batch \ -eval "(let ((si::*do-recomp-output-dir* \"$(@D)\")) (si::do-recomp t))" \ -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\")" touch $@ unixport/sys_%.o: unixport/sys_init.c i=$$(echo $* | sed 's,[0-9],,g' | sed 's,_gprof,,g'); \ $(CC) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -D $$i -D FLAVOR="$$i" -c $< -o $@ unixport/gcl0: | unixport/saved_pre_gcl unixport/gcl1: | unixport/saved_gcl0 unixport/gcl2: | unixport/saved_gcl1 unixport/gcl3: | unixport/saved_gcl2 unixport/gcl: | unixport/saved_gcl3 unixport/mod_gcl0: | unixport/saved_gcl unixport/mod_gcl: | unixport/saved_mod_gcl0 unixport/pcl_gcl: | unixport/saved_mod_gcl unixport/ansi_gcl: | unixport/saved_pcl_gcl $(addprefix unixport/,gcl0 gcl1): unixport/% : unixport/cinit.lisp | % $(word 2,$|) < <(cat $< <(echo "(system:save-system \"$@\")")) $(addprefix unixport/,gcl2 gcl3 gcl mod_gcl): unixport/% : | % ln -snf $$(basename $(word 2,$|)) $@ unixport/mod_gcl0: xgcl-2/sysdef.lisp | mod_gcl0 rm -f $(@D)/in [ "$(X_OBJS)" = "" ] || echo "(load \"$<\")" >$(@D)/in echo "(compiler::cdebug)(si::save-system \"$@\")" >>$(@D)/in $(word 2,$|) <$(@D)/in rm $(@D)/in cp gcl/all.hsh $(word 1,$|) #FIXME unixport/pcl_gcl: clcs/package.lisp cmpnew/gcl_collectfn.lsp pcl/defsys.lisp | pcl_gcl echo "(let ((*features* (remove :kcl *features*))) (mapc (quote load) (list $(patsubst %,\"%\",$^))))" \ "(compiler::cdebug)" \ "(setq compiler::*assert-ftype-proclamations* t)" \ "(setq pcl::*pcl-directory* (cons \"$$(dirname $(word 3,$^))/\" \"$(@F)/\"))" \ "(print pcl::*pcl-directory*)" \ "(setq pcl::*default-pathname-extensions* (cons \"lisp\" \"o\"))" \ "(setq pcl::*pathname-extensions* (cons \"lisp\" \"o\"))" \ "(si::save-system \"$@\")" | $(word 2,$|) unixport/ansi_gcl: clcs/package.lisp clcs/gcl_clcs_precom.lisp \ clcs/gcl_clcs_conditions.lisp clcs/gcl_clcs_condition_definitions.lisp \ | ansi_gcl echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \ "(compiler::cdebug)" \ "(si::save-system \"$@\")" | $(word 2,$|) cp pcl_gcl/all.hsh $(word 1,$|) #FIXME $(addprefix gcl0/,$(LL_OBJS)): gcl0/%.o : lsp/%.lsp $(addprefix gcl0/,$(LC_OBJS)): gcl0/%.o : cmpnew/%.lsp gcl0/%.o: | unixport/gcl0 $| -eval "(mapc 'load (directory \"$(@D)/*.done\"))" -compile $< -o $@ [ "$*" = "gcl_c" ] || [ "$*" = "gcl_listlib" ] || \ ln -f $@ $$(echo $@ |sed 's,\.o,\.done,g') #FIXME directory link $(addprefix gcl1/,$(LL_OBJS)): gcl1/%.o : lsp/%.lsp $(addprefix gcl1/,$(LC_OBJS)): gcl1/%.o : cmpnew/%.lsp gcl1/%.o: | unixport/gcl1 $| -eval "(mapc 'load (directory \"$(@D)/*.done\"))" \ -eval "(setq compiler::*dump-inl-hash* t)" \ -compile $< -o $@ [ "$*" = "gcl_sym" ] || ln -f $@ $$(echo $@ |sed 's,\.o,\.done,g') # FIXME listlib must come before sym $(addprefix gcl2/,$(LL_OBJS)): gcl2/%.o : lsp/%.lsp $(addprefix gcl2/,$(LC_OBJS)): gcl2/%.o : cmpnew/%.lsp gcl2/%.o: | unixport/gcl2 $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ $(addprefix gcl3/,$(LL_OBJS)): gcl3/%.o : lsp/%.lsp $(addprefix gcl3/,$(LC_OBJS)): gcl3/%.o : cmpnew/%.lsp gcl3/%.o: | unixport/gcl3 $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ gcl/%.o: gcl3/%.o | gcl cp $(patsubst %.o,%.*,$<) $(@D) $(addprefix mod_gcl0/,$(MMOD_OBJS)): mod_gcl0/%.o : mod/%.lsp $(addprefix mod_gcl0/,$(X_OBJS)): mod_gcl0/%.o : xgcl-2/%.lsp mod_gcl0/%.o: | unixport/mod_gcl0 $| -eval "(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ mod_gcl/%.o: mod_gcl0/%.o | unixport/mod_gcl cp $(patsubst %.o,%.*,$<) $(@D) %/c1: | unixport/% echo "(pcl::compile-pcl)" | $| touch $@ %/sys-package.lisp: %/c1 | unixport/% echo "(pcl::load-pcl)" \ "(compiler::get-packages-ansi \ (quote (:walker :iterate :pcl :slot-accessor-name)) \ \"$@\")" | $| %/sys-proclaim.lisp: %/c1 | unixport/% echo "(pcl::load-pcl)" \ "(si::do-recomp2 \ \"$@\" \ (mapcar (quote namestring) \ (directory \ (merge-pathnames \ \"*.*p\" \ (make-pathname \ :directory (pathname-directory \ (si::file (quote pcl::renew-sys-files))))))))" | $| %/p1.lisp: | unixport/% echo "(in-package :si)" \ "(export (quote %structure-name))" \ "(export (quote %compiled-function-name))" \ "(export (quote %set-compiled-function-name))" \ "(in-package :pcl)" >$@ %/all.hs1 : %/sys-package.lisp %/p1.lisp %/sys-proclaim.lisp | unixport/% rm -rf $*/*.o echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \ "(pcl::compile-pcl)" \ "(compiler::dump-inl-hash \"$@\")" | $| %/all.hsh: %/p1.lisp %/all.hs1 | unixport/pcl_gcl echo "pcl conflicts:" echo "(pcl::load-pcl)(si::all-conflicts)" | $| cat $^ > $@ $(addprefix pcl_gcl/,$(PCL_OBJS)): pcl_gcl/all.hsh touch $@ ansi_gcl/%.o: clcs/%.lisp | unixport/ansi_gcl $| -eval "(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ %.go: %.o mod_gcl/recompile #FIXME parallel $(CC) $(AM_CPPFLAGS) -I $(>$@ h/mstdint.h: echo "#include " | $(CC) -E -I./h/ - | $(AWK) '/fsid/ {next} {print}' >$@ h/mcompdefs.h: h/compdefs.h h/new_decl.h $(AWK) 'BEGIN {print "#include \"include.h\"";print "#include \"page.h\"";print "---"} {a=$$1;gsub("\\.\\.\\.","",a);print "\"#define " $$1 "\" " a}' $< |\ $(CC) $(AM_CPPFLAGS) $(AM_CFLAGS) -E -P -I./h/ - |\ $(AWK) '/^\-\-\-$$/ {i=1;next} {if (!i) next} {gsub("\"","");print}' >$@ h/cmpincludea.h: $(filter-out gclincl.h,$(CMPINCLUDE_FILES)) | h/gclincl.h # FIXME! cat $< $| $(filter-out $<,$^) | \ $(CC) $(AM_CPPFLAGS) $(AM_CFLAGS) -E -I./h/ - | \ $(AWK) '/^# |^$$|^#pragma/ {next}{print}' > $@ h/cmpinclude.h: h/mcompdefs.h h/cmpincludea.h h/cmponly_last.h @cat $^ >new_$(@F) @([ -e $@ ] && cmp new_$(@F) $@) || mv -v new_$(@F) $@ @rm -f new_$(@F) h/new_decl.h: $(INI_FILES) echo '#include "make-decl.h"' > foo.c cat $^ |sed 's,DEFBFUN,DEFUN,g' >> foo.c $(CPP) $(AM_CPPFLAGS) $(CPPFLAGS) foo.c | sed -n -e '/#/d' -e '/DO_/d' -e '/[a-zA-Z;]/p' > $@ rm -f foo.c o/boot.h: %.h: %.ini echo '#include "make-init.h"' > $@ echo 'void gcl_init_boot(void){' >> $@ cat $< >> $@ echo '}' >> $@ unixport/libboot.so: o/boot.c o/boot.h $(CC) $(AM_CPPFLAGS) -Io $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \ -fPIC -shared -Wl,-undefined -Wl,dynamic_lookup $< -o $@ o/boot.ini: CPPFLAGS += -DNO_BOOT_H # parallel builds can only have one target accessing an intermediate file # solved with BUILT_SOURCES o/%.ini: o/%.c | o/grab_defs @$(CPP) $(AM_CPPFLAGS) -DINICOMP -DNO_DEFUN $(CPPFLAGS) $< | $| > new_$(@F) @([ -e $@ ] && cmp new_$(@F) $@) || mv -v new_$(@F) $@ @rm -f new_$(@F) o/new_init.c: $(INI_FILES) echo '#include "make-init.h"' > $@ echo 'void NewInit(void){' >> $@ cat $^ >> $@ echo '}' >> $@ ! cat $@ | awk -F, '/DEFUN/ {print $$1,$$2}' | grep -v object || (rm $@ && false) sb_ansi-tests/test_results: ansi-tests | unixport/saved_ansi_gcl [ -d $(@D) ] || (mkdir $(@D) && cp $$(@D)/tmp cat $^ >>$(@D)/tmp paste $(@D)/tmp $| | \ $(AWK) '{if (n++) \ printf("%-10.10s %15.3f %15.3f %15.3f %15.3f %15.3f\n",$$1,$$2,$$4,$$6,$$8,$$10); else \ printf("%-10.10s %15.15s %15.15s %15.15s %15.15s %15.15s\n",$$1,$$2,$$4,$$7,$$10,$$13);}' \ >$@ cat $@ sb_bench: mkdir $@ sb_bench/fread.tim: sb_bench/fprint.tim sb_bench/%.tim: bench/%.cl | unixport/saved_ansi_gcl sb_bench echo "(load \"$($@ chmod a+x $@ man/man1/gcl%.1: man/man1/gcl.1 sed -e 's,\(\b\)gcl\(\b\),\1gcl$*\2,g' $< > $@ info/gcl%-dwdoc.texi: info/gcl-dwdoc.texi # FIXME one rule sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ info/gcl%-si.texi: info/gcl-si.texi sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ info/gcl%-tk.texi: info/gcl-tk.texi sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ info/gcl%.texi: info/gcl.texi sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ %.info: %.texi | xbin/mktmp # FIXME parallel ugliness i=$$($| $@);ln -f $< $$i;$(MAKEINFO) $$i --output $@;rm -f $$i %.pdf: %.dvi | xbin/mktmp i=$$($| $@);j=$$i.$$(echo $< | sed 's,.*\.,,g');ln -f $< $$j;\ dvipdfm $$j -o $@ && rm -f $$i* %.dvi: %.texi | xbin/mktmp i=$$($| $@);j=$$i.$$(echo $< | sed 's,.*\.,,g');ln -f $< $$j;\ TEXINPUTS=$(srcdir):$$TEXINPUTS \ tex -output-directory=$(@D) $$j|tail && mv $$i.dvi $@ && rm -f $$i* %.html: %.texi | xbin/mktmp mkdir -p $@ i=$$($| $@);ln -f $< $$i;$(MAKEINFO) --html $$i --output $@;rm -f $$i # end package extension install-all: install install-dvi install-pdf install-html clean_%: rm -rf $* $(addprefix unixport/,$* lib$*.a saved_$* sys_$*.o gcl_cmpnopt_$*.lsp) clean-local: $(addprefix clean_,pre_gcl $(MY_DIRS) gcl_gprof ansi_gcl_gprof) rm -rf sb_ansi-tests sb_cmpnew sb_bench distclean-local: rm -rf gcl.script unixport/gcl.script #FIXME rm -rf h/config.h #FIXME # 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: # Tell GNU make to disable its built-in pattern rules. %:: %,v %:: RCS/%,v %:: RCS/% %:: s.% %:: SCCS/s.% gcl-2.7.1/PaxHeaders/install-sh0000644000000000000000000000013214776130437013361 xustar0030 mtime=1744351519.787050969 30 atime=1744351519.963049368 30 ctime=1744351535.446909541 gcl-2.7.1/install-sh0000755000175000017500000003611514776130437012770 0ustar00cammcamm#!/bin/sh # install - install a program, script, or datafile scriptversion=2024-06-19.01; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # 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. tab=' ' nl=' ' IFS=" $tab$nl" # Set DOITPROG to "echo" to test this script. doit=${DOITPROG-} doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_mkdir= # Desired mode of installed file. mode=0755 # Create dirs (including intermediate dirs) using mode 755. # This is like GNU 'install' as of coreutils 8.32 (2020). mkdir_umask=22 backupsuffix= chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -p pass -p to $cpprog. -s $stripprog installed files. -S SUFFIX attempt to back up existing files, with suffix SUFFIX. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG By default, rm is invoked with -f; when overridden with RMPROG, it's up to you to specify -f if you want it. If -S is not specified, no backups are attempted. Report bugs to . GNU Automake home page: . General help using GNU software: ." while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -p) cpprog="$cpprog -p";; -s) stripcmd=$stripprog;; -S) backupsuffix="$2" shift;; -t) is_target_a_directory=always dst_arg=$2 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac shift;; -T) is_target_a_directory=never;; --version) echo "$0 (GNU Automake) $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done # We allow the use of options -d and -T together, by making -d # take the precedence; this is for compatibility with GNU install. if test -n "$dir_arg"; then if test -n "$dst_arg"; then echo "$0: target directory not allowed when installing a directory." >&2 exit 1 fi fi if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then if test $# -gt 1 || test "$is_target_a_directory" = always; then if test ! -d "$dst_arg"; then echo "$0: $dst_arg: Is not a directory." >&2 exit 1 fi fi fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 trap "ret=141; $do_exit" 13 trap "ret=143; $do_exit" 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names problematic for 'test' and other utilities. case $src in -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? # Don't chown directories that already exist. if test $dstdir_status = 0; then chowncmd="" fi else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # If destination is a directory, append the input filename. if test -d "$dst"; then if test "$is_target_a_directory" = never; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dstbase=`basename "$src"` case $dst in */) dst=$dst$dstbase;; *) dst=$dst/$dstbase;; esac dstdir_status=0 else dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi case $dstdir in */) dstdirslash=$dstdir;; *) dstdirslash=$dstdir/;; esac obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false # The $RANDOM variable is not portable (e.g., dash). Use it # here however when possible just to lower collision chance. tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap ' ret=$? rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null exit $ret ' 0 # Because "mkdir -p" follows existing symlinks and we likely work # directly in world-writable /tmp, make sure that the '$tmpdir' # directory is successfully created first before we actually test # 'mkdir -p'. if (umask $mkdir_umask && $mkdirprog $mkdir_mode "$tmpdir" && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibility with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. test_tmpdir="$tmpdir/a" ls_ld_tmpdir=`ls -ld "$test_tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null fi trap '' 0;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; [-=\(\)!]*) prefix='./';; *) prefix='';; esac oIFS=$IFS IFS=/ set -f set fnord $dstdir shift set +f IFS=$oIFS prefixes= for d do test X"$d" = X && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=${dstdirslash}_inst.$$_ rmtmp=${dstdirslash}_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && { test -z "$stripcmd" || { # Create $dsttmp read-write so that cp doesn't create it read-only, # which would cause strip to fail. if test -z "$doit"; then : >"$dsttmp" # No need to fork-exec 'touch'. else $doit touch "$dsttmp" fi } } && $doit_exec $cpprog "$src" "$dsttmp") && # 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 $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # If $backupsuffix is set, and the file being installed # already exists, attempt a backup. Don't worry if it fails, # e.g., if mv doesn't support -f. if test -n "$backupsuffix" && test -f "$dst"; then $doit $mvcmd -f "$dst" "$dst$backupsuffix" 2>/dev/null fi # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: gcl-2.7.1/PaxHeaders/ChangeLog0000644000000000000000000000013214555557372013140 xustar0030 mtime=1706483450.776392737 30 atime=1744294961.253792528 30 ctime=1744351535.442909577 gcl-2.7.1/ChangeLog0000644000175000017500000035515214555557372012551 0ustar00cammcamm2006-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.7.1/PaxHeaders/README0000644000000000000000000000013214776006046012236 xustar0030 mtime=1744309286.146034324 30 atime=1744309286.270034924 30 ctime=1744351535.442909577 gcl-2.7.1/README0000644000175000017500000002753514776006046011650 0ustar00cammcammDescription 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. Additional 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.7.1/PaxHeaders/release0000644000000000000000000000013214776071236012724 xustar0030 mtime=1744335518.341719145 30 atime=1744335596.758428108 30 ctime=1744351535.730906995 gcl-2.7.1/release0000644000175000017500000000004014776071236012314 0ustar00cammcammThu Apr 10 09:38:27 PM EDT 2025 gcl-2.7.1/PaxHeaders/mod0000644000000000000000000000013214776006046012060 xustar0030 mtime=1744309286.146034324 30 atime=1744351538.814879383 30 ctime=1744351535.642907784 gcl-2.7.1/mod/0000755000175000017500000000000014776006046011533 5ustar00cammcammgcl-2.7.1/mod/PaxHeaders/gcl_make_defpackage.lsp0000644000000000000000000000013114542551763016552 xustar0030 mtime=1703597043.280022865 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/mod/gcl_make_defpackage.lsp0000644000175000017500000000373314542551763016157 0ustar00cammcamm;;; 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.7.1/mod/PaxHeaders/gcl_destructuring_bind.lsp0000644000000000000000000000013114555557372017407 xustar0030 mtime=1706483450.796392732 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/mod/gcl_destructuring_bind.lsp0000644000175000017500000003707414555557372017021 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defmacro destructuring-bind (ll f &rest body) (compiler::blla ll nil f body)) ;; ;;;; 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 'lisp) ;; ;; (export '(destructuring-bind)) ;; (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)) ;; (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 defmacro-error (problem kind name) ;; ; FIXME check this ;; (declare (ignore kind)) ;; (error 'type-error :datum problem :expected-type name)) ;; (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 "destructuring-bind-error: kind ~s name ~s object ~s ll ~s~%" ;; ',error-kind ',name ',var ',object)))) ;; *system-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)))) ;; (defun make-keyword (symbol) ;; "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." ;; (intern (symbol-name symbol) (find-package "KEYWORD"))) ;; ;;;; 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)))))))) ;; (defun lookup-keyword (keyword key-list) ;; (do ((remaining key-list (cddr remaining))) ;; ((endp remaining)) ;; (when (eq keyword (car remaining)) ;; (return (cadr remaining))))) ;; (defun parse-defmacro-lambda-list ;; (lambda-list arg-list-name name error-kind error-fun ;; &optional top-level env-illegal env-arg-name wholep) ;; (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 '&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 ;; (defmacro-error "&ENVIRONMENT" error-kind name)))) ;; ((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 ;; (defmacro-error (symbol-name var) error-kind name)))) ;; ((eq var '&rest) ;; (setf restp t) ;; (setf now-processing :rest)) ;; ((eq var '&whole) ;; (setf now-processing :whole)) ;; ((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)) ;; (:rest ;; (let ((sub-list-name (gensym "SUBLIST-"))) ;; (push-sub-list-binding sub-list-name path var ;; name error-kind error-fun) ;; (parse-defmacro-lambda-list var sub-list-name name ;; error-kind error-fun))) ;; (:whole ;; (let ((sub-list-name (gensym "SUBLIST-"))) ;; (push-sub-list-binding sub-list-name arg-list-name var ;; name error-kind error-fun) ;; (parse-defmacro-lambda-list var sub-list-name name ;; error-kind error-fun nil nil nil t) ;; (setf now-processing :required))) ;; (: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))) ;; (:rest ;; (push-let-binding var path nil)) ;; (:whole ;; (push-let-binding var arg-list-name nil) ;; (setf now-processing :required)) ;; (: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 (or restp wholep) ;; (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)))) ;; ;;; 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 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 keyword-supplied-p (keyword key-list) ;; (do ((remaining key-list (cddr remaining))) ;; ((endp remaining)) ;; (when (eq keyword (car remaining)) ;; (return t)))) ;; ;;;; Destructuring-bind ;; (defmacro destructuring-bind (lambda-list arg-list &rest body) ;; "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." ;; (declare (optimize (safety 1))) ;; (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.7.1/mod/PaxHeaders/gcl_ansi_io.lsp0000644000000000000000000000013214733440601015113 xustar0030 mtime=1735278977.070650034 30 atime=1744346652.097823716 30 ctime=1744351535.642907784 gcl-2.7.1/mod/gcl_ansi_io.lsp0000644000175000017500000001402314733440601014511 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defun in-package-internal (n &aux (p (find-package n))) (or (when p (setq *package* p)) (progn (restart-case (error 'package-error :package n) (store-value (v) :report (lambda (s) (format s "Supply a new package name")) :interactive read-evaluated-form (setq n v))) (in-package-internal n)))) (defmacro in-package (name) `(in-package-internal ',name)) ;FIXME called from C (defun pprint-insert-conditional-newlines (st) (if (>= (string-match #v"[^\n\r ] +" st) 0) (concatenate 'string (subseq st 0 (match-end 0)) "~:_" (pprint-insert-conditional-newlines (subseq st (match-end 0)))) st)) ;FIXME called from C (defun pprint-check-format-string (st) (let ((j (>= (string-match #v"~>" st) 0)) (pp (>= (string-match #v"~:@?>|~:?@?_|~[0-9]*:?I|~[0-9]+,[0-9]+:?@?T]|~:?@?W" st) 0))) (assert (not (and j pp))) j)) ;FIXME called from C (defun pprint-quit (x h s count) (cond ((or (and x (atom x)) (and *print-circle* h (gethash x h))) (when (>= count 0) (write-string ". " s)) (write x :stream s) t) ((and *print-length* (>= count *print-length* 0)) (write-string "..." s) t) ((and (< count 0) *print-level* (> *prin-level* *print-level*)) (write-string "#" s) t))) (defmacro pprint-logical-block ((s x &key (prefix "") (per-line-prefix "") (suffix "")) &body body &aux (count (gensym))) (declare (optimize (safety 1))) `(let* ((*print-line-prefix* ,per-line-prefix)(*prin-level* (1+ *prin-level*))) (check-type *print-line-prefix* string) (flet ((do-pref (x h) (if (pprint-quit x h ,s -1) (return-from do-pref nil) (write-string ,prefix ,s))) (do-suf (x h) (declare (ignore x h)) (write-string ,suffix ,s));FIXME (do-pprint (x h &aux (,count 0)) (macrolet ((pprint-pop nil '(if (pprint-quit x h ,s ,count) (return-from do-pprint nil) (progn (incf ,count)(pop x)))) (pprint-exit-if-list-exhausted nil '(unless x (return-from do-pprint nil)))) ,@body))) (write-int1 ,x ,s #'do-pprint #'do-pref #'do-suf)))) (defun pprint-fill (s list &optional (colon-p t) at-sign-p) (declare (ignore at-sign-p)) (unless (listp list) (setq colon-p nil)) (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-newline :fill s)))) (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)))) (defun pprint-linear (s list &optional (colon-p t) at-sign-p) (declare (ignore at-sign-p)) (unless (listp list) (setq colon-p nil)) (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-newline :linear s)))) (defun coerce-to-stream (strm) (case strm ((nil) *standard-output*) ((t) *terminal-io*)(otherwise strm))) (defun pprint-tab (kind colnum colinc &optional strm) (declare (optimize (safety 1))) (check-type kind (member :line :section :line-relative :section-relative)) (check-type colnum (integer 0)) (check-type colinc (integer 0)) (check-type strm (or boolean stream));FIXME output-stream (when *print-pretty* (pprint-queue-codes (coerce-to-stream strm) (get kind 'fixnum) colnum colinc))) (defun pprint-indent (kind n &optional stream) (declare (optimize (safety 1))) (check-type kind (member :current :block)) (check-type n real) (check-type stream (or boolean stream)) (when *print-pretty* (let* ((stream (coerce-to-stream stream))) (unless (pprint-miser-style stream) (pprint-queue-codes stream (get kind 'fixnum) (round n)))))) (defun pprint-newline (kind &optional stream) (declare (optimize (safety 1))) (check-type kind (member :linear :miser :fill :mandatory)) (check-type stream (or boolean stream)) (when *print-pretty* (let ((stream (coerce-to-stream stream))) (pprint-queue-codes stream (get (case kind (:miser (if (pprint-miser-style stream) :linear (return-from pprint-newline nil))) (:fill (if (pprint-miser-style stream) :linear kind)) (otherwise kind)) 'fixnum))))) (defvar *print-pprint-dispatch* (list nil)) (defun pprint-make-dispatch (table) `(lambda (x) (typecase x ,@(mapcar (lambda (x) `(,(car x) (values ',(cadr x) t))) table) (otherwise (values nil nil))))) (defun set-pprint-dispatch (spec fun &optional (pri 0) (tab *print-pprint-dispatch*) &aux (x (assoc spec (car tab) :test 'equal))) (declare (optimize (safety 1))) (check-type spec type-spec) (check-type fun (or null function-name function)) (check-type pri real) (check-type tab (cons list (or null function))) (if x (setf (cadr x) fun (caddr x) pri) (push (list spec fun pri) (car tab))) (sort (car tab) '> :key 'caddr) (setf (cdr tab) (compile nil (pprint-make-dispatch (car tab)))) nil) (defun pprint-dispatch (obj &optional (table *print-pprint-dispatch*)) (declare (optimize (safety 1))) (check-type table (cons list (or null function))) (if (cdr table) (funcall (cdr table) obj) (values nil nil))) (defun copy-pprint-dispatch (&optional (tab *print-pprint-dispatch*)) (declare (optimize (safety 1))) (check-type tab (or null (cons list (or null function)))) (cons (car tab) (cdr tab))) gcl-2.7.1/mod/PaxHeaders/gcl_defpackage.lsp0000644000000000000000000000013114555557372015563 xustar0030 mtime=1706483450.792392733 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/mod/gcl_defpackage.lsp0000644000175000017500000002523614555557372015172 0ustar00cammcamm;;; -*- 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. ;;; Copyright (c) 2024 Camm Maguire ;;; ;;; 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). ;;; ;;; ----------------------------------------------------------------- (unless (find-package :defpackage) (make-package :defpackage :use '(:cl))) (in-package :defpackage) (export '(defpackage)) (use-package :SLOOP) (defmacro DEFPACKAGE (name &rest options) (declare (optimize (safety 1))) "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)) (let ((name (string name))) (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))) FIXME? size support in gcl (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))) ,@(when (not (null (member :use options :key 'car))) `((unuse-package (package-use-list (find-package ,name)) ,name)))) (make-package ,name :use 'nil :nicknames ',nicknames)) ,@(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) (multiple-value-bind (sym fnd) (find-symbol symbol ,(first list)) (unless fnd (specific-correctable-error :package-error "A package error occurred on ~S: ~S." ,(first list) (format nil "~%Symbol ~a not present" symbol))) (intern symbol ,(first list)))) ; FIXME better error messages ',(rest list)))) SHADOWING-IMPORTed-from-symbol-names-list)) (USE-PACKAGE ',(if (member :USE options :test #'option-test) (mapcar 'string (option-values :USE options)) "CL")) ,@(when IMPORTed-from-symbol-names-list (mapcar (lambda (list) `(IMPORT (mapcar (lambda (symbol) (multiple-value-bind (sym fnd) (find-symbol symbol ,(first list)) (unless fnd (specific-correctable-error :package-error "A package error occurred on ~S: ~S." ,(first list) (format nil "~%Symbol ~a not present" symbol))) (intern symbol ,(first list)))) ; FIXME better error messages ',(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)))))) (provide :defpackage) (pushnew :defpackage *features*) (eval-when (load) (in-package :USER) (unintern 'defpackage 'user) (use-package "DEFPACKAGE")) ;;;; ------------------------------------------------------------ ;;;; End of File ;;;; ------------------------------------------------------------ gcl-2.7.1/mod/PaxHeaders/gcl_loop.lsp0000644000000000000000000000013114720126436014445 xustar0030 mtime=1732291870.754087843 29 atime=1744346652.10182374 30 ctime=1744351535.642907784 gcl-2.7.1/mod/gcl_loop.lsp0000644000175000017500000025201314720126436014047 0ustar00cammcamm;;; -*- Mode: LISP; Package: ANSI-LOOP; Syntax: Common-lisp; Base: 10; Lowercase:T -*- ;;;> ;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. ;;;> Portions of LOOP are Copyright (c) 2024 Camm Maguire ;;;> 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) #-allegro (in-package :ansi-loop) (export '(loop loop-finish)) (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* (gensym (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 (:constructor make-loop-minimax-internal) (:copier 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 (:print-function print-loop-universe) (:copier 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 ) (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)) #+(or Genera cmu) ;@@@@ This is reallly the ANSI definition. (print-unreadable-object (u stream :type t :identity t) (princ str stream)) #-(or Genera CLOE cmu) (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) (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 (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) ;;;; 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: (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 t;(ext:valid-function-name-p (cadr x)) 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 'style-warning :format-control "~?~%Current LOOP context:~{ ~S~}." :format-arguments (list 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." (declare (optimize (safety 1))) '(go end-loop)) (defun subst-gensyms-for-nil (tree) (declare (special *ignores*)) (cond ((null tree) (car (push (loop-gentemp) *ignores*))) ((atom tree) tree) (t (cons (subst-gensyms-for-nil (car tree)) (subst-gensyms-for-nil (cdr tree)))))) (defun loop-build-destructuring-bindings (crocks forms) (if crocks (let ((*ignores* ())) (declare (special *ignores*)) `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) ,(cadr crocks) (declare (ignore ,@*ignores*)) ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) forms)) (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-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*))))) (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 ,@(loop-build-destructuring-bindings crocks forms))))))) (if *loop-names* (do () ((null (car *loop-names*)) answer) (setq answer `(block ,(pop *loop-names*) ,answer))) `(block nil ,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-compound-form () (let ((form (loop-get-form))) (unless (consp form) (loop-error "Compound form expected, but found ~A." form)) form)) (defun loop-get-progn () (do ((forms (list (loop-get-compound-form)) (cons (loop-get-compound-form) 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) (push form *loop-body*)) ;; (cond (*loop-emitted-body* (push form *loop-body*)) ;; (*loop-inside-conditional* (push form *loop-body*) (push nil *loop-before-loop*) (push nil *loop-after-body*)) ;; ; (*loop-inside-while* (nconc *loop-before-loop* (list nil)) (nconc *loop-after-body* (list form))) ;; (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 (&optional (form nil form-supplied-p)) (when form-supplied-p (push (loop-construct-return form) *loop-after-epilogue*)) (when *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))) (defun loop-disallow-anonymous-collectors () (when (find-if-not 'loop-collector-name *loop-collection-cruft*) (loop-error "This LOOP clause is not permitted with anonymous collectors."))) (defun loop-disallow-aggregate-booleans () (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) ;;;; 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) ((symbolp 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)) ((or (atom k) (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-variable-p (name) (do ((entry *loop-bind-stack* (cdr entry))) (nil) (cond ((null entry) (return nil)) ((assoc name (caar entry) :test #'eq) (return t))))) (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-))) (loop-declare-variable name dtype) (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 (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) (first-clause-p t)) (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 (and (loop-tequal (car *loop-source-code*) 'it) first-clause-p) (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))))))) (setq first-clause-p nil) (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 (:copier nil) (:predicate nil)) name class (history nil) (tempvars nil) dtype (data nil)) ;collector-specific data (defun loop-get-collection-info (collector class default-type) (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 name (loop-disallow-aggregate-booleans)) (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) (when (and name (loop-variable-p name)) (loop-error "Variable ~S cannot be used in INTO clause" name)) (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-disallow-anonymous-collectors) (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-disallow-anonymous-collectors) (loop-emit-final-value) (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) ,(loop-construct-return *loop-when-it-variable*)))) (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))) (when (and var (loop-variable-p var)) (loop-error "Variable ~S has already been used" var)) (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 () (loop-disallow-conditional :repeat) (let ((form (loop-get-form)) (type 'real)) (let ((var (loop-make-variable (loop-gentemp) form type))) (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*) (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*) ;; FIXME: What should ;; (loop count t into a ;; repeat 3 ;; count t into b ;; finally (return (list a b))) ;; return: (3 3) or (4 3)? PUSHes above are for the former ;; variant, L-P-B below for the latter. #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop)))))) (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 't) (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 (:copier 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)) (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 (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) (indexv (or indexv (gensym))) ) (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) (temp-val-var (loop-gentemp 'loop-hash-val-temp-)) (temp-key-var (loop-gentemp 'loop-hash-key-temp-)) (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-)) (variable (or variable (loop-gentemp))) (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-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) (,next-fn) ;; We use M-V-BIND instead of M-V-SETQ because we only ;; want to assign values to the key and val vars when we ;; are in the hash table. When we reach the end, ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and ;; temp-val-var. This might break any type declarations ;; on the key and val vars. (when ,temp-predicate-var (setq ,val-var ,temp-val-var) (setq ,key-var ,temp-key-var)) (setq ,dummy-predicate-var ,temp-predicate-var) )) ;post-test ,post-steps))))) (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) (cond ((and prep-phrases (cdr prep-phrases)) (loop-error "Too many prepositions!")) ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) (loop-error "Unknow preposition ~S" (caar prep-phrases)))) (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-)) (variable (or variable (loop-gentemp))) (pkg (or (cadar prep-phrases) '*package*))) (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) `(((,variable nil ,data-type) (,pkg-var ,pkg)) () () () (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)) (repeat (loop-do-repeat))) :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)) (to (loop-for-arithmetic :to)) (upto (loop-for-arithmetic :upto)) (downto (loop-for-arithmetic :downto)) (by (loop-for-arithmetic :by)) (being (loop-for-being))) :iteration-keywords '((for (loop-do-for)) (as (loop-do-for))) :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 :external))) 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)) (declare (optimize (safety 1))) (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.7.1/PaxHeaders/majvers0000644000000000000000000000013014542551763012750 xustar0030 mtime=1703597043.276022859 29 atime=1744339797.16730268 29 ctime=1744351535.72690703 gcl-2.7.1/majvers0000755000175000017500000000000214542551763012343 0ustar00cammcamm2 gcl-2.7.1/PaxHeaders/Makefile.am0000644000000000000000000000013214776120507013411 xustar0030 mtime=1744347463.582839865 30 atime=1744347471.742890339 30 ctime=1744351535.390910043 gcl-2.7.1/Makefile.am0000644000175000017500000005754214776120507013024 0ustar00cammcammexport C_INCLUDE_PATH=$(srcdir)/h:$(srcdir)/gcl-tk AM_CPPFLAGS=$(BASE_CPPFLAGS) AM_CFLAGS=$(BASE_CFLAGS) AM_LDFLAGS=$(BASE_LDFLAGS) AUTOMAKE_OPTIONS=subdir-objects info-in-builddir my_libdir=$(libdir)/$(PACKAGE)-$(PACKAGE_VERSION) my_unixportdir=$(my_libdir)/unixport my_gcltkdir=$(my_libdir)/gcl-tk my_xgcl2dir=$(my_libdir)/xgcl-2 my_pcldir=$(my_libdir)/pcl my_lspdir=$(my_libdir)/lsp my_hdir=$(my_libdir)/h my_cmpnewdir=$(my_libdir)/cmpnew my_clcsdir=$(my_libdir)/clcs docdir=$(datarootdir)/doc/$(PACKAGE) xgcl2docdir=$(docdir)/xgcl-2 gcltkdocdir=$(docdir)/gcl-tk # primaries noinst_PROGRAMS=bin/dpp o/grab_defs noinst_LIBRARIES=lib/libbase_gcl.a my_unixport_PROGRAMS=unixport/saved_gcl unixport/saved_ansi_gcl my_unixport_LIBRARIES=unixport/libgcl.a unixport/libansi_gcl.a bin_SCRIPTS=bin/gcl check_SCRIPTS=sb_ansi-tests/test_results sb_bench/timing_results info_TEXINFOS=info/gcl.texi info/gcl-si.texi my_unixport_DATA=$(addprefix unixport/,init_raw.lsp gcl.script libboot.so \ gcl_cmpnopt_gcl.lsp gcl_cmpnopt_ansi_gcl.lsp) my_h_DATA=h/cmpinclude.h my_cmpnew_DATA=sb_cmpnew/gcl_collectfn.o cmpnew/gcl_lfun_list.lsp cmpnew/gcl_cmpopt.lsp my_pcl_DATA=pcl/package.lisp my_lsp_DATA=lsp/gcl_auto_new.lsp lsp/gcl_autoload.lsp lsp/gcl_defmacro.lsp \ lsp/gcl_evalmacros.lsp lsp/gcl_export.lsp lsp/gcl_module.lsp lsp/gcl_top.lsp my_clcs_DATA=clcs/package.lisp dist_man1_MANS=man/man1/gcl.1 lisp_DATA=elisp/add-default.el elisp/ansi-doc.el elisp/dbl.el elisp/doc-to-texi.el \ elisp/gcl.el elisp/man1-to-texi.el elisp/smart-complete.el elisp/sshell.el dist_noinst_DATA= # conditionals if AMM_GPROF LIBGPROF=lib/libgprof.a noinst_LIBRARIES+=$(LIBGPROF) lib/libbase_gcl_gprof.a my_unixport_PROGRAMS+=unixport/saved_gcl_gprof unixport/saved_ansi_gcl_gprof my_unixport_LIBRARIES+=unixport/libgcl_gprof.a unixport/libansi_gcl_gprof.a endif #it would be nice someday to sandbox xgcl-2 and gcl-tk builds in tmpdirs if AMM_XGCL X_LIB=lib/libxgcl.a noinst_LIBRARIES+=$(X_LIB) dist_xgcl2doc_DATA=xgcl-2/Xakcl.paper xgcl-2/README dist_xgcl2doc_DATA+=$(addprefix xgcl-2/gcl_,\ $(addsuffix .lsp,\ menu-set pcalc draw dwindow editors ice-cream lispserver Xakcl.example)) dist_my_xgcl2_DATA=xgcl-2/sysdef.lisp \ $(addprefix xgcl-2/gcl_,$(addsuffix .lsp,\ dwtest dwtestcases drawtrans editorstrans lispservertrans menu-settrans draw-gates)) X_OBJS=$(addprefix gcl_,$(addsuffix .o,\ Xlib Xutil X XAtom defentry_events Xstruct XStruct_l_3 \ general keysymdef X10 Xinit dwtrans tohtml index)) dist_noinst_DATA+=$(addprefix xgcl-2/,dwdoc.tex gnu.license dec.copyright version\ $(patsubst %.o,%.lsp,$(X_OBJS))) info_TEXINFOS+=info/gcl-dwdoc.texi if AMM_GPROF noinst_LIBRARIES+=lib/libxgcl_gprof.a endif endif if AMM_TK my_gcltk_PROGRAMS=gcl-tk/gcltkaux my_gcltk_SCRIPTS=gcl-tk/gcltksrv my_gcltk_DATA=gcl-tk/tkl.o gcl-tk/tinfo.o gcl-tk/demos/gc-monitor.o gcltkdoc_DATA=gcl-tk/demos/index.lsp dist_my_gcltk_DATA=gcl-tk/tk-package.lsp gcl-tk/gcl.tcl dist_gcltkdoc_DATA=$(addprefix gcl-tk/demos/,$(addsuffix .lisp,\ gc-monitor mkBasic mkCanvText mkdialog mkEntry2 mkEntry mkForm mkHScale mkItems \ mkLabel mkListbox mkPlot mkRadio mkRuler mkSearch mkStyles mkTextBind mkVScale \ nqthm-stack showVars widget)) dist_noinst_DATA+=gcl-tk/tkl.lisp gcl-tk/tinfo.lsp info_TEXINFOS+=info/gcl-tk.texi endif EXTRA_DIST=$(D_SRC) $(INCL_C) $(INIT_L) $(INCL_TEXI)\ lsp cmpnew mod pcl clcs ansi-tests elisp xbin bench \ majvers minvers git.tag release # end of primaries INCL_TEXI=$(addprefix info/,$(addsuffix .texi,\ bind c-interface chap-1 chap-10 chap-11 chap-12 chap-13 chap-14 chap-15 chap-16 chap-17 chap-18 chap-19 \ chap-2 chap-20 chap-21 chap-22 chap-23 chap-24 chap-25 chap-26 chap-3 chap-4 chap-5 chap-6 chap-7 chap-8 \ chap-9 chap-a character compile compiler-defs control debug doc form \ general internal io iteration japi list misc number sequence si-defs structure symbol system type \ user-interface widgets)) INCL_C=o/sgbc.c o/gmp_big.c o/gmp.c o/gmp_num_log.c o/cmac.c o/regexp.c o/unexelf.c o/unexmacosx.c o/unexnt.c \ o/save.c o/xdrfuns.c o/fasdump.c o/usig2_aux.c o/sfaslelf.c o/sfaslmacho.c o/sfaslcoff.c gcl-tk/comm.c \ o/sfasli.c o/firstfile.c o/lastfile.c INIT_L=unixport/sys_init.c unixport/sys.c o/boot.c unixport/cinit.lisp BASE_H= h/compbas2.h h/compbas.h h/compprotos.h h/cstack.h h/enum.h h/error.h h/eval.h h/fixnum.h h/frame.h \ h/funlink.h h/globals.h h/gmp_wrappers.h h/immnum.h h/include.h h/lex.h h/linux.h h/lu.h h/make-init.h \ h/mp.h h/notcomp.h h/num_include.h h/object.h h/options.h h/page.h h/pageinfo.h h/pbits.h h/pool.h \ h/prelink.h h/protoize.h h/ptable.h h/rgbc.h h/sfun_argd.h h/stacks.h h/type.h h/usig.h h/vs.h \ h/writable.h o/regexp.h h/arth.h h/bsd.h h/bds.h h/att_ext.h h/bfdef.h h/compat.h h/apply_n.h \ gcl-tk/sheader.h h/make-decl.h h/defun.h o/ntheap.h CMPI_H= h/compdefs.h h/cmpincl1.h h/mgmp.h h/compprotos.h h/compbas2.h h/cmponly_last.h ARCHT_H=h/elf32_armhf_reloc.h h/elf32_armhf_reloc_special.h h/elf32_arm_reloc.h h/elf32_arm_reloc_special.h \ h/elf32_hppa_reloc.h h/elf32_hppa_reloc_special.h h/elf32_i386_reloc.h h/elf32_m68k_reloc.h \ h/elf32_mips_reloc.h h/elf32_mips_reloc_special.h h/elf32_ppc_reloc.h h/elf32_s390_reloc.h \ h/elf32_sh4_reloc.h h/elf32_sparc_reloc.h h/elf64_aarch64_reloc.h h/elf64_aarch64_reloc_special.h \ h/elf64_alpha_reloc.h h/elf64_alpha_reloc_special.h h/elf64_i386_reloc.h h/elf64_i386_reloc_special.h \ h/elf64_loongarch64_reloc.h h/elf64_loongarch64_reloc_special.h h/elf64_mips_reloc.h \ h/elf64_mips_reloc_special.h h/elf64_ppcle_reloc.h h/elf64_ppcle_reloc_special.h h/elf64_ppc_reloc.h \ h/elf64_ppc_reloc_special.h h/elf64_riscv64_reloc.h h/elf64_s390_reloc.h h/elf64_sparc_reloc.h \ h/elf64_sparc_reloc_special.h h/mach32_i386_reloc.h h/mach32_ppc_reloc.h h/mach64_i386_reloc.h \ h/sh4-linux.h h/amd64-linux.h h/amd64-kfreebsd.h h/386-linux.h h/riscv64-linux.h \ h/386-kfreebsd.h h/amd64-gnu.h h/386-gnu.h h/m68k-linux.h h/alpha-linux.h h/mips-linux.h \ h/mipsel-linux.h h/sparc-linux.h h/aarch64-linux.h h/armhf-linux.h h/arm-linux.h h/s390-linux.h \ h/ia64-linux.h h/hppa-linux.h h/loongarch64-linux.h h/powerpc-linux.h h/powerpc-macosx.h \ h/386-macosx.h h/mingw.h h/gnuwin95.h h/FreeBSD.h h/solaris.h h/solaris-i386.h BUILT_H=h/new_decl.h o/boot.h h/cmpinclude.h C_SRC=o/typespec.c o/alloc.c o/gbc.c o/bitop.c o/main.c o/eval.c o/macros.c o/lex.c o/bds.c o/frame.c\ o/predicate.c o/reference.c o/assignment.c o/bind.c o/let.c o/conditional.c o/block.c o/iteration.c\ o/prog.c o/multival.c o/catch.c o/cfun.c o/cmpaux.c o/big.c o/number.c o/num_pred.c o/num_comp.c\ o/num_arith.c o/num_sfun.c o/num_co.c o/num_log.c o/num_rand.c o/earith.c\ o/array.c o/regexpr.c o/structure.c o/toplevel.c o/backq.c o/format.c\ o/unixfsys.c o/unixfasl.c o/error.c o/unixtime.c o/unixsys.c o/unixsave.c o/funlink.c o/fat_string.c\ o/run_process.c o/nfunlink.c o/usig.c o/usig2.c o/utils.c o/makefun.c o/sockets.c o/gmp_wrappers.c\ o/clxsocket.c o/nsocket.c o/prelink.c o/sfasl.c o/msbrk.c \ o/bcmp.c o/bcopy.c o/bzero.c o/user_init.c o/user_match.c o/mapfun.c D_SRC=o/character.d o/file.d o/gcl_readline.d o/hash.d o/list.d o/package.d o/pathname.d o/print.d\ o/read.d o/sequence.d o/string.d o/symbol.d BUILT_C=o/character.c o/file.c o/gcl_readline.c o/hash.c o/list.c o/package.c o/pathname.c o/print.c\ o/read.c o/sequence.c o/string.c o/symbol.c o/new_init.c INI_FILES=$(patsubst %.c,%.ini,$(C_SRC)) $(patsubst %.d,%.ini,$(D_SRC)) if AMM_GPROF INI_FILES+=o/gprof.ini endif BUILT_SOURCES=$(BUILT_H) $(BUILT_C) CLEANFILES=$(BUILT_SOURCES) $(INI_FILES) o/boot.ini lib_libbase_gcl_a_SOURCES=$(C_SRC) $(BASE_H) $(CMPI_H) $(ARCHT_H) nodist_lib_libbase_gcl_a_SOURCES=$(BUILT_C) lib_libgprof_a_SOURCES=o/gprof.c lib_libgprof_a_CFLAGS=$(AM_CFLAGS) -fno-omit-frame-pointer -pg lib_libbase_gcl_gprof_a_SOURCES=$(lib_libbase_gcl_a_SOURCES) o/gprof.c nodist_lib_libbase_gcl_gprof_a_SOURCES=$(nodist_lib_libbase_gcl_a_SOURCES) lib_libbase_gcl_gprof_a_CFLAGS=$(AM_CFLAGS) -fno-omit-frame-pointer -pg lib_libbase_gcl_gprof_a_CPPFLAGS=$(AM_CPPFLAGS) -DGCL_GPROF X_SRC=xgcl-2/Events.c xgcl-2/general-c.c xgcl-2/XStruct-2.c xgcl-2/XStruct-4.c xgcl-2/Xutil-2.c lib_libxgcl_a_SOURCES=$(X_SRC) lib_libxgcl_gprof_a_SOURCES=$(X_SRC) lib_libxgcl_gprof_a_CFLAGS=$(AM_CFLAGS) -fno-omit-frame-pointer -pg unixport_saved_gcl_SOURCES= unixport/saved_gcl$(EXEEXT): unixport_saved_ansi_gcl_SOURCES= unixport/saved_ansi_gcl$(EXEEXT): unixport_saved_gcl_gprof_SOURCES= unixport/saved_gcl_gprof$(EXEEXT): unixport_saved_ansi_gcl_gprof_SOURCES= unixport/saved_ansi_gcl_gprof$(EXEEXT): unixport_libgcl_a_SOURCES= unixport/libgcl.a: unixport_libansi_gcl_a_SOURCES= unixport/libansi_gcl.a: unixport_libgcl_gprof_a_SOURCES= unixport/libgcl_gprof.a: unixport_libansi_gcl_gprof_a_SOURCES= unixport/libansi_gcl_gprof.a: GCLTK_SRC=gcl-tk/guis.c gcl-tk/tkAppInit.c gcl-tk/tkMain.c gcl-tk/guis.h gcl_tk_gcltkaux_SOURCES=$(GCLTK_SRC) gcl_tk_gcltkaux_CPPFLAGS=$(AM_CPPFLAGS) $(TK_INCLUDE) $(TCL_INCLUDE) $(TK_XINCLUDES) gcl_tk_gcltkaux_LDADD=$(TK_LIB_SPEC) $(TCL_LIB_SPEC) MY_DIRS=gcl0 gcl1 gcl2 gcl3 gcl mod_gcl0 mod_gcl pcl_gcl ansi_gcl L_STUBS=s sf c listlib predlib deftype typeof subtypep bit type typep typecase arraylib \ seq seqlib bnum fle dl rm nr lr sym hash sharp \ cmptype cmpeval cmpvar cmpwt cmpif \ cmplet cmptag cmpinline cmpenv cmplam cmptop cmpbind cmpblock cmpcall cmpcatch \ cmpflet cmpfun cmplabel cmploc cmpmap cmpmulti cmpspecial cmputil cmpvs cmpmain \ callhash assert defmacro defstruct \ describe evalmacros sc logical_pathname_translations make_pathname parse_namestring \ merge_pathnames pathname_match_p namestring wild_pathname_p translate_pathname \ truename directory rename_file restart iolib mislib module numlib packlib \ setf top trace sloop debug info serror mnum fpe L_OBJS=$(addprefix gcl_,$(addsuffix .o,$(L_STUBS))) LC_OBJS=$(filter gcl_cmp%,$(L_OBJS)) LL_OBJS=$(filter-out gcl_cmp%,$(L_OBJS)) L_FOBJS=$(addprefix gcl/,$(L_OBJS)) MOD_STUBS=ansi_io defpackage destructuring_bind loop make_defpackage MMOD_OBJS=$(addprefix gcl_,$(addsuffix .o,$(MOD_STUBS))) MOD_OBJS=$(MMOD_OBJS) $(X_OBJS) MOD_FOBJS=$(addprefix mod_gcl/,$(MOD_OBJS)) $(L_FOBJS) $(X_LIB) PCL_STUBS=boot braid cache combin compat cpl ctypes defclass defcombin defs dfun dlisp2\ dlisp env fast_init fin fixup fngen fsc generic_functions impl_low init iterate\ low macros methods pkg precom1 precom2 slots_boot slots std_class vector walk PCL_OBJS=$(addprefix gcl_pcl_,$(addsuffix .o,$(PCL_STUBS))) PCL_FOBJS=$(addprefix pcl_gcl/,$(PCL_OBJS)) $(MOD_FOBJS) CLCS_STUBS=condition_definitions conditions precom CLCS_OBJS=$(addprefix gcl_clcs_,$(addsuffix .o,$(CLCS_STUBS))) ANSI_FOBJS=$(addprefix ansi_gcl/,$(CLCS_OBJS)) $(PCL_FOBJS) CLEANFILES+=$(addprefix unixport/raw_,gcl gcl_gprof ansi_gcl ansi_gcl_gprof) $(addprefix unixport/saved_,gcl ansi_gcl gcl_gprof ansi_gcl_gprof):\ unixport/saved_%: unixport/raw_% # rebuild these only when out of date unixport/saved_%: | unixport/raw_% unixport/gcl_cmpnopt_%.lsp \ unixport/libboot.so unixport/init_raw.lsp rm -rf sb_$* # FIXME sandbox ugliness for parallel builds mkdir sb_$* cd sb_$* && \ ar x ../unixport/lib$*.a $$(ar t ../unixport/lib$*.a |grep ^gcl_) && \ ln -snf gcl_cmpnopt_$*.lsp ../unixport/gcl_cmpnopt.lsp && \ mkdir h && \ ln -snf ../../h/cmpinclude.h h/ && \ GCL_LSPSYSDIR=../$(srcdir)/unixport/ \ ../unixport/raw_$* $$(dirname $$(pwd))/unixport/ -libdir $$(dirname $$(pwd))/ \ < <(cat ../unixport/init_raw.lsp <(echo "(system:save-system \"../$@\")")) && \ rm -f ../unixport/gcl_cmpnopt.lsp rm -rf sb_$* unixport/raw_%: unixport/lib%.a $(CC) $(AM_LDFLAGS) -rdynamic -Wl,-z,relro $(LDFLAGS) -o $@ $< $(LIBS) #FIXME relro unixport/gcl_cmpnopt_gcl_gprof.lsp unixport/gcl_cmpnopt_ansi_gcl_gprof.lsp:\ unixport/gcl_cmpnopt_%_gprof.lsp: unixport/gcl_cmpnopt_%.lsp ln -snf $$(basename $<) $@ unixport/gcl_cmpnopt_pre_gcl.lsp: # FIXME necessary? touch $@ unixport/gcl_cmpnopt_%.lsp: unixport/lib%.a | unixport/% echo "(mapc (quote load) (directory \"$*/*.hsh\"))" \ "(compiler::dump-inl-hash \"$@\")" | $| $(addprefix unixport/lib,$(addsuffix .a,pre_gcl $(MY_DIRS))): \ unixport/lib%.a: lib/libbase_gcl.a $(LIBGPROF) unixport/sys_%.o $(addprefix unixport/lib,$(addsuffix .a,gcl_gprof ansi_gcl_gprof)): \ unixport/lib%.a:lib/libbase_gcl_gprof.a unixport/sys_%.o .POSIX: # parallel job ordering E0=s typep nr deftype cmptype cmpinline cmpflet L0=c listlib seqlib type evalmacros E0_OBJS=$(addprefix gcl_,$(addsuffix .o,$(E0))) M0_OBJS=$(filter-out $(E0_OBJS) $(L0_OBJS),$(L_OBJS)) L0_OBJS=$(addprefix gcl_,$(addsuffix .o,$(L0))) unixport/libgcl0.a: $(addprefix gcl0/,$(E0_OBJS) $(M0_OBJS) $(L0_OBJS)) $(addprefix unixport/lib,$(addsuffix .a,gcl1 gcl2 gcl3 gcl)):\ unixport/lib%.a: $(addprefix %/,$(L_OBJS)) unixport/libmod_gcl0.a unixport/libmod_gcl.a:\ unixport/lib%.a: $(addprefix %/,$(MOD_OBJS)) $(L_FOBJS) $(X_LIB) unixport/libgcl.a unixport/libmod_gcl.a: unixport/lib%.a: %/recompile unixport/libpcl_gcl.a: $(PCL_FOBJS) unixport/libansi_gcl.a: $(ANSI_FOBJS) unixport/libgcl_gprof.a: $(patsubst %.o,%.go,$(L_FOBJS)) unixport/libansi_gcl_gprof.a: $(patsubst %.o,%.go,$(ANSI_FOBJS)) unixport/lib%.a: | xbin/ar_merge $| $(ARFLAGS)s $@ $^ %/recompile: | unixport/% $| -batch \ -eval "(let ((si::*do-recomp-output-dir* \"$(@D)\")) (si::do-recomp t))" \ -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\")" touch $@ unixport/sys_%.o: unixport/sys_init.c i=$$(echo $* | sed 's,[0-9],,g' | sed 's,_gprof,,g'); \ $(CC) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -D $$i -D FLAVOR="$$i" -c $< -o $@ unixport/gcl0: | unixport/saved_pre_gcl unixport/gcl1: | unixport/saved_gcl0 unixport/gcl2: | unixport/saved_gcl1 unixport/gcl3: | unixport/saved_gcl2 unixport/gcl: | unixport/saved_gcl3 unixport/mod_gcl0: | unixport/saved_gcl unixport/mod_gcl: | unixport/saved_mod_gcl0 unixport/pcl_gcl: | unixport/saved_mod_gcl unixport/ansi_gcl: | unixport/saved_pcl_gcl $(addprefix unixport/,gcl0 gcl1): unixport/% : unixport/cinit.lisp | % $(word 2,$|) < <(cat $< <(echo "(system:save-system \"$@\")")) $(addprefix unixport/,gcl2 gcl3 gcl mod_gcl): unixport/% : | % ln -snf $$(basename $(word 2,$|)) $@ unixport/mod_gcl0: xgcl-2/sysdef.lisp | mod_gcl0 rm -f $(@D)/in [ "$(X_OBJS)" = "" ] || echo "(load \"$<\")" >$(@D)/in echo "(compiler::cdebug)(si::save-system \"$@\")" >>$(@D)/in $(word 2,$|) <$(@D)/in rm $(@D)/in cp gcl/all.hsh $(word 1,$|) #FIXME unixport/pcl_gcl: clcs/package.lisp cmpnew/gcl_collectfn.lsp pcl/defsys.lisp | pcl_gcl echo "(let ((*features* (remove :kcl *features*))) (mapc (quote load) (list $(patsubst %,\"%\",$^))))" \ "(compiler::cdebug)" \ "(setq compiler::*assert-ftype-proclamations* t)" \ "(setq pcl::*pcl-directory* (cons \"$$(dirname $(word 3,$^))/\" \"$(@F)/\"))" \ "(print pcl::*pcl-directory*)" \ "(setq pcl::*default-pathname-extensions* (cons \"lisp\" \"o\"))" \ "(setq pcl::*pathname-extensions* (cons \"lisp\" \"o\"))" \ "(si::save-system \"$@\")" | $(word 2,$|) unixport/ansi_gcl: clcs/package.lisp clcs/gcl_clcs_precom.lisp \ clcs/gcl_clcs_conditions.lisp clcs/gcl_clcs_condition_definitions.lisp \ | ansi_gcl echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \ "(compiler::cdebug)" \ "(si::save-system \"$@\")" | $(word 2,$|) cp pcl_gcl/all.hsh $(word 1,$|) #FIXME $(addprefix gcl0/,$(LL_OBJS)): gcl0/%.o : lsp/%.lsp $(addprefix gcl0/,$(LC_OBJS)): gcl0/%.o : cmpnew/%.lsp gcl0/%.o: | unixport/gcl0 $| -eval "(mapc 'load (directory \"$(@D)/*.done\"))" -compile $< -o $@ [ "$*" = "gcl_c" ] || [ "$*" = "gcl_listlib" ] || \ ln -f $@ $$(echo $@ |sed 's,\.o,\.done,g') #FIXME directory link $(addprefix gcl1/,$(LL_OBJS)): gcl1/%.o : lsp/%.lsp $(addprefix gcl1/,$(LC_OBJS)): gcl1/%.o : cmpnew/%.lsp gcl1/%.o: | unixport/gcl1 $| -eval "(mapc 'load (directory \"$(@D)/*.done\"))" \ -eval "(setq compiler::*dump-inl-hash* t)" \ -compile $< -o $@ [ "$*" = "gcl_sym" ] || ln -f $@ $$(echo $@ |sed 's,\.o,\.done,g') # FIXME listlib must come before sym $(addprefix gcl2/,$(LL_OBJS)): gcl2/%.o : lsp/%.lsp $(addprefix gcl2/,$(LC_OBJS)): gcl2/%.o : cmpnew/%.lsp gcl2/%.o: | unixport/gcl2 $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ $(addprefix gcl3/,$(LL_OBJS)): gcl3/%.o : lsp/%.lsp $(addprefix gcl3/,$(LC_OBJS)): gcl3/%.o : cmpnew/%.lsp gcl3/%.o: | unixport/gcl3 $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ gcl/%.o: gcl3/%.o | gcl cp $(patsubst %.o,%.*,$<) $(@D) $(addprefix mod_gcl0/,$(MMOD_OBJS)): mod_gcl0/%.o : mod/%.lsp $(addprefix mod_gcl0/,$(X_OBJS)): mod_gcl0/%.o : xgcl-2/%.lsp mod_gcl0/%.o: | unixport/mod_gcl0 $| -eval "(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ mod_gcl/%.o: mod_gcl0/%.o | unixport/mod_gcl cp $(patsubst %.o,%.*,$<) $(@D) %/c1: | unixport/% echo "(pcl::compile-pcl)" | $| touch $@ %/sys-package.lisp: %/c1 | unixport/% echo "(pcl::load-pcl)" \ "(compiler::get-packages-ansi \ (quote (:walker :iterate :pcl :slot-accessor-name)) \ \"$@\")" | $| %/sys-proclaim.lisp: %/c1 | unixport/% echo "(pcl::load-pcl)" \ "(si::do-recomp2 \ \"$@\" \ (mapcar (quote namestring) \ (directory \ (merge-pathnames \ \"*.*p\" \ (make-pathname \ :directory (pathname-directory \ (si::file (quote pcl::renew-sys-files))))))))" | $| %/p1.lisp: | unixport/% echo "(in-package :si)" \ "(export (quote %structure-name))" \ "(export (quote %compiled-function-name))" \ "(export (quote %set-compiled-function-name))" \ "(in-package :pcl)" >$@ %/all.hs1 : %/sys-package.lisp %/p1.lisp %/sys-proclaim.lisp | unixport/% rm -rf $*/*.o echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \ "(pcl::compile-pcl)" \ "(compiler::dump-inl-hash \"$@\")" | $| %/all.hsh: %/p1.lisp %/all.hs1 | unixport/pcl_gcl echo "pcl conflicts:" echo "(pcl::load-pcl)(si::all-conflicts)" | $| cat $^ > $@ $(addprefix pcl_gcl/,$(PCL_OBJS)): pcl_gcl/all.hsh touch $@ ansi_gcl/%.o: clcs/%.lisp | unixport/ansi_gcl $| -eval "(setq compiler::*dump-inl-hash* t)" -compile $< -o $@ %.go: %.o mod_gcl/recompile #FIXME parallel $(CC) $(AM_CPPFLAGS) -I $(>$@ CMPINCLUDE_FILES=h/cmpincl1.h h/gclincl.h h/compbas.h h/type.h h/mgmp.h \ h/lu.h h/globals.h h/vs.h h/bds.h h/frame.h h/lex.h \ h/mstdint.h h/compbas2.h h/compprotos.h h/immnum.h CLEANFILES+=h/cmpinclude.h h/mstdint.h h/cmpincludea.h h/mcompdefs.h h/mstdint.h: echo "#include " | $(CC) -E -I./h/ - | $(AWK) '/fsid/ {next} {print}' >$@ h/mcompdefs.h: h/compdefs.h h/new_decl.h $(AWK) 'BEGIN {print "#include \"include.h\"";print "#include \"page.h\"";print "---"} {a=$$1;gsub("\\.\\.\\.","",a);print "\"#define " $$1 "\" " a}' $< |\ $(CC) $(AM_CPPFLAGS) $(AM_CFLAGS) -E -P -I./h/ - |\ $(AWK) '/^\-\-\-$$/ {i=1;next} {if (!i) next} {gsub("\"","");print}' >$@ h/cmpincludea.h: $(filter-out gclincl.h,$(CMPINCLUDE_FILES)) | h/gclincl.h # FIXME! cat $< $| $(filter-out $<,$^) | \ $(CC) $(AM_CPPFLAGS) $(AM_CFLAGS) -E -I./h/ - | \ $(AWK) '/^# |^$$|^#pragma/ {next}{print}' > $@ h/cmpinclude.h: h/mcompdefs.h h/cmpincludea.h h/cmponly_last.h @cat $^ >new_$(@F) @([ -e $@ ] && cmp new_$(@F) $@) || mv -v new_$(@F) $@ @rm -f new_$(@F) h/new_decl.h: $(INI_FILES) echo '#include "make-decl.h"' > foo.c cat $^ |sed 's,DEFBFUN,DEFUN,g' >> foo.c $(CPP) $(AM_CPPFLAGS) $(CPPFLAGS) foo.c | sed -n -e '/#/d' -e '/DO_/d' -e '/[a-zA-Z;]/p' > $@ rm -f foo.c o/boot.h: %.h: %.ini echo '#include "make-init.h"' > $@ echo 'void gcl_init_boot(void){' >> $@ cat $< >> $@ echo '}' >> $@ CLEANFILES+=unixport/libboot.so unixport/libboot.so: o/boot.c o/boot.h $(CC) $(AM_CPPFLAGS) -Io $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \ -fPIC -shared -Wl,-undefined -Wl,dynamic_lookup $< -o $@ o/boot.ini: CPPFLAGS += -DNO_BOOT_H # parallel builds can only have one target accessing an intermediate file # solved with BUILT_SOURCES o/%.ini: o/%.c | o/grab_defs @$(CPP) $(AM_CPPFLAGS) -DINICOMP -DNO_DEFUN $(CPPFLAGS) $< | $| > new_$(@F) @([ -e $@ ] && cmp new_$(@F) $@) || mv -v new_$(@F) $@ @rm -f new_$(@F) o/new_init.c: $(INI_FILES) echo '#include "make-init.h"' > $@ echo 'void NewInit(void){' >> $@ cat $^ >> $@ echo '}' >> $@ ! cat $@ | awk -F, '/DEFUN/ {print $$1,$$2}' | grep -v object || (rm $@ && false) sb_ansi-tests/test_results: ansi-tests | unixport/saved_ansi_gcl [ -d $(@D) ] || (mkdir $(@D) && cp $$(@D)/tmp cat $^ >>$(@D)/tmp paste $(@D)/tmp $| | \ $(AWK) '{if (n++) \ printf("%-10.10s %15.3f %15.3f %15.3f %15.3f %15.3f\n",$$1,$$2,$$4,$$6,$$8,$$10); else \ printf("%-10.10s %15.15s %15.15s %15.15s %15.15s %15.15s\n",$$1,$$2,$$4,$$7,$$10,$$13);}' \ >$@ cat $@ sb_bench: mkdir $@ sb_bench/fread.tim: sb_bench/fprint.tim sb_bench/%.tim: bench/%.cl | unixport/saved_ansi_gcl sb_bench echo "(load \"$($@ chmod a+x $@ man/man1/gcl%.1: man/man1/gcl.1 sed -e 's,\(\b\)gcl\(\b\),\1gcl$*\2,g' $< > $@ info/gcl%-dwdoc.texi: info/gcl-dwdoc.texi # FIXME one rule sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ info/gcl%-si.texi: info/gcl-si.texi sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ info/gcl%-tk.texi: info/gcl-tk.texi sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ info/gcl%.texi: info/gcl.texi sed -e 's,gcl\([:.-]\),gcl$*\1,g' $< >$@ %.info: %.texi | xbin/mktmp # FIXME parallel ugliness i=$$($| $@);ln -f $< $$i;$(MAKEINFO) $$i --output $@;rm -f $$i %.pdf: %.dvi | xbin/mktmp i=$$($| $@);j=$$i.$$(echo $< | sed 's,.*\.,,g');ln -f $< $$j;\ dvipdfm $$j -o $@ && rm -f $$i* %.dvi: %.texi | xbin/mktmp i=$$($| $@);j=$$i.$$(echo $< | sed 's,.*\.,,g');ln -f $< $$j;\ TEXINPUTS=$(srcdir):$$TEXINPUTS \ tex -output-directory=$(@D) $$j|tail && mv $$i.dvi $@ && rm -f $$i* %.html: %.texi | xbin/mktmp mkdir -p $@ i=$$($| $@);ln -f $< $$i;$(MAKEINFO) --html $$i --output $@;rm -f $$i # end package extension install-all: install install-dvi install-pdf install-html clean_%: rm -rf $* $(addprefix unixport/,$* lib$*.a saved_$* sys_$*.o gcl_cmpnopt_$*.lsp) clean-local: $(addprefix clean_,pre_gcl $(MY_DIRS) gcl_gprof ansi_gcl_gprof) rm -rf sb_ansi-tests sb_cmpnew sb_bench distclean-local: rm -rf gcl.script unixport/gcl.script #FIXME rm -rf h/config.h #FIXME AM_ETAGSFLAGS=--regex='/[ \n\t\#\.`]*(defun[ \n\t]+\([^ \n\t]+\)/' \ --regex='/[ \n\t\#\.`]*(defmfun[ \n\t]+"\([^ \n\t"]+\)"[ \n\t]*)/\1/' \ --regex='/[ \n\t\#\.`]*(defmfun[ \n\t]+"[^ \n\t"]+"[ \n\t]+\([^ \n\t]+\)/\1/' TAGS_FILES=lsp/*.lsp cmpnew/*.lsp mod/*.lsp pcl/*sp clcs/*sp xgcl-2/*p gcl-2.7.1/PaxHeaders/ansi-tests0000644000000000000000000000013214776006046013373 xustar0030 mtime=1744309286.150034344 30 atime=1744351538.814879383 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/0000755000175000017500000000000014776006046013046 5ustar00cammcammgcl-2.7.1/ansi-tests/PaxHeaders/print-symbols.lsp0000644000000000000000000000013014542551763017012 xustar0030 mtime=1703597043.016022451 29 atime=1744294960.22578801 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-symbols.lsp0000644000175000017500000005275014542551763016423 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 6 11:47:55 2004 ;;;; Contains: Tests of symbol printing (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Symbol printing when escaping is off (defun princ.symbol.fn (sym case *print-case* expected) (setf (readtable-case *readtable*) case) (let ((str (with-output-to-string (s) (princ sym s)))) (or (equalt str expected) (list str expected)))) (defun prin1.symbol.fn (sym case *print-case* expected) (setf (readtable-case *readtable*) case) (let ((str (with-output-to-string (s) (prin1 sym s)))) (or (and (member str expected :test #'string=) t) (list str expected)))) (deftest print.symbol.1 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|XYZ| :upcase :upcase "XYZ") (%p '|XYZ| :upcase :downcase "xyz") (%p '|XYZ| :upcase :capitalize "Xyz") (%p '|XYZ| :downcase :upcase "XYZ") (%p '|XYZ| :downcase :downcase "XYZ") (%p '|XYZ| :downcase :capitalize "XYZ") (%p '|XYZ| :preserve :upcase "XYZ") (%p '|XYZ| :preserve :downcase "XYZ") (%p '|XYZ| :preserve :capitalize "XYZ") (%p '|XYZ| :invert :upcase "xyz") (%p '|XYZ| :invert :downcase "xyz") (%p '|XYZ| :invert :capitalize "xyz"))))) t t t t t t t t t t t t) (deftest print.symbol.2 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|xyz| :upcase :upcase "xyz") (%p '|xyz| :upcase :downcase "xyz") (%p '|xyz| :upcase :capitalize "xyz") (%p '|xyz| :downcase :upcase "XYZ") (%p '|xyz| :downcase :downcase "xyz") (%p '|xyz| :downcase :capitalize "Xyz") (%p '|xyz| :preserve :upcase "xyz") (%p '|xyz| :preserve :downcase "xyz") (%p '|xyz| :preserve :capitalize "xyz") (%p '|xyz| :invert :upcase "XYZ") (%p '|xyz| :invert :downcase "XYZ") (%p '|xyz| :invert :capitalize "XYZ"))))) t t t t t t t t t t t t) (deftest print.symbol.3 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|Xyz| :upcase :upcase "Xyz") (%p '|Xyz| :upcase :downcase "xyz") (%p '|Xyz| :upcase :capitalize "Xyz") (%p '|Xyz| :downcase :upcase "XYZ") (%p '|Xyz| :downcase :downcase "Xyz") (%p '|Xyz| :downcase :capitalize "Xyz") (%p '|Xyz| :preserve :upcase "Xyz") (%p '|Xyz| :preserve :downcase "Xyz") (%p '|Xyz| :preserve :capitalize "Xyz") (%p '|Xyz| :invert :upcase "Xyz") (%p '|Xyz| :invert :downcase "Xyz") (%p '|Xyz| :invert :capitalize "Xyz"))))) t t t t t t t t t t t t) (deftest print.symbol.4 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|xYZ| :upcase :upcase "xYZ") (%p '|xYZ| :upcase :downcase "xyz") (%p '|xYZ| :upcase :capitalize "xyz") (%p '|xYZ| :downcase :upcase "XYZ") (%p '|xYZ| :downcase :downcase "xYZ") (%p '|xYZ| :downcase :capitalize "XYZ") (%p '|xYZ| :preserve :upcase "xYZ") (%p '|xYZ| :preserve :downcase "xYZ") (%p '|xYZ| :preserve :capitalize "xYZ") (%p '|xYZ| :invert :upcase "xYZ") (%p '|xYZ| :invert :downcase "xYZ") (%p '|xYZ| :invert :capitalize "xYZ"))))) t t t t t t t t t t t t) (deftest print.symbol.5 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X1Z| :upcase :upcase "X1Z") (%p '|X1Z| :upcase :downcase "x1z") (%p '|X1Z| :upcase :capitalize "X1z") (%p '|X1Z| :downcase :upcase "X1Z") (%p '|X1Z| :downcase :downcase "X1Z") (%p '|X1Z| :downcase :capitalize "X1Z") (%p '|X1Z| :preserve :upcase "X1Z") (%p '|X1Z| :preserve :downcase "X1Z") (%p '|X1Z| :preserve :capitalize "X1Z") (%p '|X1Z| :invert :upcase "x1z") (%p '|X1Z| :invert :downcase "x1z") (%p '|X1Z| :invert :capitalize "x1z"))))) t t t t t t t t t t t t) (deftest print.symbol.6 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x1z| :upcase :upcase "x1z") (%p '|x1z| :upcase :downcase "x1z") (%p '|x1z| :upcase :capitalize "x1z") (%p '|x1z| :downcase :upcase "X1Z") (%p '|x1z| :downcase :downcase "x1z") (%p '|x1z| :downcase :capitalize "X1z") (%p '|x1z| :preserve :upcase "x1z") (%p '|x1z| :preserve :downcase "x1z") (%p '|x1z| :preserve :capitalize "x1z") (%p '|x1z| :invert :upcase "X1Z") (%p '|x1z| :invert :downcase "X1Z") (%p '|x1z| :invert :capitalize "X1Z"))))) t t t t t t t t t t t t) (deftest print.symbol.7 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X1z| :upcase :upcase "X1z") (%p '|X1z| :upcase :downcase "x1z") (%p '|X1z| :upcase :capitalize "X1z") (%p '|X1z| :downcase :upcase "X1Z") (%p '|X1z| :downcase :downcase "X1z") (%p '|X1z| :downcase :capitalize "X1z") (%p '|X1z| :preserve :upcase "X1z") (%p '|X1z| :preserve :downcase "X1z") (%p '|X1z| :preserve :capitalize "X1z") (%p '|X1z| :invert :upcase "X1z") (%p '|X1z| :invert :downcase "X1z") (%p '|X1z| :invert :capitalize "X1z"))))) t t t t t t t t t t t t) (deftest print.symbol.8 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x1Z| :upcase :upcase "x1Z") (%p '|x1Z| :upcase :downcase "x1z") (%p '|x1Z| :upcase :capitalize "x1z") (%p '|x1Z| :downcase :upcase "X1Z") (%p '|x1Z| :downcase :downcase "x1Z") (%p '|x1Z| :downcase :capitalize "X1Z") (%p '|x1Z| :preserve :upcase "x1Z") (%p '|x1Z| :preserve :downcase "x1Z") (%p '|x1Z| :preserve :capitalize "x1Z") (%p '|x1Z| :invert :upcase "x1Z") (%p '|x1Z| :invert :downcase "x1Z") (%p '|x1Z| :invert :capitalize "x1Z"))))) t t t t t t t t t t t t) (deftest print.symbol.9 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X Z| :upcase :upcase "X Z") (%p '|X Z| :upcase :downcase "x z") (%p '|X Z| :upcase :capitalize "X Z") (%p '|X Z| :downcase :upcase "X Z") (%p '|X Z| :downcase :downcase "X Z") (%p '|X Z| :downcase :capitalize "X Z") (%p '|X Z| :preserve :upcase "X Z") (%p '|X Z| :preserve :downcase "X Z") (%p '|X Z| :preserve :capitalize "X Z") (%p '|X Z| :invert :upcase "x z") (%p '|X Z| :invert :downcase "x z") (%p '|X Z| :invert :capitalize "x z"))))) t t t t t t t t t t t t) (deftest print.symbol.10 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x z| :upcase :upcase "x z") (%p '|x z| :upcase :downcase "x z") (%p '|x z| :upcase :capitalize "x z") (%p '|x z| :downcase :upcase "X Z") (%p '|x z| :downcase :downcase "x z") (%p '|x z| :downcase :capitalize "X Z") (%p '|x z| :preserve :upcase "x z") (%p '|x z| :preserve :downcase "x z") (%p '|x z| :preserve :capitalize "x z") (%p '|x z| :invert :upcase "X Z") (%p '|x z| :invert :downcase "X Z") (%p '|x z| :invert :capitalize "X Z"))))) t t t t t t t t t t t t) (deftest print.symbol.11 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|X z| :upcase :upcase "X z") (%p '|X z| :upcase :downcase "x z") (%p '|X z| :upcase :capitalize "X z") (%p '|X z| :downcase :upcase "X Z") (%p '|X z| :downcase :downcase "X z") (%p '|X z| :downcase :capitalize "X Z") (%p '|X z| :preserve :upcase "X z") (%p '|X z| :preserve :downcase "X z") (%p '|X z| :preserve :capitalize "X z") (%p '|X z| :invert :upcase "X z") (%p '|X z| :invert :downcase "X z") (%p '|X z| :invert :capitalize "X z"))))) t t t t t t t t t t t t) (deftest print.symbol.12 (with-standard-io-syntax (let ((*print-readably* nil) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values (%p '|x Z| :upcase :upcase "x Z") (%p '|x Z| :upcase :downcase "x z") (%p '|x Z| :upcase :capitalize "x Z") (%p '|x Z| :downcase :upcase "X Z") (%p '|x Z| :downcase :downcase "x Z") (%p '|x Z| :downcase :capitalize "X Z") (%p '|x Z| :preserve :upcase "x Z") (%p '|x Z| :preserve :downcase "x Z") (%p '|x Z| :preserve :capitalize "x Z") (%p '|x Z| :invert :upcase "x Z") (%p '|x Z| :invert :downcase "x Z") (%p '|x Z| :invert :capitalize "x Z"))))) t t t t t t t t t t t t) ;;; Randomized printing tests (deftest print.symbol.random.1 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name))) (trim-list (loop for c across +standard-chars+ nconc (loop repeat 50 nconc (randomly-check-readability (intern (string c))))) 10)) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.random.2 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name)) (count 0)) (trim-list (loop for c1 = (random-from-seq +standard-chars+) for c2 = (random-from-seq +standard-chars+) for string = (concatenate 'string (string c1) (string c2)) for result = (randomly-check-readability (intern string)) for tries from 1 to 10000 when result do (incf count) nconc result when (= count 10) collect (format nil "... ~A out of ~A, stopping test ..." count tries) while (< count 10)) 10)) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.random.3 (let ((count 0) (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) ;; Find all symbols that have a home package, put into array SYMBOLS (do-all-symbols (s) (when (symbol-package s) (vector-push-extend s symbols (array-dimension symbols 0)))) (loop for i = (random (fill-pointer symbols)) for s = (aref symbols i) for tries from 1 to 10000 for problem = (randomly-check-readability s) nconc problem when problem do (incf count) while (< count 10))) nil) (deftest print.symbol.random.4 (let ((count 0) (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) ;; Find all symbols that have a home package, put into array SYMBOLS (do-all-symbols (s) (when (symbol-package s) (vector-push-extend s symbols (array-dimension symbols 0)))) (loop for i = (random (fill-pointer symbols)) for s = (aref symbols i) for tries from 1 to 10000 for problem = (let ((*package* (symbol-package s))) (randomly-check-readability s)) nconc problem when problem do (incf count) while (< count 10))) nil) ;;;; Tests of printing with escaping enabled (deftest prin1.symbol.1 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values (%p '|X| :upcase :upcase '("x" "X" "\\X" "|X|")) (%p '|X| :upcase :downcase '("x" "X" "\\X" "|X|")) (%p '|X| :upcase :capitalize '("x" "X" "\\X" "|X|")) (%p '|X| :downcase :upcase '("\\X" "|X|")) (%p '|X| :downcase :downcase '("\\X" "|X|")) (%p '|X| :downcase :capitalize '("\\X" "|X|")) (%p '|X| :preserve :upcase '("X" "\\X" "|X|")) (%p '|X| :preserve :downcase '("X" "\\X" "|X|")) (%p '|X| :preserve :capitalize '("X" "\\X" "|X|")) (%p '|X| :invert :upcase '("x" "\\X" "|X|")) (%p '|X| :invert :downcase '("x" "\\X" "|X|")) (%p '|X| :invert :capitalize '("x" "\\X" "|X|")) )))) t t t t t t t t t t t t) (deftest prin1.symbol.2 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values (%p '|x| :upcase :upcase '("\\x" "|x|")) (%p '|x| :upcase :downcase '("\\x" "|x|")) (%p '|x| :upcase :capitalize '("\\x" "|x|")) (%p '|x| :downcase :upcase '("x" "X" "\\x" "|x|")) (%p '|x| :downcase :downcase '("x" "X" "\\x" "|x|")) (%p '|x| :downcase :capitalize '("x" "X" "\\x" "|x|")) (%p '|x| :preserve :upcase '("x" "\\x" "|x|")) (%p '|x| :preserve :downcase '("x" "\\x" "|x|")) (%p '|x| :preserve :capitalize '("x" "\\x" "|x|")) (%p '|x| :invert :upcase '("X" "\\x" "|x|")) (%p '|x| :invert :downcase '("X" "\\x" "|x|")) (%p '|x| :invert :capitalize '("X" "\\x" "|x|")) )))) t t t t t t t t t t t t) (deftest prin1.symbol.3 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values (%p '|1| :upcase :upcase '("\\1" "|1|")) (%p '|1| :upcase :downcase '("\\1" "|1|")) (%p '|1| :upcase :capitalize '("\\1" "|1|")) (%p '|1| :downcase :upcase '("1" "\\1" "|1|")) (%p '|1| :downcase :downcase '("1" "\\1" "|1|")) (%p '|1| :downcase :capitalize '("1" "\\1" "|1|")) (%p '|1| :preserve :upcase '("1" "\\1" "|1|")) (%p '|1| :preserve :downcase '("1" "\\1" "|1|")) (%p '|1| :preserve :capitalize '("1" "\\1" "|1|")) (%p '|1| :invert :upcase '("1" "\\1" "|1|")) (%p '|1| :invert :downcase '("1" "\\1" "|1|")) (%p '|1| :invert :capitalize '("1" "\\1" "|1|")) )))) t t t t t t t t t t t t) ;;; Random symbol printing tests when *print-escape* is true ;;; and *print-readably* is false. ;;; I AM NOT SURE THESE ARE CORRECT, SO THEY ARE COMMENTED OUT FOR NOW -- PFD #| (deftest print.symbol.escaped-random.1 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name)) (result (loop for c across +standard-chars+ for s = (intern (string c)) append (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t))))) (subseq result 0 (min (length result) 10))) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.escaped-random.2 (let ((result (loop for c across +standard-chars+ for s = (make-symbol (string c)) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols))))) (subseq result 0 (min (length result) 10))) nil) (deftest print.symbol.escaped-random.3 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let ((*package* (make-package pkg-name)) (result (loop for i below 256 for c = (code-char i) when c nconc (let ((s (intern (string c)))) (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t)))))) (subseq result 0 (min (length result) 10))) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.escaped-random.4 (let ((result (loop for i below 256 for c = (code-char i) when c nconc (let ((s (make-symbol (string c)))) (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols)))))) (subseq result 0 (min (length result) 10))) nil) (deftest print.symbol.escaped-random.5 (loop for s in *universe* when (and (symbolp s) (symbol-package s) ) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t))) nil) (deftest print.symbol.escaped-random.6 (let ((*package* (find-package "KEYWORD"))) (loop for s in *universe* when (and (symbolp s) (symbol-package s)) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t)))) nil) (deftest print.symbol.escaped-random.7 (loop for s in *universe* when (and (symbolp s) (not (symbol-package s))) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols))) nil) (deftest print.symbol.escaped-random.8 (let ((*package* (find-package "KEYWORD"))) (loop for s in *universe* when (and (symbolp s) (not (symbol-package s))) nconc (loop repeat 50 nconc (randomly-check-readability s :readable nil :escape t :gensym t :test #'similar-uninterned-symbols)))) nil) (deftest print.symbol.escaped.9 (let* ((*package* (find-package "CL-TEST")) (s (intern "()"))) (randomly-check-readability s :readable nil :escape t)) nil) (deftest print.symbol.escaped.10 (let* ((*package* (find-package "KEYWORD")) (s (intern "()"))) (randomly-check-readability s :readable nil :escape t)) nil) |# ;;; Tests of printing package prefixes (deftest print.symbol.prefix.1 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym t :case :upcase :escape t :readably nil))) (if (string= s "#:ABC") t s))) t) (deftest print.symbol.prefix.2 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape nil))) (if (string= s "ABC") t s))) t) (deftest print.symbol.prefix.3 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably t :escape nil))) (if (and (string= (subseq s 0 2) "#:") (string= (symbol-name (read-from-string s)) "ABC")) t s))) t) (deftest print.symbol.prefix.4 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape t))) (if (string= s "ABC") t s))) t) (deftest print.symbol.prefix.5 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (let ((pkg (make-package pkg-name))) (multiple-value-prog1 (let* ((*package* (find-package "CL-TEST")) (s (intern "ABC" pkg))) (values (write-to-string s :case :upcase :readably nil :escape t) (let ((*package* pkg)) (write-to-string s :case :upcase :readably nil :escape t)) (let ((*package* pkg)) (write-to-string s :case :downcase :readably nil :escape t)) )) ;; (delete-package pkg) )))) "PRINT-SYMBOL-TEST-PACKAGE::ABC" "ABC" "abc") (deftest print.symbol.prefix.6 (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (let ((pkg (make-package pkg-name))) (prog1 (with-standard-io-syntax (let* ((*package* pkg) (s (intern "X" pkg))) (write-to-string s :case :upcase :readably nil)) ;; (delete-package pkg) )))) "X") (deftest print.symbol.prefix.6a (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string 'x :case :upcase :readably nil))) "X") (deftest print.symbol.prefix.6b (funcall (compile nil '(lambda () (declare (optimize speed (safety 0))) (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string 'cl-test::x :case :upcase :readably nil)))))) "X") (deftest print.symbol.prefix.7 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (when (find-package pkg-name2) (delete-package pkg-name2)) (prog1 (let* ((pkg (make-package pkg-name)) (pkg2 (make-package pkg-name2)) (s (intern "ABC" pkg))) (import s pkg2) (let ((*package* pkg2)) (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) "ABC") (deftest print.symbol.prefix.8 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (when (find-package pkg-name2) (delete-package pkg-name2)) (prog1 (let* ((pkg (make-package pkg-name)) (pkg2 (make-package pkg-name2)) (s (intern "ABC" pkg2))) (import s pkg) (delete-package pkg2) (let ((*package* pkg)) (write-to-string s :case :upcase :gensym t :readably nil :escape t))) ;; (delete-package pkg) ))) "#:ABC") (deftest print.symbol.prefix.9 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let* ((pkg (make-package pkg-name)) (s (intern "ABC" pkg))) (export s pkg) (let ((*package* (find-package "CL-TEST"))) (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) "PRINT-SYMBOL-TEST-PACKAGE:ABC") (deftest print.symbol.prefix.10 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (prog1 (let* ((pkg (make-package pkg-name)) (s :|X|)) (import s pkg) (let ((*package* pkg)) (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) ":X") gcl-2.7.1/ansi-tests/PaxHeaders/rplaca.lsp0000644000000000000000000000013114542551763015433 xustar0030 mtime=1703597043.020022457 29 atime=1744294960.22578801 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rplaca.lsp0000644000175000017500000000174214542551763015036 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:29:43 2003 ;;;; Contains: Tests of RPLACA (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;; rplaca on a non-cons is a type error (deftest rplaca.error.1 (check-type-error #'(lambda (x) (rplaca x 1)) #'consp) nil) (deftest rplaca.error.2 (signals-error (rplaca) program-error) t) (deftest rplaca.error.3 (signals-error (rplaca (cons 'a 'b)) program-error) t) (deftest rplaca.error.4 (signals-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage) program-error) t) (deftest rplaca.error.6 (signals-error (locally (rplaca 'a 1) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/unuse-package.lsp0000644000000000000000000000013114542551763016721 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.233788046 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/unuse-package.lsp0000644000175000017500000002173414542551763016327 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:48 1998 ;;;; Contains: Tests of UNUSE-PACKAGE (in-package :cl-test) (compile-and-load "package-aux.lsp") (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) ;;; Specialized sequences (defmacro def-unuse-package-test (test-name &key (user "H") (used "G")) `(deftest ,test-name (let ((user-name ,user) (used-name ,used)) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) (puser (make-package user-name :use (list used-name)))) (prog1 (and (equal (package-use-list puser) (list pused)) (equal (package-used-by-list pused) (list puser)) (unuse-package (list used-name) user-name) (equal (package-use-list puser) nil) (null (package-used-by-list pused))) (safely-delete-package user-name) (safely-delete-package used-name)))) t)) ;;; Specialized user package designator (def-unuse-package-test unuse-package.10 :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unuse-package-test unuse-package.11 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unuse-package-test unuse-package.12 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unuse-package-test unuse-package.13 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unuse-package-test unuse-package.14 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unuse-package-test unuse-package.15 :user (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unuse-package-test unuse-package.16 :user (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Specialed used package designator (def-unuse-package-test unuse-package.17 :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unuse-package-test unuse-package.18 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unuse-package-test unuse-package.19 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unuse-package-test unuse-package.20 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unuse-package-test unuse-package.21 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unuse-package-test unuse-package.22 :used (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unuse-package-test unuse-package.23 :used (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Error tests (deftest unuse-package.error.1 (signals-error (unuse-package) program-error) t) (deftest unuse-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use '("UPE2")) (signals-error (unuse-package "UPE2" "UPE2A" nil) program-error)) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-sequences.lsp0000644000000000000000000000013214772071556017104 xustar0030 mtime=1743287150.474906292 30 atime=1744294960.237788063 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-sequences.lsp0000644000175000017500000000173514772071556016510 0ustar00cammcamm;;; 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 "stable-sort.lsp") (load "length.lsp") (load "find.lsp") (load "find-if.lsp") (load "find-if-not.lsp") (load "position.lsp") (load "position-if.lsp") (load "position-if-not.lsp") (load "search-list.lsp") (load "search-vector.lsp") (load "search-bitvector.lsp") (load "search-string.lsp") (load "mismatch.lsp") (load "replace.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") (load "remove.lsp") ;; also related funs (load "remove-duplicates.lsp") ;; also delete-duplicates gcl-2.7.1/ansi-tests/PaxHeaders/pprint-logical-block.lsp0000644000000000000000000000013114542551763020205 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.253788134 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-logical-block.lsp0000644000175000017500000001752314542551763017614 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 4 07:17:52 2004 ;;;; Contains: Tests of PPRINT-LOGICAL-BLOCK (in-package :cl-test) (deftest pprint-logical-block.1 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil)) (with-open-stream (os (make-string-output-stream)) (values (multiple-value-list (pprint-logical-block (os 1))) (get-output-stream-string os))))) (nil) "1") (deftest pprint-logical-block.2 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil) (val '(1 a (b) (c . d) 1.0s0 2.0f0 -3.0d0 4.0l0 1/2 #(x y z)))) (string=t (with-output-to-string (s) (write val :stream s)) (with-output-to-string (s) (pprint-logical-block (s val) (write val :stream s)))))) t) (deftest pprint-logical-block.3 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil)) (with-output-to-string (*standard-output*) (pprint-logical-block (nil 1))))) "1") (deftest pprint-logical-block.4 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-logical-block (t 1))))))) "1") (deftest pprint-logical-block.5 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(1))) (with-output-to-string (os) (pprint-logical-block (os val) (write (car val) :stream os))))) "1") (deftest pprint-logical-block.6 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(2))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write (car val) :stream os))))) "[2]") (deftest pprint-logical-block.7 :notes (:nil-vectors-are-strings) (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(3))) (with-output-to-string (os) (pprint-logical-block (os val :prefix (make-array '(0) :element-type nil) :suffix (make-array '(0) :element-type nil)) (write (car val) :stream os))))) "3") (deftest pprint-logical-block.8 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(4))) (with-output-to-string (os) (pprint-logical-block (os val :prefix (make-array '(10) :element-type 'character :initial-contents "abcdefghij" :fill-pointer 3) :suffix (make-array '(2) :element-type 'base-char :initial-contents "!?" :adjustable t)) (write (car val) :stream os))))) "abc4!?") (deftest pprint-logical-block.9 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (*print-level* 1) (val '((4)))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "{" :suffix "}") (pprint-logical-block (os (car val) :prefix "[" :suffix "]") (write (caar val) :stream os)))))) "{#}") (deftest pprint-logical-block.10 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (*print-level* 0) (val '(5))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write (car val) :stream os))))) "#") (deftest pprint-logical-block.11 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(6))) (with-output-to-string (os) (pprint-logical-block (os val :per-line-prefix "abcd") (write (car val) :stream os))))) "abcd6") (deftest pprint-logical-block.12 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(a b c))) (with-output-to-string (os) (pprint-logical-block (os val :per-line-prefix "abcd") (write 1 :stream os) (terpri os) (terpri os) (write 2 :stream os) (terpri os) (write 3 :stream os))))) "abcd1 abcd abcd2 abcd3") ;;; Same as pprint-logical-block.10, but *print-pretty* is bound to nil (deftest pprint-logical-block.13 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-level* 0) (val '(5))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write (car val) :stream os))))) "#") ;;; Both :suffix and :per-line-prefix may be supplied (deftest pprint-logical-block.14 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(6))) (with-output-to-string (os) (pprint-logical-block (os val :per-line-prefix "[" :suffix "]") (write (car val) :stream os))))) "[6]") ;;; Declarations are allowed (deftest pprint-logical-block.15 (with-standard-io-syntax (let ((*print-pretty* t) (x 0)) (with-output-to-string (os) (declare (integer x)) (declare (optimize (safety 3)))))) "") ;;; Two conditions that cause :prefix, :suffix to be omitted (deftest pprint-logical-block.16 (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val 9)) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") (write val :stream os))))) "9") (deftest pprint-logical-block.17 (with-standard-io-syntax (let* ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (*print-circle* t) (v1 '(8)) (val (list v1 v1))) (with-output-to-string (os) (pprint-logical-block (os val :prefix "(" :suffix ")") (pprint-logical-block (os (car val) :prefix "(" :suffix ")") (write (caar val) :stream os)) (write-char #\Space os) (pprint-logical-block (os (cadr val) :prefix "(" :suffix ")") (write (caadr val) :stream os)))))) "(#1=(8) #1#)") ;;; Error cases (deftest pprint-logical-block.error.1 (check-type-error #'(lambda (x) (pprint-logical-block (*standard-output* '(1) :prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.1-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-logical-block (*standard-output* '(1) :prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.2 (check-type-error #'(lambda (x) (pprint-logical-block (*standard-output* '(1) :suffix x))) #'stringp) nil) (deftest pprint-logical-block.error.2-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-logical-block (*standard-output* '(1) :suffix x))) #'stringp) nil) (deftest pprint-logical-block.error.3 (check-type-error #'(lambda (x) (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.3-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) #'stringp) nil) (deftest pprint-logical-block.error.4 (signals-error (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(7))) (pprint-logical-block (os val :prefix "" :per-line-prefix "") (write (car val) :stream os)))) error) t) (deftest pprint-logical-block.error.4-unsafe (signals-error (with-standard-io-syntax (let ((*print-pretty* t) (*print-right-margin* 100) (*print-readably* nil) (val '(7))) (pprint-logical-block (os val :prefix "" :per-line-prefix "") (write (car val) :stream os)))) error :safety 0) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-streams.lsp0000644000000000000000000000013214772071556016567 xustar0030 mtime=1743287150.850906655 30 atime=1744294960.253788134 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-streams.lsp0000644000175000017500000000317214772071556016170 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/nil.lsp0000644000000000000000000000013114542551763014753 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.253788134 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nil.lsp0000644000175000017500000000114114542551763014347 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:32:46 2002 ;;;; Contains: Tests for NIL (in-package :cl-test) (deftest nil.1 (check-predicate #'(lambda (x) (not (subtypep (type-of x) nil)))) nil) (deftest nil.2 (check-predicate #'(lambda (x) (subtypep nil (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.7.1/ansi-tests/PaxHeaders/do-external-symbols.lsp0000644000000000000000000000013214542551762020101 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.269788204 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/do-external-symbols.lsp0000644000175000017500000000762014542551762017504 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 18:26:08 2004 ;;;; Contains: Tests of DO-EXTERNAL-SYMBOLS (in-package :cl-test) (compile-and-load "package-aux.lsp") (declaim (optimize (safety 3))) (defun collect-external-symbols (pkg) (remove-duplicates (sort-symbols (let ((all nil)) (do-external-symbols (x pkg all) (push x all)))))) (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-external-symbols works without ;; a return value (and that the default return value is nil) (deftest do-external-symbols.6 (do-external-symbols (s "DS1") (declare (ignore s)) t) nil) ;; Test that do-external-symbols works without ;; a package being specified (deftest do-external-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (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-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))) ;;; Specialized sequence tests (defmacro def-do-external-symbols-test (test-name name-form) `(deftest ,test-name (collect-external-symbols ,name-form) (DS1:A DS1:B))) (def-do-external-symbols-test do-external-symbols.9 (make-array 3 :element-type 'base-char :initial-contents "DS1")) (def-do-external-symbols-test do-external-symbols.10 (make-array 6 :element-type 'base-char :initial-contents "DS1XXX" :fill-pointer 3)) (def-do-external-symbols-test do-external-symbols.11 (make-array 6 :element-type 'character :initial-contents "DS1XXX" :fill-pointer 3)) (def-do-external-symbols-test do-external-symbols.12 (make-array 3 :element-type 'base-char :initial-contents "DS1" :adjustable t)) (def-do-external-symbols-test do-external-symbols.13 (make-array 3 :element-type 'character :initial-contents "DS1" :adjustable t)) (def-do-external-symbols-test do-external-symbols.14 (let* ((etype 'base-char) (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-do-external-symbols-test do-external-symbols.15 (let* ((etype 'character) (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope tests (deftest do-external-symbols.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do-external-symbols (s (return-from done x)) (declare (special x)))))) :good) (deftest do-external-symbols.17 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do-external-symbols (s "CL-TEST" x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do-external-symbols.18 (macrolet ((%m (z) z)) (do-external-symbols (s (expand-in-current-env (%m "CL-TEST")) :good))) :good) (deftest do-external-symbols.19 (macrolet ((%m (z) z)) (do-external-symbols (s "CL-TEST" (expand-in-current-env (%m :good))))) :good) ;;; Error tests (def-macro-test do-external-symbols.error.1 (do-external-symbols (x "CL")))gcl-2.7.1/ansi-tests/PaxHeaders/macroexpand.lsp0000644000000000000000000000013214542551763016473 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.277788239 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/macroexpand.lsp0000644000175000017500000000314514542551763016074 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 13:43:00 2005 ;;;; Contains: Tests of MACROEXPAND (in-package :cl-test) (deftest macroexpand.error.1 (signals-error (macroexpand) program-error) t) (deftest macroexpand.error.2 (signals-error (macroexpand 'x nil nil) program-error) t) ;;; Non-error tests (deftest macroexpand.1 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand x)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand.2 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand x nil)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand.3 (macrolet ((%m (&environment env) `(quote ,(check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand x env)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals)))))))))) (%m)) nil) (deftest macroexpand.4 (macrolet ((%m () ''foo)) (macrolet ((%m2 (&environment env) (macroexpand '(%m) env))) (%m2))) foo) (deftest macroexpand.5 (let ((form (list (gensym))) (i 0)) (values (equalt (macroexpand (progn (incf i) form)) form) i)) t 1) (deftest macroexpand.6 (let ((form (list (gensym))) (i 0) a b) (values (equalt (macroexpand (progn (setf a (incf i)) form) (progn (setf b (incf i)) nil)) form) i a b)) t 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/loop14.lsp0000644000000000000000000000013214542551763015310 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.293788309 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop14.lsp0000644000175000017500000001624014542551763014711 0ustar00cammcamm;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.14.46 (macrolet ((%m (z) z)) (loop for x from 1 to 6 when (expand-in-current-env (%m (evenp x))) collect x)) (2 4 6)) (deftest loop.14.47 (macrolet ((%m (z) z)) (loop for x from 1 to 6 unless (expand-in-current-env (%m (evenp x))) collect x)) (1 3 5)) (deftest loop.14.48 (macrolet ((%m (z) z)) (loop for x from 1 to 6 when (expand-in-current-env (%m t)) sum x)) 21) (deftest loop.14.49 (macrolet ((%m (z) z)) (loop for x from 1 to 10 if (expand-in-current-env (%m (evenp x))) collect x end)) (2 4 6 8 10)) gcl-2.7.1/ansi-tests/PaxHeaders/defclass-02.lsp0000644000000000000000000000013214542551762016174 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.301788344 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defclass-02.lsp0000644000175000017500000003700214542551762015574 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Apr 25 07:16:57 2003 ;;;; Contains: Tests of DEFCLASS with simple inheritance (in-package :cl-test) ;;; (defclass class-0201 () ((a :initform 'x) (b :allocation :instance) (c :reader class-0201-c))) (defclass class-0202 (class-0201) (d (e :initform 'y) (f :allocation :instance))) (deftest class-0201.1 (let ((c (make-instance 'class-0201))) (values (map-slot-boundp* c '(a b c)) (map-slot-exists-p* c '(a b c)) (slot-value c 'a) (map-typep* c (list 'class-0201 'class-0202 (find-class 'class-0201) (find-class 'class-0202))) (class-name (class-of c)) )) (t nil nil) (t t t) x (t nil t nil) class-0201) (deftest class-0202.1 (let ((c (make-instance 'class-0202))) (values (map-slot-boundp* c '(a b c d e f)) (map-slot-value c '(a e)) (map-typep* c (list 'class-0201 'class-0202 (find-class 'class-0201) (find-class 'class-0202))) (class-name (class-of c)) )) (t nil nil nil t nil) (x y) (t t t t) class-0202) ;;; (defclass class-0203 () ((a :allocation :class) (b :allocation :instance))) (defclass class-0204 (class-0203) (c d)) (deftest class-0203.1 (let ((c1 (make-instance 'class-0203)) (c2 (make-instance 'class-0204))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (setf (slot-value c1 'a) 'x) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (slot-value c1 'a) (slot-value c2 'a) (eqt (slot-makunbound c1 'a) c1) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)))) (nil nil) (nil nil nil nil) x (t nil) (t nil nil nil) x x t (nil nil) (nil nil nil nil)) (deftest class-0203.2 (let ((c1 (make-instance 'class-0203)) (c2 (make-instance 'class-0204))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (setf (slot-value c1 'a) 'x) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) (slot-value c1 'a) (slot-value c2 'a) (eqt (slot-makunbound c2 'a) c2) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)))) (nil nil) (nil nil nil nil) x (t nil) (t nil nil nil) x x t (nil nil) (nil nil nil nil)) ;;; (defclass class-0205a () ((a :initform 'x) (b :initform 'y) c)) (defclass class-0205b (class-0205a) ((a :initform 'z) b (c :initform 'w))) (deftest class-0205a.1 (let ((c (make-instance 'class-0205a))) (values (slot-value c 'a) (slot-value c 'b) (slot-boundp c 'c))) x y nil) (deftest class-0205b.1 (let ((c (make-instance 'class-0205b))) (map-slot-value c '(a b c))) (z y w)) ;;; (defclass class-0206a () ((a :allocation :instance) (b :allocation :class))) (defclass class-0206b (class-0206a) ((a :allocation :class) (b :allocation :instance))) (deftest class-0206.1 (let ((c1 (make-instance 'class-0206a)) (c2 (make-instance 'class-0206b))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) (setf (slot-value c1 'a) 'x) (setf (slot-value c1 'b) 'y) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) (map-slot-value c1 '(a b)) (progn (slot-makunbound c1 'a) (slot-makunbound c1 'b) (setf (slot-value c2 'a) 'x)) (setf (slot-value c2 'b) 'y) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) (map-slot-value c2 '(a b)) (progn (slot-makunbound c2 'a) (slot-makunbound c2 'b) nil))) (nil nil) (nil nil) x y (t t) (nil nil) (x y) x y (nil nil) (t t) (x y) nil) ;;; ;;; Show shadowing of slots by :allocation (defclass class-0207a () ((a :allocation :class))) (defclass class-0207b (class-0207a) ((a :allocation :instance))) (defclass class-0207c (class-0207b) ((a :allocation :class))) (deftest class-0207.1 (let ((c1 (make-instance 'class-0207a)) (c2 (make-instance 'class-0207b)) (c3 (make-instance 'class-0207c))) (slot-makunbound c1 'a) (slot-makunbound c2 'a) (slot-makunbound c3 'a) (values (setf (slot-value c1 'a) 'x) (slot-boundp* c1 'a) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (slot-value c1 'a) (setf (slot-value c2 'a) 'y) (slot-boundp* c1 'a) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (slot-value c1 'a) (slot-value c2 'a) (setf (slot-value c3 'a) 'z) (slot-boundp* c1 'a) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (slot-value c1 'a) (slot-value c2 'a) (slot-value c3 'a))) x t nil nil x y t t nil x y z t t t x y z) ;;; ;;; Initforms are inherited even if :allocation changes (defclass class-0208a () ((a :allocation :class :initform 'x))) (defclass class-0208b (class-0208a) ((a :allocation :instance))) (deftest class-0208.1 (values (slot-value (make-instance 'class-0208a) 'a) (slot-value (make-instance 'class-0208b) 'a)) x x) ;;; ;;; That was failing when things were reloaded. ;;; Try a test that redefines it (deftest class-redefinition.1 (let* ((cobj1 (eval '(defclass class-0209a () ((a :allocation :class :initform 'x))))) (cobj2 (eval '(defclass class-0209b (class-0209a) ((a :allocation :instance))))) (cobj3 (eval '(defclass class-0209a () ((a :allocation :class :initform 'x))))) (cobj4 (eval '(defclass class-0209b (class-0209a) ((a :allocation :instance)))))) (values (eqt cobj1 cobj3) (eqt cobj2 cobj4) (class-name cobj1) (class-name cobj2) (slot-value (make-instance 'class-0209a) 'a) (slot-value (make-instance 'class-0209b) 'a))) t t class-0209a class-0209b x x) (deftest class-redefinition.2 (let* ( (cobj1 (eval '(defclass class-0210a () ((a :allocation :class))))) (cobj2 (eval '(defclass class-0210b (class-0210a) ((a :allocation :instance))))) (cobj3 (eval '(defclass class-0210c (class-0210b) ((a :allocation :class))))) (dummy (progn (setf (slot-value (make-instance 'class-0210a) 'a) :bad1) (make-instance 'class-0210b) (make-instance 'class-0210c) nil)) (cobj4 (eval '(defclass class-0210a () ((a :allocation :class))))) (cobj5 (eval '(defclass class-0210b (class-0210a) ((a :allocation :instance))))) (cobj6 (eval '(defclass class-0210c (class-0210b) ((a :allocation :class)))))) (list (eqt cobj1 cobj4) (eqt cobj2 cobj5) (eqt cobj3 cobj6) (class-name cobj1) (class-name cobj2) (class-name cobj3) (let ((c1 (make-instance 'class-0210a)) (c2 (make-instance 'class-0210b)) (c3 (make-instance 'class-0210c))) (slot-makunbound c1 'a) (slot-makunbound c2 'a) (slot-makunbound c3 'a) (list (setf (slot-value c1 'a) 'x) (and (slot-boundp* c1 'a) (slot-value c1 'a)) (slot-boundp* c2 'a) (slot-boundp* c3 'a) (setf (slot-value c2 'a) 'y) (and (slot-boundp* c1 'a) (slot-value c1 'a)) (and (slot-boundp* c2 'a) (slot-value c2 'a)) (slot-boundp* c3 'a) (setf (slot-value c3 'a) 'z) (and (slot-boundp* c1 'a) (slot-value c1 'a)) (and (slot-boundp* c2 'a) (slot-value c2 'a)) (and (slot-boundp* c3 'a) (slot-value c3 'a)))))) (t t t class-0210a class-0210b class-0210c (x x nil nil y x y nil z x y z))) ;;; Same as class-redefinition.1, but reverse the order in which ;;; the classes are redefined. (deftest class-redefinition.3 (let* ((cobj1 (eval '(defclass class-redef-03a () ((a :allocation :class :initform 'x))))) (cobj2 (eval '(defclass class-redef-03b (class-redef-03a) ((a :allocation :instance))))) (cobj4 (eval '(defclass class-redef-03b (class-redef-03a) ((a :allocation :instance))))) (cobj3 (eval '(defclass class-redef-03a () ((a :allocation :class :initform 'x)))))) (values (eqt cobj1 cobj3) (eqt cobj2 cobj4) (class-name cobj1) (class-name cobj2) (slot-value (make-instance 'class-redef-03a) 'a) (slot-value (make-instance 'class-redef-03b) 'a))) t t class-redef-03a class-redef-03b x x) ;;; Initforms are inherited even if :allocation changes (defclass class-0211a () ((a :allocation :instance :initform 'x))) (defclass class-0211b (class-0211a) ((a :allocation :class))) (deftest class-0211.1 (values (slot-value (make-instance 'class-0211a) 'a) (slot-value (make-instance 'class-0211b) 'a)) x x) ;;; ;;; Inheritance of :initargs (defclass class-0212a () ((a :initarg :a1))) (defclass class-0212b (class-0212a) ((a :initarg :a2) (b :initarg :b))) (deftest class-0212.1 (let ((c (make-instance 'class-0212a :a1 'x))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-exists-p c 'b))) t nil x nil) (deftest class-0212.2 (let ((c (make-instance 'class-0212b :a1 'x))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-boundp* c 'b))) t t x nil) (deftest class-0212.3 (let ((c (make-instance 'class-0212b :a2 'x :b 'y))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-value c 'b))) t t x y) (deftest class-0212.4 (let ((c (make-instance 'class-0212b :a1 'z :a2 'x :b 'y))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-value c 'b))) t t z y) (deftest class-0212.5 (let ((c (make-instance 'class-0212b :a2 'x :b 'y :a1 'z))) (values (typep* c 'class-0212a) (typep* c 'class-0212b) (slot-value c 'a) (slot-value c 'b))) t t x y) ;;; (defclass class-0213a () ((a :initarg :a1))) (defclass class-0213b (class-0213a) (b)) (deftest class-0213.1 (let ((c (make-instance 'class-0213a :a1 'x))) (values (typep* c 'class-0213a) (typep* c 'class-0213b) (slot-value c 'a) (slot-exists-p c 'b))) t nil x nil) (deftest class-0213.2 (let ((c (make-instance 'class-0213b :a1 'x))) (values (typep* c 'class-0213a) (typep* c 'class-0213b) (slot-value c 'a) (slot-boundp* c 'b))) t t x nil) ;;; (defclass class-0214a () ((a :initarg :a1 :allocation :class))) (defclass class-0214b (class-0214a) (b)) (deftest class-0214.1 (let ((c (make-instance 'class-0214a :a1 'x))) (values (typep* c 'class-0214a) (typep* c 'class-0214b) (slot-value c 'a) (slot-exists-p c 'b))) t nil x nil) (deftest class-0214.2 (let ((c (make-instance 'class-0214b :a1 'y))) (values (typep* c 'class-0214a) (typep* c 'class-0214b) (slot-value c 'a) (slot-boundp* c 'b))) t t y nil) ;;; (defclass class-0215a () ((a :initarg :a1 :allocation :instance))) (defclass class-0215b (class-0215a) ((a :allocation :class))) (deftest class-0215.1 (let ((c (make-instance 'class-0215a :a1 'x))) (values (typep* c 'class-0215a) (typep* c 'class-0215b) (slot-value c 'a))) t nil x) (deftest class-0215.2 (let ((c (make-instance 'class-0215b :a1 'y))) (values (typep* c 'class-0215a) (typep* c 'class-0215b) (slot-value c 'a))) t t y) ;;; Tests of defaulted initargs (defclass class-0216a () ((a :initarg :a1) (b :initarg :b1))) (defclass class-0216b (class-0216a) () (:default-initargs :a1 'x)) (deftest class-0216.1 (let ((c (make-instance 'class-0216a))) (values (typep* c 'class-0216a) (typep* c 'class-0216b) (slot-boundp c 'a) (slot-boundp c 'b))) t nil nil nil) (deftest class-0216.2 (let ((c (make-instance 'class-0216b))) (values (typep* c 'class-0216a) (typep* c 'class-0216b) (slot-value c 'a) (slot-boundp c 'b))) t t x nil) ;;; (defclass class-0217a () ((a :initarg :a1) (b :initarg :b1) (c :initarg :c1) (d :initarg :d1)) (:default-initargs :a1 10 :b1 20)) (defclass class-0217b (class-0217a) () (:default-initargs :a1 30 :c1 40)) (deftest class-0217.1 (let ((c (make-instance 'class-0217a))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b)))) (t t nil nil) (10 20)) (deftest class-0217.2 (let ((c (make-instance 'class-0217a :a1 'x :c1 'y))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c)))) (t t t nil) (x 20 y)) (deftest class-0217.3 (let ((c (make-instance 'class-0217b))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c)))) (t t t nil) (30 20 40)) (deftest class-0217.4 (let ((c (make-instance 'class-0217b :a1 'x :d1 'y))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c d)))) (t t t t) (x 20 40 y)) ;;; (defclass class-0218a () ((a :initarg :a1)) (:default-initargs :a1 'x)) (defclass class-0218b (class-0218a) ((a :initform 'y))) (deftest class-0218.1 (let ((c (make-instance 'class-0218a))) (slot-value c 'a)) x) (deftest class-0218.2 (let ((c (make-instance 'class-0218b))) (slot-value c 'a)) x) ;;; (declaim (special *class-0219-a-1* *class-0219-a-2*)) (defclass class-0219a () ((a :initarg :a1)) (:default-initargs :a1 (setf *class-0219-a-1* 'x))) (defclass class-0219b () ((a :initarg :a1)) (:default-initargs :a1 (setf *class-0219-a-2* 'y))) (deftest class-0219.1 (let ((*class-0219-a-1* nil)) (values (slot-value (make-instance 'class-0219a) 'a) *class-0219-a-1*)) x x) (deftest class-0219.2 (let ((*class-0219-a-1* nil) (*class-0219-a-2* nil)) (values (slot-value (make-instance 'class-0219b) 'a) *class-0219-a-1* *class-0219-a-2*)) y nil y) ;;; (defclass class-0220a () ((a :type (integer 0 10) :initarg :a))) (defclass class-0220b (class-0220a) ((a :type (integer -5 5)))) (deftest class-0220.1 (slot-value (make-instance 'class-0220a :a 10) 'a) 10) (deftest class-0220.2 (slot-value (make-instance 'class-0220a :a 0) 'a) 0) (deftest class-0220.3 (slot-value (make-instance 'class-0220b :a 0) 'a) 0) (deftest class-0220.4 (slot-value (make-instance 'class-0220b :a 5) 'a) 5) ;;; (defclass class-0221a () (a b c) (:documentation "This is class class-0221a")) (defclass class-0221b (class-0221a) ()) (defclass class-0221c (class-0221a) () (:documentation "This is class class-0221c")) (deftest class-0221.1 (let* ((cl (find-class 'class-0221a)) (doc (documentation cl t))) (or (null doc) (equalt doc "This is class class-0221a"))) t) (deftest class-0221.2 (let* ((cl (find-class 'class-0221b)) (doc (documentation cl t))) doc) nil) (deftest class-0221.3 (let* ((cl (find-class 'class-0221c)) (doc (documentation cl t))) (or (null doc) (equalt doc "This is class class-0221c"))) t) ;;; (defclass class-0222a () ((s1 :reader s1-r :writer s1-w :accessor s1-acc))) (defclass class-0222b (class-0222a) ()) (deftest class-0222.1 (let ((c (make-instance 'class-0222a))) (values (s1-w 'x c) (s1-r c) (s1-acc c) (setf (s1-acc c) 'y) (s1-r c))) x x x y y) (deftest class-0222.2 (let ((c (make-instance 'class-0222b))) (values (s1-w 'x c) (s1-r c) (s1-acc c) (setf (s1-acc c) 'y) (s1-r c))) x x x y y) ;;; (defclass class-0223a () ((s1 :reader s-r :writer s-w :accessor s-acc))) (defclass class-0223b (class-0223a) ((s2 :reader s-r :writer s-w :accessor s-acc))) (deftest class-0223.1 (let ((c (make-instance 'class-0223b))) (values (setf (slot-value c 's1) 'x) (setf (slot-value c 's2) 'y) (s-r c) (s-acc c) (s-w 'z c) (slot-value c 's1) (slot-value c 's2) (s-r c) (s-acc c))) x y y y z x z z z) gcl-2.7.1/ansi-tests/PaxHeaders/mask-field.lsp0000644000000000000000000000013114542551763016205 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.313788397 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/mask-field.lsp0000644000175000017500000000420314542551763015603 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 21:27:13 2003 ;;;; Contains: Tests of MASK-FIELD (in-package :cl-test) ;;; Error tests (deftest mask-field.error.1 (signals-error (mask-field) program-error) t) (deftest mask-field.error.2 (signals-error (mask-field (byte 1 1)) program-error) t) (deftest mask-field.error.3 (signals-error (mask-field (byte 1 1) -1 0) program-error) t) ;;; Non-error tests (deftest mask-field.1 (loop for x = (random-fixnum) for pos = (random 30) for size = (random 30) repeat 10000 unless (eql (mask-field (byte size pos) x) (logand (ash (1- (ash 1 size)) pos) x)) collect (list x pos size)) nil) (deftest mask-field.2 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) for pos = (random 300) for size = (random 300) repeat 1000 unless (eql (mask-field (byte size pos) x) (logand (ash (1- (ash 1 size)) pos) x)) collect (list x pos size))) nil) (deftest mask-field.3 (loop for i of-type fixnum from -1000 to 1000 always (eql (mask-field (byte 0 0) i) 0)) t) (deftest mask-field.order.1 (let ((i 0) a b c d) (values (mask-field (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (progn (setf d (incf i)) -1)) i a b c d)) 14 4 1 2 3 4) ;;; mask-field on places (deftest mask-field.place.1 (let ((x 0)) (values (setf (mask-field (byte 4 1) x) -1) x)) -1 30) (deftest mask-field.place.2 (loop for pos from 0 to 100 always (loop for size from 0 to 100 always (let ((x 0) (field (ash 1 pos))) (and (eql (setf (mask-field (byte size pos) x) field) field) (if (> size 0) (eql x field) (eql x 0)) )))) t) (deftest mask-field.place.order.1 (let ((i 0) a b c d e f (x (copy-seq #(63)))) (values (setf (mask-field (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (aref (progn (setf d (incf i)) x) (progn (setf e (incf i)) 0))) (progn (setf f (incf i)) (lognot 14))) x i a b c d e f)) -15 #(49) 6 1 2 3 4 5 6) gcl-2.7.1/ansi-tests/PaxHeaders/every.lsp0000644000000000000000000000013214542551762015323 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.313788397 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/every.lsp0000644000175000017500000001743114542551762014727 0ustar00cammcamm;-*- 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) ;;; Other specialized sequences (deftest every.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'zerop v)))) (t t t t t nil nil nil nil nil)) (deftest every.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest every.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest every.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest every.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (every #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest every.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (notnot (every #'alpha-char-p v)) (setf (aref v 2) #\0) (every #'alpha-char-p v))) t #\0 nil) ;;; Displaced vectors (deftest every.23 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (every #'evenp v1) (notnot (every 'evenp v2)))) nil t) (deftest every.24 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (every 'evenp v1)) (every #'evenp v2))) collect i) nil) (deftest every.25 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (every 'evenp v1)) (every #'evenp v2))) collect i) nil) (deftest every.26 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (notnot (every 'alpha-char-p s2)))) (nil nil t t nil nil nil)) (deftest every.27 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (notnot (every 'alpha-char-p s2)))) (nil nil t t nil nil nil)) ;;; adjustable vectors (deftest every.28 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (notnot (every #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (every #'plusp v)))) t nil) (deftest every.29 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (notnot (every #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (every #'plusp v)))) t t) ;;; Float, complex vectors (deftest every.30 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) unless (every #'plusp v) collect (list type v)) nil) (deftest every.31 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :fill-pointer 5 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) unless (every #'plusp v) collect (list type v)) nil) (deftest every.32 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) unless (every #'complexp v) collect (list type v)) nil) ;;; Order of arguments (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 (check-type-error #'(lambda (x) (every x '(a b c))) #'(lambda (x) (typep x '(or function symbol)))) nil) (deftest every.error.2 (check-type-error #'(lambda (x) (every #'null x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest every.error.3 (check-type-error #'(lambda (x) (every #'eq () x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest every.error.8 (signals-error (every) program-error) t) (deftest every.error.9 (signals-error (every #'null) program-error) t) (deftest every.error.10 (signals-error (locally (every 1 '(a b c)) t) type-error) t) (deftest every.error.11 (signals-error (every #'cons '(a b c)) program-error) t) (deftest every.error.12 (signals-error (every #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest every.error.13 (signals-error (every #'car '(a b c)) type-error) t) (deftest every.error.14 (signals-error (every #'identity '(1 2 3 . 4)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/fround-aux.lsp0000644000000000000000000000013214542551762016261 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.313788397 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fround-aux.lsp0000644000175000017500000000106714542551762015663 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 16:08:55 2003 ;;;; Contains: Aux. functions for testing FROUND (in-package :cl-test) (defun fround.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (fround n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (<= (- (/ d 2)) r (/ d 2)) (or (/= (abs r) (/ d 2)) (evenp (floor q)))) collect (list n d q r n2))) gcl-2.7.1/ansi-tests/PaxHeaders/gcd-aux.lsp0000644000000000000000000000013114542551762015520 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.313788397 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/gcd-aux.lsp0000644000175000017500000000110614542551762015115 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 3 06:57:22 2003 ;;;; Contains: Aux. functions for testing GCD (in-package :cl-test) (defun my-gcd (x y) (cond ((< x 0) (my-gcd (- x) y)) ((< y 0) (my-gcd x (- y))) ((<= x y) (my-gcd* x y)) (t (my-gcd* y x)))) (defun my-gcd* (x y) ;;; 0 <= x <= y (loop (when (zerop x) (return y)) (psetq x (mod y x) y x))) (defun my-lcm (x y) (when (< x 0) (setf x (- x))) (when (< y 0) (setf y (- y))) (if (or (= x 0) (= y 0)) 0 (/ (* x y) (my-gcd x y)))) gcl-2.7.1/ansi-tests/PaxHeaders/function.lsp0000644000000000000000000000013114542551762016015 xustar0030 mtime=1703597042.992022413 29 atime=1744294960.32578845 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/function.lsp0000644000175000017500000001151014542551762015412 0ustar00cammcamm;-*- 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) (report-and-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 (check-predicate (typef '(not (and (or number character symbol cons array) function)))) 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) ;;; Tests of FUNCTION type specifiers (deftest function.14 (flet ((%f () nil)) (declare (optimize safety debug)) (let ((f #'%f)) (declare (type (function () null) f)) (funcall f))) nil) (deftest function.15 (flet ((%f (x) (declare (ignore x)) nil)) (declare (ftype (function (nil) nil) %f)) :good) :good) (deftest function.16 (flet ((%f (x) (declare (ignore x)) nil)) (declare (ftype (function (t) null) %f)) (values (%f 'a) (locally (declare (ftype (function (integer) t) %f)) (%f 10)) (%f 'b))) nil nil nil) (deftest function.17 (flet ((%f (&optional x) x)) (declare (ftype (function (&optional integer) t) %f)) (values (%f) (%f 10) (%f) (%f (1+ most-positive-fixnum)))) nil 10 nil #.(1+ most-positive-fixnum)) (deftest function.18 (flet ((%f (&rest x) x)) (declare (ftype (function (&rest symbol) t) %f)) (values (%f) (%f 'a) (%f 'a 'b 'c))) () (a) (a b c)) (deftest function.19 (flet ((%f (&key foo bar) (list foo bar))) (declare (ftype (function (&key (:foo t) (:bar t)) list) %f)) (values (%f) (%f :foo 1) (%f :foo 1 :foo 2) (%f :bar 'a) (%f :bar 'a :bar 'b) (%f :foo 'x :bar 'y) (%f :bar 'x :foo 'y) (%f :bar 'x :foo 'y :bar 'z :foo 'w) )) (nil nil) (1 nil) (1 nil) (nil a) (nil a) (x y) (y x) (y x)) (deftest function.20 (flet ((%f (&key foo) foo)) (declare (ftype (function (&key (:foo t) (:allow-other-keys t)) t) %f)) (values (%f) (%f :foo 'a) (%f :allow-other-keys nil) (%f :allow-other-keys t :foo 'z))) nil a nil z) (deftest function.21 (flet ((%f (&key foo &allow-other-keys) foo)) (declare (ftype (function (&key (:foo integer)) t) %f)) (values (%f) (%f :foo 123))) nil 123) (deftest function.22 (flet ((%f (&key foo &allow-other-keys) foo)) (declare (ftype (function (&key (:foo integer) (:bar t)) t) %f)) (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y))) nil 123 nil 12) (deftest function.23 (flet ((%f (&key foo &allow-other-keys) foo)) (declare (ftype (function (&key (:foo integer) &allow-other-keys) t) %f)) (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y))) nil 123 nil 12) (deftest function.24 (flet ((%f (&rest r &key foo bar) (list r foo bar))) (declare (ftype (function (&rest symbol &key (:foo t) (:bar t)) list) %f)) (values (%f) (%f :foo 'a) (%f :bar 'b) (%f :bar 'd :foo 'c))) (nil nil nil) ((:foo a) a nil) ((:bar b) nil b) ((:bar d :foo c) c d)) gcl-2.7.1/ansi-tests/PaxHeaders/vector-push-extend.lsp0000644000000000000000000000013214542551763017736 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.333788485 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/vector-push-extend.lsp0000644000175000017500000003736014542551763017345 0ustar00cammcamm;-*- 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)) ;;; Tests on displaced arrays (deftest vector-push-extend.21 (let* ((a1 (make-array 10 :initial-element nil)) (a2 (make-array 6 :displaced-to a1 :displaced-index-offset 2 :fill-pointer 0))) (values (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 'foo a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1))) 0 () 0 1 (foo) (nil nil foo nil nil nil nil nil nil nil)) (deftest vector-push-extend.22 (let* ((a1 (make-array 6 :initial-element nil)) (a2 (make-array 0 :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 0))) (values (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 'foo a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a2)) )) 0 () 0 1 (foo) (nil nil nil nil nil nil) t (nil 0)) (deftest vector-push-extend.23 (let* ((a1 (make-array 10 :initial-element nil)) (a2 (make-array 6 :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 1))) (values (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 'foo a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (eqt (array-displacement a2) a1) (nth-value 1 (array-displacement a2)) )) 1 (nil) 1 2 (nil foo) (nil nil nil foo nil nil nil nil nil nil) t t 2) (deftest vector-push-extend.24 (let* ((a1 (make-array 4 :initial-element nil)) (a2 (make-array 2 :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 2))) (values (map 'list #'identity a1) (map 'list #'identity a2) (vector-push-extend 'foo a2 7) (fill-pointer a2) (map 'list #'identity a1) (map 'list #'identity a2) (array-dimension a2 0) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a2)))) (nil nil nil nil) (nil nil) 2 3 (nil nil nil nil) (nil nil foo) 9 t (nil 0)) ;;; Integer vectors (deftest vector-push-extend.25 (loop for adj in '(nil t) nconc (loop for bits from 1 to 64 for etype = `(unsigned-byte ,bits) for a1 = (make-array 10 :initial-element 0 :element-type etype) for a2 =(make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable adj :fill-pointer 0) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 1 a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1)) unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0))) collect (list etype adj result))) nil) (deftest vector-push-extend.26 (loop for bits from 1 to 64 for etype = `(unsigned-byte ,bits) for a1 = (make-array 8 :initial-element 0 :element-type etype) for a2 = (make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 6) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend 1 a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a1))) unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1) (0 0 0 0 0 0 0 0) t (nil 0))) collect (list etype result)) nil) ;;; strings (deftest vector-push-extend.27 (loop for adj in '(nil t) nconc (loop for etype in '(character base-char standard-char) for a1 = (make-array 10 :initial-element #\a :element-type etype) for a2 =(make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable adj :fill-pointer 0) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend #\b a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1)) unless (equal result '(0 () 0 1 (#\b) (#\a #\a #\b #\a #\a #\a #\a #\a #\a #\a))) collect (list etype adj result))) nil) (deftest vector-push-extend.28 (loop for etype in '(character base-char standard-char) for a1 = (make-array 8 :initial-element #\a :element-type etype) for a2 = (make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 6) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend #\b a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a1))) unless (equal result '(6 #.(coerce "aaaaaa" 'list) 6 7 #.(coerce "aaaaaab" 'list) #.(coerce "aaaaaaaa" 'list) t (nil 0))) collect (list etype result)) nil) ;;; float tests (deftest vector-push-extend.29 (loop for adj in '(nil t) nconc (loop for etype in '(short-float single-float double-float long-float) for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) for a1 = (make-array 10 :initial-element zero :element-type etype) for a2 =(make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable adj :fill-pointer 0) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend one a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1)) unless (equal result `(0 () 0 1 (,one) (,zero ,zero ,one ,zero ,zero ,zero ,zero ,zero ,zero ,zero))) collect (list etype adj result))) nil) (deftest vector-push-extend.30 (loop for etype in '(short-float single-float double-float long-float) for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) for a1 = (make-array 8 :initial-element zero :element-type etype) for a2 = (make-array 6 :element-type etype :displaced-to a1 :displaced-index-offset 2 :adjustable t :fill-pointer 6) for result = (list (fill-pointer a2) (map 'list #'identity a2) (vector-push-extend one a2) (fill-pointer a2) (map 'list #'identity a2) (map 'list #'identity a1) (notnot (adjustable-array-p a2)) (multiple-value-list (array-displacement a1))) unless (equal result `(6 (,zero ,zero ,zero ,zero ,zero ,zero) 6 7 (,zero ,zero ,zero ,zero ,zero ,zero ,one) (,zero ,zero ,zero ,zero ,zero ,zero ,zero ,zero) t (nil 0))) collect (list etype result)) nil) ;;; 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 (signals-error (vector-push-extend) program-error) t) (deftest vector-push-extend.error.15 (signals-error (vector-push-extend (vector 1 2 3)) program-error) t) (deftest vector-push-extend.error.16 (signals-error (vector-push-extend (vector 1 2 3) 4 1 nil) program-error) t) (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.7.1/ansi-tests/PaxHeaders/numbers-aux.lsp0000644000000000000000000000013114542551763016437 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.337788502 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/numbers-aux.lsp0000644000175000017500000002307614542551763016046 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 7 07:24:43 2003 ;;;; Contains: Auxiliary functions for number tests (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) ;;; Binary search on reals (defun float-binary-search (fn lo hi) "FN is a function that, if true for X, is true for all Y > X. Find the smallest float in [lo,hi] for which the function return true." (assert (functionp fn)) (assert (floatp lo)) (assert (floatp hi)) (assert (<= lo hi)) (assert (funcall fn hi)) (loop while (<= lo hi) do (let ((mid (/ (+ lo hi) 2))) (if (funcall fn mid) (if (= mid hi) (return hi) (setq hi mid)) (if (= mid lo) (return hi) (setq lo mid)))))) (defun integer-binary-search (fn lo hi) "FN is a function that, if true for X, is true for all Y < X. Find the largest integer in [lo,hi) for which the function return true." (assert (functionp fn)) (assert (integerp lo)) (assert (integerp hi)) (assert (<= lo hi)) (assert (funcall fn lo)) (loop while (< lo hi) do (let ((mid (ceiling (+ lo hi) 2))) (if (funcall fn mid) (setq lo mid) (if (= mid hi) (return lo) (setq hi mid)))) finally (return lo))) (defun find-largest-exactly-floatable-integer (upper-bound) (integer-binary-search #'(lambda (i) (let* ((f (float i)) (i- (1- i)) (f- (float i-))) (and (= f i) (= f- i-)))) 0 upper-bound)) (defun eqlzt (x y) "Return T if (eql x y) or if both are zero of the same type." (cond ((complexp x) (and (complexp y) (eqlzt (realpart x) (realpart y)) (eqlzt (imagpart x) (imagpart y)))) ((zerop x) (eqlt (abs x) (abs y))) (t (eqlt x y)))) (defconstant +rational-most-negative-short-float+ (rational-safely most-negative-short-float)) (defconstant +rational-most-negative-single-float+ (rational-safely most-negative-single-float)) (defconstant +rational-most-negative-double-float+ (rational-safely most-negative-double-float)) (defconstant +rational-most-negative-long-float+ (rational-safely most-negative-long-float)) (defconstant +rational-most-positive-short-float+ (rational-safely most-positive-short-float)) (defconstant +rational-most-positive-single-float+ (rational-safely most-positive-single-float)) (defconstant +rational-most-positive-double-float+ (rational-safely most-positive-double-float)) (defconstant +rational-most-positive-long-float+ (rational-safely most-positive-long-float)) (defun float-exponent (x) (if (floatp x) (nth-value 1 (decode-float x)) 0)) (defun numbers-are-compatible (x y) (cond ((complexp x) (and (numbers-are-compatible (realpart x) y) (numbers-are-compatible (imagpart x) y))) ((complexp y) (and (numbers-are-compatible x (realpart y)) (numbers-are-compatible x (imagpart y)))) (t (when (floatp x) (rotatef x y)) (or (floatp x) (not (floatp y)) (etypecase y (short-float (<= +rational-most-negative-short-float+ x +rational-most-positive-short-float+)) (single-float (<= +rational-most-negative-single-float+ x +rational-most-positive-single-float+)) (double-float (<= +rational-most-negative-double-float+ x +rational-most-positive-double-float+)) (long-float (<= +rational-most-negative-long-float+ x +rational-most-positive-long-float+))))))) ;;; NOTE! According to section 12.1.4.1, when a rational is compared ;;; to a float, the effect is as if the float is convert to a rational ;;; (by RATIONAL), not as if the rational is converted to a float. ;;; This means the calls to numbers-are-compatible are not necessary. (defun =.4-fn () (loop for x in *numbers* append (loop for y in *numbers* unless (or ;; (not (numbers-are-compatible x y)) (if (= x y) (= y x) (not (= y x)))) collect (list x y)))) (defun /=.4-fn () (loop for x in *numbers* append (loop for y in *numbers* unless (or ;; (not (numbers-are-compatible x y)) (if (/= x y) (/= y x) (not (/= y x)))) collect (list x y)))) (defun /=.4a-fn () (loop for x in *numbers* append (loop for y in *numbers* when (and ;; (numbers-are-compatible x y) (if (= x y) (/= x y) (not (/= x y)))) collect (list x y)))) (defun <.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (and (< x y) (> x y))) (arithmetic-error () nil)) collect (list x y)))) (defun <.9-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (< x y) (not (> y x)) (> y x))) (arithmetic-error () nil)) collect (list x y)))) (defun <.10-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (< x y) (>= x y) (not (>= x y)))) (arithmetic-error () nil)) collect (list x y)))) (defun <=.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (<= x y) (not (>= y x)) (>= y x))) (arithmetic-error () nil)) collect (list x y)))) (defun <=.9-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (<= x y) (not (or (= x y) (< x y))) (or (= x y) (< x y)))) (arithmetic-error () nil)) collect (list x y)))) (defun >.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (> x y) (<= x y) (not (<= x y)))) (arithmetic-error () nil)) collect (list x y)))) (defun >=.8-fn () (loop for x in *reals* nconc (loop for y in *reals* when (handler-case (and ;; (numbers-are-compatible x y) (if (>= x y) (not (or (= x y) (> x y))) (or (= x y) (> x y)))) (arithmetic-error () nil)) collect (list x y)))) ;;; Comparison of rationsls (defun compare-random-rationals (n m rep) (loop for a = (- (random n) m) for b = (- (random n) m) for c = (- (random n) m) for d = (- (random n) m) repeat rep when (and (/= b 0) (/= d 0) (let ((q1 (/ a b)) (q2 (/ c d)) (ad (* a d)) (bc (* b c))) (when (< (* b d) 0) (setq ad (- ad)) (setq bc (- bc))) (or (if (< q1 q2) (not (< ad bc)) (< ad bc)) (if (<= q1 q2) (not (<= ad bc)) (<= ad bc)) (if (> q1 q2) (not (> ad bc)) (> ad bc)) (if (>= q1 q2) (not (>= ad bc)) (>= ad bc)) (if (= q1 q2) (not (= ad bc)) (= ad bc)) (if (/= q1 q2) (not (/= ad bc)) (/= ad bc))))) collect (list a b c d))) (defun max.2-fn () (loop for x in *reals* nconc (loop for y in *reals* when (numbers-are-compatible x y) unless (handler-case (let ((m (max x y))) (and (>= m x) (>= m y) (or (= m x) (= m y)))) (floating-point-underflow () t) (floating-point-overflow () t)) collect (list x y (max x y))))) (defun min.2-fn () (loop for x in *reals* nconc (loop for y in *reals* when (numbers-are-compatible x y) unless (handler-case (let ((m (min x y))) (and (<= m x) (<= m y) (or (= m x) (= m y)))) (floating-point-underflow () t) (floating-point-overflow () t)) collect (list x y (min x y))))) ;;; Compute the number of digits that can be added to 1.0 in the appropriate ;;; float type, a rational representation of the smallest radix^(-k) s.t. ;;; 1.0 + radix^(-k) /= 1.0, and the float representation of that value. ;;; Note that this will in general be > -epsilon. (defun find-epsilon (x) (assert (floatp x)) (let* ((one (float 1 x)) (radix (float-radix one)) (eps (/ 1 radix))) (loop for next-eps = (/ eps radix) for i from 1 until (eql one (+ one next-eps)) do (setq eps next-eps) finally (return (values i eps (float eps one)))))) (defun test-log-op-with-decls (op xlo xhi ylo yhi niters &optional (decls '((optimize (speed 3) (safety 1) (debug 1))))) "Test that a compiled form of the LOG* function OP computes the expected result on two random integers drawn from the types `(integer ,xlo ,xhi) and `(integer ,ylo ,yhi). Try niters choices. Return a list of pairs on which the test fails." (assert (symbolp op)) (assert (integerp xlo)) (assert (integerp xhi)) (assert (integerp ylo)) (assert (integerp yhi)) (assert (integerp niters)) (assert (<= xlo xhi)) (assert (<= ylo yhi)) (let* ((source `(lambda (x y) (declare (type (integer ,xlo ,xhi) x) (type (integer ,ylo ,yhi) y) ,@ decls) (,op x y))) (fn (compile nil source))) (loop for i below niters for x = (random-from-interval (1+ xhi) xlo) for y = (random-from-interval (1+ yhi) ylo) unless (eql (funcall (the symbol op) x y) (funcall fn x y)) collect (list x y)))) (defun test-log-op (op n1 n2) (flet ((%r () (let ((r (random 33))) (- (random (ash 1 (1+ r))) (ash 1 r))))) (loop for x1 = (%r) for x2 = (%r) for y1 = (%r) for y2 = (%r) repeat n1 nconc (test-log-op-with-decls op (min x1 x2) (max x1 x2) (min y1 y2) (max y1 y2) n2)))) (defun safe-tan (x &optional (default 0.0)) (handler-case (let ((result (multiple-value-list (tan x)))) (assert (null (cdr result))) (car result)) (arithmetic-error () default))) gcl-2.7.1/ansi-tests/PaxHeaders/directory-namestring.lsp0000644000000000000000000000013214542551762020342 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.345788538 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/directory-namestring.lsp0000644000175000017500000000270314542551762017742 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cons-test-04.lsp0000644000000000000000000000013214542551762016331 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.349788556 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-04.lsp0000644000175000017500000002224114542551762015730 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cerror.lsp0000644000000000000000000000013014542551762015463 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.349788556 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cerror.lsp0000644000175000017500000000323214542551762015063 0ustar00cammcamm;-*- 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.2a (let* ((fmt (formatter "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.4a (let ((fmt (formatter "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) ;;; Program error cases (deftest cerror.error.1 (signals-error (cerror) program-error) t) (deftest cerror.error.2 (signals-error (cerror "foo") program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ecase.lsp0000644000000000000000000000013214542551762015251 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.349788556 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ecase.lsp0000644000175000017500000000647514542551762014663 0ustar00cammcamm;-*- 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 (signals-type-error x 1 (ecase x)) t) (deftest ecase.3 (signals-type-error x 1 (ecase x (a 1) (b 2) (c 3))) t) ;;; It is legal to use T or OTHERWISE as key designators ;;; in ECASE forms. They have no special meaning here. (deftest ecase.4 (signals-type-error x 1 (ecase x (t nil))) t) (deftest ecase.5 (signals-type-error x 1 (ecase x (otherwise nil))) t) (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 (signals-type-error x nil (ecase x (nil 'a))) t) (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 (signals-type-error x t (ecase x (a 10))) t) (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 (signals-type-error x 'otherwise (ecase x ((t) 10))) t) (deftest ecase.16 (signals-type-error x t (ecase x ((otherwise) 10))) t) (deftest ecase.17 (signals-type-error x 'a (ecase x (b 0) (c 1) (otherwise 2))) t) (deftest ecase.18 (signals-type-error x 'a (ecase x (b 0) (c 1) ((otherwise) 2))) t) (deftest ecase.19 (signals-type-error x 'a (ecase x (b 0) (c 1) ((t) 2))) t) (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) ;;; No implicit tagbody (deftest ecase.33 (block done (tagbody (ecase 'a (a (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest ecase.34 (macrolet ((%m (z) z)) (ecase (expand-in-current-env (%m :b)) (:a :bad1) (:b :good) (:c :bad2))) :good) (deftest ecase.error.1 (signals-error (funcall (macro-function 'ecase)) program-error) t) (deftest ecase.error.2 (signals-error (funcall (macro-function 'ecase) '(ecase t)) program-error) t) (deftest ecase.error.3 (signals-error (funcall (macro-function 'ecase) '(ecase t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/standard-generic-function.lsp0000644000000000000000000000013214542551763021227 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.349788556 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/standard-generic-function.lsp0000644000175000017500000000154014542551763020625 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 20 06:47:20 2003 ;;;; Contains: Additional tests for class STANDARD-GENERIC-FUNCTION (in-package :cl-test) ;;; Most tests of this are elsewhere (unless (typep #'cons 'generic-function) (deftest standard-generic-function.1 (progn (eval '(defgeneric sgf-cpl-gf.1 (x) (:method ((x generic-function)) 1) (:method ((x function)) 2) (:method ((x t)) 3))) (values (sgf-cpl-gf.1 #'make-instance) (sgf-cpl-gf.1 #'cons) (sgf-cpl-gf.1 'a))) 1 2 3) (deftest standard-generic-function.2 (progn (eval '(defgeneric sgf-cpl-gf.2 (x) (:method ((x standard-generic-function)) 1) (:method ((x function)) 2) (:method ((x t)) 3))) (values (sgf-cpl-gf.2 #'make-instance) (sgf-cpl-gf.2 #'cons) (sgf-cpl-gf.2 'a))) 1 2 3) ) gcl-2.7.1/ansi-tests/PaxHeaders/bit-andc1.lsp0000644000000000000000000000013014542551762015731 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.365788626 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-andc1.lsp0000644000175000017500000001547714542551762015347 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:56:39 2003 ;;;; Contains: Tests of BIT-ANDC1 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-andc1 (expand-in-current-env (%m #*0011)) #*0101)) #*0100) (deftest bit-andc1.21 (macrolet ((%m (z) z)) (bit-andc1 #*1010 (expand-in-current-env (%m #*1100)))) #*0100) (deftest bit-andc1.22 (macrolet ((%m (z) z)) (bit-andc1 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*01001000) (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) (def-fold-test bit-andc1.fold.1 (bit-andc1 #*10010 #*01011)) ;;; Random tests (deftest bit-andc1.random.1 (bit-random-test-fn #'bit-andc1 #'logandc1) nil) ;;; Error tests (deftest bit-andc1.error.1 (signals-error (bit-andc1) program-error) t) (deftest bit-andc1.error.2 (signals-error (bit-andc1 #*000) program-error) t) (deftest bit-andc1.error.3 (signals-error (bit-andc1 #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/rt-doc.txt0000644000000000000000000000013214542551763015403 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.365788626 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rt-doc.txt0000644000175000017500000002077314542551763015012 0ustar00cammcamm #|----------------------------------------------------------------------------| | 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.7.1/ansi-tests/PaxHeaders/open-stream-p.lsp0000644000000000000000000000013114542551763016660 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.365788626 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/open-stream-p.lsp0000644000175000017500000000241314542551763016257 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/psetq.lsp0000644000000000000000000000013114542551763015325 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.365788626 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/psetq.lsp0000644000175000017500000000372714542551763014735 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:37:20 2003 ;;;; Contains: Tests of PSETQ (in-package :cl-test) (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) (deftest psetq.8 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetq *x* 6 *y* 15) *x* *y*)) 0 10 nil 6 15) (deftest psetq.9 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetq *x* *y* *y* *x*) *x* *y*)) 0 10 nil 10 0) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest psetq.10 (macrolet ((%m (z) z)) (let ((x nil) (y nil)) (values (psetq x (expand-in-current-env (%m 1)) y (expand-in-current-env (%m 2))) x y))) nil 1 2) (deftest psetq.error.1 (signals-error (funcall (macro-function 'psetq)) program-error) t) (deftest psetq.error.2 (signals-error (funcall (macro-function 'psetq) '(psetq)) program-error) t) (deftest psetq.error.3 (signals-error (funcall (macro-function 'psetq) '(psetq) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/read-sequence.lsp0000644000000000000000000000013114542551763016712 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.365788626 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-sequence.lsp0000644000175000017500000002205314542551763016313 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/dpb.lsp0000644000000000000000000000013214542551762014736 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.365788626 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/dpb.lsp0000644000175000017500000000402214542551762014332 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:43:54 2003 ;;;; Contains: Tests of DPB (in-package :cl-test) ;;; Error tests (deftest dpb.error.1 (signals-error (dpb) program-error) t) (deftest dpb.error.2 (signals-error (dpb 1) program-error) t) (deftest dpb.error.3 (signals-error (dpb 1 (byte 1 0)) program-error) t) (deftest dpb.error.4 (signals-error (dpb 1 (byte 1 0) 0 nil) program-error) t) ;;; Non-error tests (deftest dpb.1 (loop for pos = (random 32) for size = (random 32) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (dpb newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp (- i pos) newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest dpb.2 (loop for pos = (random 1000) for size = (random 1000) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (dpb newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp (- i pos) newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest dpb.3 (loop for x = (random-fixnum) for y = (random-fixnum) for pos = (random 32) repeat 100 always (= (dpb x (byte 0 pos) y) y)) t) (deftest dpb.4 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for pos = (random 200) repeat 100 always (= (dpb x (byte 0 pos) y) y))) t) (deftest dpb.5 (loop for i of-type fixnum from -1000 to 1000 always (eql (dpb -1 (byte 0 0) i) i)) t) gcl-2.7.1/ansi-tests/PaxHeaders/remhash.lsp0000644000000000000000000000013114542551763015620 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.365788626 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remhash.lsp0000644000175000017500000000344114542551763015221 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 08:58:06 2003 ;;;; Contains: Tests of REMHASH (in-package :cl-test) (deftest remhash.1 (let ((table (make-hash-table))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.2 (let ((table (make-hash-table :test 'eq))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.3 (let ((table (make-hash-table :test 'equal))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.4 (let ((table (make-hash-table :test 'equalp))) (values (gethash 'a table) (remhash 'a table) (setf (gethash 'a table) 'b) (gethash 'a table) (notnot (remhash 'a table)) (gethash 'a table))) nil nil b b t nil) (deftest remhash.5 (remhash 'a (make-hash-table)) nil) (deftest remhash.6 (notnot-mv (remhash nil (let ((table (make-hash-table))) (setf (gethash nil table) t) table))) t) (deftest remhash.order.1 (let ((i 0) x y) (values (remhash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) (make-hash-table))) i x y)) nil 2 1 2) ;;; Error tests (deftest remhash.error.1 (signals-error (remhash) program-error) t) (deftest remhash.error.2 (signals-error (remhash 'a) program-error) t) (deftest remhash.error.3 (signals-error (remhash 'a (make-hash-table) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/write.lsp0000644000000000000000000000013214542551763015324 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.377788678 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/write.lsp0000644000175000017500000000350714542551763014727 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jul 15 06:43:55 2004 ;;;; Contains: Tests of WRITE (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;; (compile-and-load "write-aux.lsp") ;;; This function is also incidentally tested elsewhere. (deftest write.1 (random-write-test 1000) nil) (deftest write.2 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 2 :stream nil)))) "2") (deftest write.3 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (write 3 :stream t)))))) "3") (deftest write.4 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (os) (write 4 :stream os)))) "4") (deftest write.5 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 5 :allow-other-keys nil)))) "5") (deftest write.6 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 6 :allow-other-keys t :foo 'bar)))) "6") (deftest write.7 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (*standard-output*) (write 7 :base 10 :base 3)))) "7") ;;; Error tests (deftest write.error.1 (signals-error (write) program-error) t) (deftest write.error.2 (signals-error (write 1 :stream) program-error) t) (deftest write.error.3 (signals-error (write 1 :allow-other-keys nil :foo 'bar) program-error) t) (deftest write.error.4 (signals-error (write 1 :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop.lsp0000644000000000000000000000013114542551763017406 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.377788678 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop.lsp0000644000175000017500000005574514542551763017025 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Dec 23 20:39:22 2004 ;;;; Contains: Randomized tests of type propagation in the compiler (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel) (compile-and-load "random-aux.lsp") (compile-and-load "random-int-form.lsp")) (defvar *print-random-type-prop-input* nil) (defparameter *random-type-prop-result* nil) (declaim (special *param-types* *params* *is-var?* *form*)) (declaim (special *replicate-type*)) (defparameter *default-reps* 1000) (defparameter *default-cell* nil) (defparameter *default-ignore* 'arithmetic-error) (defparameter *default-arg-the* t) ;;; ;;; The random type prop tester takes three required arguments: ;;; ;;; operator A lisp operator (either a symbol or a lambda form) ;;; arg-types A list consisting either of certain kinds of lisp types ;;; (that make-random-element-of-type understands) and/or ;;; functions that yield types. ;;; minargs Minimum number of arguments to be given to the operator. ;;; Must be a positive integer <= maxargs. ;;; ;;; There are also keyword arguments, some with defaults given by special ;;; variables. ;;; ;;; The random type prop tester generates between minargs and maxargs ;;; (maxargs defaults to minargs) random arguments. The type of each ;;; argument is given by the corresponding type in arg-types (or by rest-type, ;;; if there aren't enough elements of arg-types). If the element of arg-types ;;; is a function, the type for the parameter is produced by calling the function ;;; with the previously generated actual parameters as its arguments. ;;; ;;; The list of parameters is stored into the special variable *params*. ;;; ;;; The tester evaluates (operator . arguments), and also builds a lambda ;;; form to be compiled and called on (a subset of) the parameters. The lambda ;;; form is stored in the special variable *form*. ;;; ;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests ;;; in a deftest form. See random-type-prop-tests.lsp (and subfiles) for examples ;;; of its use testing CL builtin operators. To use it: ;;; ;;; (load "gclload1.lsp") ;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles ;;; (compile-and-load "random-type-prop.lsp") ;;; (in-package :cl-test) ;;; (load "random-type-prop-tests.lsp") ;;; (let (*catch-errors*) (do-test ')) ;;; or (let (*catch-errors*) (do-tests)) ;;; ;;; Running all the tests may take a while, particularly on lisps with slow compilers. ;;; ;;; ;;; Keyword arguments to do-random-type-prop-tests: ;;; ;;; Argument Default Meaning ;;; ;;; maxargs minargs Maximum number of actual parameters to generate (max 20). ;;; rest-type t Type of arguments beyond those specified in arg-types ;;; reps *default-reps* Number of repetitions to try before stopping. ;;; The default is controlled by a special variable that ;;; is initially 1000. ;;; enclosing-the nil If true, with prob 1/2 randomly generate an enclosing ;;; (THE ...) form around the form invoking the operator. ;;; arg-the *default-arg-the* If true (which is the initial value of the default ;;; special variable), with probability 1/2 randomly generate ;;; a (THE ...) form around each actual parameter. ;;; cell *default-cell* If true (default is NIL), store the result into a rank-0 ;;; array of specialized type. This enables one to test ;;; forms where the result will be unboxed. Otherwise, just ;;; return the values. ;;; ignore *default-ignore* Ignore conditions that are elements of IGNORE. Default is ;;; ARITHMETIC-ERROR. ;;; test rt::equalp-with-case The test function used to compare outputs. It's ;;; also handy to use #'approx= to handle approximate equality ;;; when testing floating point computations, where compiled code ;;; may have different roundoff errors. ;;; replicate nil Cause arguments to be copied (preserving sharing in conses ;;; and arrays) before applying the operator. This is used to test ;;; destructive operators. ;;; ;;; (defun do-random-type-prop-tests (operator arg-types minargs &key (maxargs minargs) (rest-type t) (reps *default-reps*) (enclosing-the nil) (arg-the *default-arg-the*) (cell *default-cell*) (ignore *default-ignore*) (test #'regression-test::equalp-with-case) (replicate nil replicate-p)) (assert (<= 1 minargs maxargs 20)) (prog1 (dotimes (i reps) again (handler-bind #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) #+lispworks () (let* ((param-names '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) (nargs (+ minargs (random (- maxargs minargs -1)))) (types (subseq (append arg-types (make-list (max 0 (- nargs (length arg-types))) :initial-element rest-type)) 0 nargs)) (replicate (if replicate-p replicate (mapcar (constantly nil) types))) ; (vals (mapcar #'make-random-element-of-type types)) (vals (setq *params* (or (make-random-arguments types) (go again)))) (vals (if replicate (mapcar #'replicate vals) vals)) (is-var? (if (consp replicate) (progn (assert (= (length replicate) (length vals))) (loop for x in replicate collect (or x (coin)))) (loop repeat (length vals) collect (coin)))) (*is-var?* is-var?) (params (loop for x in is-var? for p in param-names when x collect p)) (param-types (mapcar #'make-random-type-containing vals replicate)) (*param-types* param-types) (type-decls (loop for x in is-var? for p in param-names for tp in param-types when x collect `(type ,tp ,p))) (rval (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (let* ((vals (if replicate (mapcar #'replicate vals) vals)) (eval-form (cons operator (loop for v in vals collect `(quote ,v))))) ;; (print eval-form) (terpri) ;; (dotimes (i 100) (eval eval-form)) (eval eval-form)))) (result-type (if (and enclosing-the (integerp rval)) (make-random-type-containing rval) t)) (expr `(,operator ,@(loop for x in is-var? for v in vals for r in replicate for p in param-names collect (if x (if (and arg-the (coin)) (let ((tp (make-random-type-containing v r))) `(the ,tp ,p)) p) (if (or (consp v) (and (symbolp v) (not (or (keywordp v) (member v '(nil t)))))) `(quote ,v) v))))) (speed (random 4)) (space (random 4)) (safety #-allegro (random 4) #+allegro (1+ (random 3))) (debug (random 4)) (store-into-cell? (and cell (coin))) (upgraded-result-type (and store-into-cell? (upgraded-array-element-type `(eql ,rval)))) (form (setq *form* `(lambda (,@(when store-into-cell? '(r)) ,@params) (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) ,@ type-decls) ,(let ((result-form (if enclosing-the `(the ,result-type ,expr) expr))) (if store-into-cell? `(setf (aref r) ,result-form) result-form))))) ) (when *print-random-type-prop-input* (let ((*print-pretty* t) (*print-case* :downcase)) (print (list :form form :vals vals)))) (finish-output) (let* ((param-vals (loop for x in is-var? for v in vals when x collect v)) (fn (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (compile nil form))) (result (if store-into-cell? (let ((r (make-array nil :element-type upgraded-result-type))) (apply fn r param-vals) (aref r)) (apply fn param-vals)))) (setq *random-type-prop-result* (list :upgraded-result-type upgraded-result-type :form form :vals vals :result result :rval rval)) (unless (funcall test result rval) (return *random-type-prop-result*)))) ;; #+allegro (excl::gc t) )))) (defun make-random-arguments (types-or-funs) (let ((vals nil)) (loop for type-or-fun in types-or-funs for type = (or (typecase type-or-fun ((and function (not symbol)) (apply type-or-fun vals)) (t type-or-fun)) (return-from make-random-arguments nil) ;; null type ) for val = (make-random-element-of-type type) do (setf vals (nconc vals (list val)))) ;; (dolist (v vals) (describe v)) vals)) (defmacro defmethods (name &rest bodies) `(progn ,@(mapcar #'(lambda (body) `(defmethod ,name ,@body)) bodies))) (defgeneric make-random-type-containing* (val) (:method-combination randomized) (:documentation "Produce a random type containing VAL. If the special variable *REPLICATE-TYPE* is true, and the value is mutable, then do not use the value in MEMBER or EQL type specifiers.")) (defun make-random-type-containing (type &optional *replicate-type*) (declare (special *replicate-type*)) (make-random-type-containing* type)) (defmethods make-random-type-containing* (4 ((val t)) (declare (special *replicate-type*)) (rcase (1 t) (1 (if (consp val) 'cons 'atom)) (1 (if *replicate-type* (make-random-type-containing* val) `(eql ,val))) (1 (if *replicate-type* (make-random-type-containing* val) (let* ((n1 (random 4)) (n2 (random 4)) ;; Replace these calls with (make-random-element-of-type t) ;; at some point (l1 (loop repeat n1 collect (random-leaf))) (l2 (loop repeat n2 collect (random-leaf)))) `(member ,@l1 ,val ,@l2)))))) (1 ((val standard-object)) 'standard-object) (1 ((val structure-object)) 'structure-object) (1 ((val class)) 'class) (1 ((val standard-class)) 'standard-class) (1 ((val structure-class)) 'structure-class) (1 ((val number)) 'number) (1 ((val real)) 'real) (1 ((val ratio)) 'ratio) (1 ((val integer)) (rcase (1 'integer) (1 'signed-byte) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-integer))) (l2 (loop repeat n2 collect (make-random-integer)))) `(member ,@l1 ,val ,@l2))) (1 (let ((lo (abs (make-random-integer)))) `(integer ,(- val lo)))) (2 (let ((lo (abs (make-random-integer)))) `(integer ,(- val lo) *))) (2 (let ((hi (abs (make-random-integer)))) `(integer * ,(+ val hi)))) (4 (let ((lo (abs (make-random-integer))) (hi (abs (make-random-integer)))) `(integer ,(- val lo) ,(+ val hi)))) (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) (2 ((val character)) (rcase (1 'character) (1 (if (typep val 'base-char) 'base-char #-sbcl 'extended-char #+sbcl (throw 'fail nil) )) (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil))) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-character))) (l2 (loop repeat n2 collect (make-random-character)))) `(member ,@l1 ,val ,@l2))))) (1 ((val null)) 'null) (2 ((val symbol)) (rcase (1 'symbol) (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil)))) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-symbol))) (l2 (loop repeat n2 collect (make-random-symbol)))) `(member ,@l1 ,val ,@l2))))) (1 ((val rational)) (rcase (1 'rational) (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) `(member ,@l1 ,val ,@l2))) (1 `(rational ,val)) (1 `(rational * ,val)) (1 (let ((v (make-random-element-of-type 'rational))) (if (<= v val) `(rational ,v ,val) `(rational ,val ,v)))))) (1 ((val float)) (rcase (1 (let* ((n1 (random 4)) (n2 (random 4)) (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) `(member ,@l1 ,val ,@l2))) (1 (let ((names (float-types-containing val))) (random-from-seq names))) (1 (let ((name (random-from-seq (float-types-containing val)))) (if (>= val 0) `(,name ,(coerce 0 name) ,val) `(,name ,val ,(coerce 0 name))))))) ) (defun float-types-containing (val) (loop for n in '(short-float single-float double-float long-float float) when (typep val n) collect n)) (defun make-random-array-dimension-spec (array dim-index) (assert (<= 0 dim-index)) (assert (< dim-index (array-rank array))) (let ((dim (array-dimension array dim-index))) (rcase (1 '*) (1 dim)))) ;;; More methods (defmethods make-random-type-containing* (3 ((val bit-vector)) (let ((root (if (and (coin) (typep val 'simple-bit-vector)) 'simple-bit-vector 'bit-vector))) (rcase (1 root) (1 `(,root)) (3 `(,root ,(make-random-array-dimension-spec val 0)))))) (3 ((val vector)) (let ((root 'vector) (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) (etype (rcase (1 '*) (1 (array-element-type val)) ;; Add rule for creating new element types? ))) (rcase (1 alt-root) (1 `(,alt-root)) (1 `(,root ,etype)) (2 (if (and (simple-vector-p val) (coin)) `(simple-vector ,(make-random-array-dimension-spec val 0)) `(,root ,etype ,(make-random-array-dimension-spec val 0))))))) (3 ((val array)) (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) (etype (rcase (1 (array-element-type val)) (1 '*))) (rank (array-rank val))) (rcase (1 root) (1 `(,root)) (1 `(,root ,etype)) (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) #-ecl (1 `(,root ,etype ,rank))))) (3 ((val string)) (let ((root (cond ((and (coin) (typep val 'base-string)) (cond ((and (coin) (typep val 'simple-base-string)) 'simple-base-string) (t 'base-string))) ((and (coin) (typep val 'simple-string)) 'simple-string) (t 'string)))) (rcase (1 root) (1 `(,root)) (3 `(,root ,(make-random-array-dimension-spec val 0)))))) (1 ((val list)) 'list) (1 ((val cons)) (rcase (1 'cons) (2 `(cons ,(make-random-type-containing* (car val)) ,(make-random-type-containing* (cdr val)))) (1 `(cons ,(make-random-type-containing* (car val)) ,(random-from-seq #(t *)))) (1 `(cons ,(make-random-type-containing* (car val)))) (1 `(cons ,(random-from-seq #(t *)) ,(make-random-type-containing* (cdr val)) )))) (1 ((val complex)) (rcase (1 'complex) #-gcl (1 (let* ((t1 (type-of (realpart val))) (t2 (type-of (imagpart val))) (part-type (cond ((subtypep t1 t2) (upgraded-complex-part-type t2)) ((subtypep t2 t1) (upgraded-complex-part-type t1)) ((and (subtypep t1 'rational) (subtypep t2 'rational)) 'rational) (t (upgraded-complex-part-type `(or ,t1 ,t2)))))) (if (subtypep 'real part-type) '(complex real) `(complex ,part-type)))))) (1 ((val generic-function)) 'generic-function) (1 ((val function)) (rcase (1 'function) (1 (if (typep val 'compiled-function) 'compiled-function 'function)))) ) ;;; Macro for defining random type prop tests (defmacro def-type-prop-test (name &body args) `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." (string name)) (find-package :cl-test)) (do-random-type-prop-tests ,@args) nil)) ;;; Function used in constructing list types for some random type prop tests (defun make-list-type (length &optional (rest-type 'null) (element-type t)) (let ((result rest-type)) (loop repeat length do (setq result `(cons ,element-type ,result))) result)) (defun make-sequence-type (length &optional (element-type t)) (rcase (1 `(vector ,element-type ,length)) (1 `(array ,element-type (,length))) (1 `(simple-array ,element-type (,length))) (2 (make-list-type length 'null element-type)))) (defun make-random-sequence-type-containing (element &optional *replicate-type*) (make-sequence-type (random 10) (make-random-type-containing* element))) (defun same-set-p (set1 set2 &rest args &key key test test-not) (declare (ignorable key test test-not)) (and (apply #'subsetp set1 set2 args) (apply #'subsetp set2 set2 args) t)) (defun index-type-for-dim (dim) "Returns a function that computes integer type for valid indices of an array dimension, or NIL if there are none." #'(lambda (array &rest other) (declare (ignore other)) (let ((d (array-dimension array dim))) (and (> d 0) `(integer 0 (,d)))))) (defun index-type-for-v1 (v1 &rest other) "Computes integer type for valid indices for the first of two vectors" (declare (ignore other)) (let ((d (length v1))) `(integer 0 ,d))) (defun index-type-for-v2 (v1 v2 &rest other) "Computes integer type for valid indices for the second of two vectors" (declare (ignore v1 other)) (let ((d (length v2))) `(integer 0 ,d))) (defun end-type-for-v1 (v1 v2 &rest other) (declare (ignore v2)) (let ((d (length v1)) (start1 (or (cadr (member :start1 other)) 0))) `(integer ,start1 ,d))) (defun end-type-for-v2 (v1 v2 &rest other) (declare (ignore v1)) (let ((d (length v2)) (start2 (or (cadr (member :start2 other)) 0))) `(integer ,start2 ,d))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric replicate (obj) (:documentation "Copies the structure of a lisp object recursively, preserving sharing.")) (defmacro replicate-with ((source-obj dest-obj copy-form) &body body) `(or (gethash ,source-obj *replicate-table*) (let ((,dest-obj ,copy-form)) (setf (gethash ,source-obj *replicate-table*) ,dest-obj) ,@body ,dest-obj))) (declaim (special *replicate-table*)) (defmethod replicate :around ((obj t)) "Wrapper to create a hash table for structure sharing, if none exists." (if (boundp '*replicate-table*) (call-next-method obj) (let ((*replicate-table* (make-hash-table))) (call-next-method obj)))) (defmethod replicate ((obj cons)) (or (gethash obj *replicate-table*) (let ((x (cons nil nil))) (setf (gethash obj *replicate-table*) x) (setf (car x) (replicate (car obj))) (setf (cdr x) (replicate (cdr obj))) x))) ;;; Default method for objects without internal structure (defmethod replicate ((obj t)) obj) (defmethod replicate ((obj array)) (multiple-value-bind (new-obj old-leaf new-leaf) (replicate-displaced-array obj) (when new-leaf (loop for i below (array-total-size new-leaf) do (setf (row-major-aref new-leaf i) (row-major-aref old-leaf i)))) new-obj)) (defun replicate-displaced-array (obj) "Replicate the non-terminal (and not already replicated) arrays in a displaced array chain. Return the new root array, the old leaf array, and the new (but empty) leaf array. The latter two are NIL if the leaf did not have to be copied again." (or (gethash obj *replicate-table*) (multiple-value-bind (displaced-to displaced-index-offset) (array-displacement obj) (let ((dims (array-dimensions obj)) (element-type (array-element-type obj)) (fill-pointer (and (array-has-fill-pointer-p obj) (fill-pointer obj))) (adj (adjustable-array-p obj))) (if displaced-to ;; The array is displaced ;; Copy recursively (multiple-value-bind (new-displaced-to old-leaf new-leaf) (replicate-displaced-array displaced-to) (let ((new-obj (make-array dims :element-type element-type :fill-pointer fill-pointer :adjustable adj :displaced-to new-displaced-to :displaced-index-offset displaced-index-offset))) (setf (gethash obj *replicate-table*) new-obj) (values new-obj old-leaf new-leaf))) ;; The array is not displaced ;; This is the leaf array (let ((new-obj (make-array dims :element-type element-type :fill-pointer fill-pointer :adjustable adj))) (setf (gethash obj *replicate-table*) new-obj) (values new-obj obj new-obj))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declaim (special *isomorphism-table*)) (defun isomorphic-p (obj1 obj2) (let ((*isomorphism-table* (make-hash-table))) (isomorphic-p* obj1 obj2))) (defgeneric isomorphic-p* (obj1 obj2) (:documentation "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure, including the same leaf values and the same pattern of sharing). It should be the case that (isomorphic-p obj (replicate obj)) is true.")) (defmethod isomorphic-p* ((obj1 t) (obj2 t)) (eql obj1 obj2)) (defmethod isomorphic-p* ((obj1 cons) (obj2 cons)) (let ((previous (gethash obj1 *isomorphism-table*))) (cond (previous ;; If we've already produced a mapping from obj1 to something, ;; isomorphism requires that obj2 be that object (eq previous obj2)) ;; Otherwise, assume obj1 will map to obj2 and recurse (t (setf (gethash obj1 *isomorphism-table*) obj2) (and (isomorphic-p* (car obj1) (car obj2)) (isomorphic-p* (cdr obj1) (cdr obj2))))))) (defmethod isomorphic-p* ((obj1 array) (obj2 array)) (let ((previous (gethash obj1 *isomorphism-table*))) (cond (previous ;; If we've already produced a mapping from obj1 to something, ;; isomorphism requires that obj2 be that object (eq previous obj2)) (t (setf (gethash obj1 *isomorphism-table*) obj2) (and (equal (array-dimensions obj1) (array-dimensions obj2)) (equal (array-element-type obj1) (array-element-type obj2)) (if (array-has-fill-pointer-p obj1) (and (array-has-fill-pointer-p obj2) (eql (fill-pointer obj1) (fill-pointer obj2))) (not (array-has-fill-pointer-p obj2))) (let (to-1 (index-1 0) to-2 (index-2 0)) (multiple-value-setq (to-1 index-1) (array-displacement obj1)) (multiple-value-setq (to-2 index-2) (array-displacement obj2)) (if to-1 (and to-2 (eql index-1 index-2) (isomorphic-p* to-1 to-2)) ;; Not displaced -- recurse on elements (let ((total-size (array-total-size obj1))) (loop for i below total-size always (isomorphic-p* (row-major-aref obj1 i) (row-major-aref obj2 i))))))))))) ;;; Test that sequences have identical elements (defun equalp-and-eql-elements (s1 s2) (and (equalp s1 s2) (every #'eql s1 s2))) gcl-2.7.1/ansi-tests/PaxHeaders/packages-04.lsp0000644000000000000000000000013114542551763016170 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.377788678 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-04.lsp0000644000175000017500000000263614542551763015576 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/bit-nand.lsp0000644000000000000000000000013014542551762015663 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.377788678 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-nand.lsp0000644000175000017500000001541514542551762015271 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:16:15 2003 ;;;; Contains: Tests for BIT-NAND (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-nand (expand-in-current-env (%m #*0011)) #*0101)) #*1110) (deftest bit-nand.21 (macrolet ((%m (z) z)) (bit-nand #*1010 (expand-in-current-env (%m #*1100)))) #*0111) (deftest bit-nand.22 (macrolet ((%m (z) z)) (bit-nand #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*11011101) (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) (def-fold-test bit-nand.fold.1 (bit-nand #*00101 #*10100)) ;;; Random tests (deftest bit-nand.random.1 (bit-random-test-fn #'bit-nand #'lognand) nil) ;;; Error tests (deftest bit-nand.error.1 (signals-error (bit-nand) program-error) t) (deftest bit-nand.error.2 (signals-error (bit-nand #*000) program-error) t) (deftest bit-nand.error.3 (signals-error (bit-nand #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cl-test-package.lsp0000644000000000000000000000013014542551762017133 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.377788678 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cl-test-package.lsp0000644000175000017500000000130214542551762016527 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 14 10:13:21 1998 ;;;; Contains: CL test case package definition (let* ((name :cl-test) (pkg (find-package name))) (unless pkg (setq pkg (make-package name :use '(:cl :regression-test)))) (let ((*package* pkg)) (shadow '(#:handler-case #:handler-bind)) (import '(common-lisp-user::compile-and-load) pkg) (export (mapcar #'intern (mapcar #'symbol-name '(#:random-from-seq #:random-case #:coin #:random-permute #:*universe* #:*mini-universe* #:*cl-symbols* #:signals-error #:typef))))) (let ((s (find-symbol "QUIT" "CL-USER"))) (when s (import s :cl-test)))) gcl-2.7.1/ansi-tests/PaxHeaders/parse-namestring.lsp0000644000000000000000000000013114542551763017450 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.377788678 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/parse-namestring.lsp0000644000175000017500000000475314542551763017060 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/dotimes.lsp0000644000000000000000000000013214542551762015635 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.377788678 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/dotimes.lsp0000644000175000017500000000767714542551762015254 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:27:15 2005 ;;;; Contains: Tests of DOTIMES (in-package :cl-test) (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 (block done (dotimes (i -1 'good) (return-from done 'bad))) good) (deftest dotimes.7 (block done (dotimes (i (1- most-negative-fixnum) 'good) (return-from done 'bad))) good) ;;; 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.17a (let ((i 0) (y nil) (bound 4)) (declare (special i)) (flet ((%f () i)) (dotimes (i bound) (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)) (deftest dotimes.18a (let ((i 0) (y nil) (bound 4)) (declare (special i)) (flet ((%f () i)) (dotimes (i bound) (declare (special i)) (push (%f) y))) y) (3 2 1 0)) (deftest dotimes.19 (dotimes (i 100 i)) 100) (deftest dotimes.20 (dotimes (i -100 i)) 0) (deftest dotimes.21 (let ((x 0)) (dotimes (i (1- most-negative-fixnum) (values i x)) (declare (type fixnum i)) (incf x))) 0 0) ;;; Scope of free declarations (deftest dotimes.22 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (dotimes (i (return-from done x)) (declare (special x)))))) :good) (deftest dotimes.23 (let ((x :good)) (declare (special x)) (let ((x :bad)) (dotimes (i 10 x) (declare (special x))))) :good) (deftest dotimes.23a (let ((x :good) (bound 10)) (declare (special x)) (let ((x :bad)) (dotimes (i bound x) (declare (special x))))) :good) (deftest dotimes.24 (let ((bound 4) (j 0)) (values (dotimes (i bound) (incf j) (decf bound)) bound j)) nil 0 4) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest dotimes.25 (macrolet ((%m (z) z)) (let (result) (dotimes (i (expand-in-current-env (%m 4)) result) (push i result)))) (3 2 1 0)) (deftest dotimes.26 (macrolet ((%m (z) z)) (let (result) (dotimes (i 4 (expand-in-current-env (%m result))) (push i result)))) (3 2 1 0)) (def-macro-test dotimes.error.1 (dotimes (i 10))) gcl-2.7.1/ansi-tests/PaxHeaders/subst-if-not.lsp0000644000000000000000000000013114542551763016523 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.381788696 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subst-if-not.lsp0000644000175000017500000000553614542551763016133 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:48:22 2003 ;;;; Contains: Tests of SUBST-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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-not.2 (check-subst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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-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-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-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) (def-fold-test subst-if-not.fold.1 (subst-if-not 'a #'consp '((1 . 2) 3 . 4))) ;;; 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) ;;; error cases (deftest subst-if-not.error.1 (signals-error (subst-if-not) program-error) t) (deftest subst-if-not.error.2 (signals-error (subst-if-not 'a) program-error) t) (deftest subst-if-not.error.3 (signals-error (subst-if-not 'a #'null) program-error) t) (deftest subst-if-not.error.4 (signals-error (subst-if-not 'a #'null nil :foo nil) program-error) t) (deftest subst-if-not.error.5 (signals-error (subst-if-not 'a #'null nil :test) program-error) t) (deftest subst-if-not.error.6 (signals-error (subst-if-not 'a #'null nil 1) program-error) t) (deftest subst-if-not.error.7 (signals-error (subst-if-not 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest subst-if-not.error.8 (signals-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/print-level.lsp0000644000000000000000000000013114542551763016432 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.381788696 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-level.lsp0000644000175000017500000000654514542551763016043 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 26 13:07:51 2004 ;;;; Contains: Tests of binding the *PRINT-LEVEL* variable (in-package :cl-test) (compile-and-load "printer-aux.lsp") #| (deftest print-level.1 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for x in *mini-universe* for s1 = (write-to-string x) for s2 = (let ((*print-level* 0)) (write-to-string x)) when (and (or (consp x) (and (arrayp x) (not (stringp x)) (not (typep x 'bit-vector))) (typep (class-of x) 'structure-class)) (not (string= s2 "#"))) collect (list x s1 s2)))) nil) |# (defclass print-level-test-class nil (a b c)) ;;; The CLHS page for PRINT-OBJECT makes it clear that tests ;;; PRINT-LEVEL.2,6,7,10,11 were testing for implementation-dependent ;;; behavior. They have been commented out. #| (deftest print-level.2 (with-standard-io-syntax (write-to-string (make-instance 'print-level-test-class) :level 0 :readably nil)) "#") |# (deftest print-level.3 (with-standard-io-syntax (write-to-string (make-array '(4) :initial-contents '(a b c d)) :readably nil :array t :level 0)) "#") (deftest print-level.4 (with-standard-io-syntax (write-to-string (make-array '(4) :initial-contents '(1 1 0 1) :element-type 'bit) :readably nil :array t :level 0)) "#*1101") (deftest print-level.5 (with-standard-io-syntax (write-to-string "abcd" :readably nil :array t :level 0)) "\"abcd\"") (define-condition print-level-condition (condition) (a b c)) #| (deftest print-level.6 (with-standard-io-syntax (write-to-string (make-condition 'print-level-condition) :level 0 :pretty nil :readably nil)) "#") (deftest print-level.7 (with-standard-io-syntax (write-to-string (make-condition 'print-level-condition) :level 0 :pretty t :readably nil)) "#") |# (defstruct print-level-struct) (deftest print-level.8 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) (*print-pretty* nil) (s (make-print-level-struct))) (values (write-to-string s :level 0 :readably nil) (write-to-string s :level 1 :readably nil) (write-to-string s :level nil :readably nil)))) "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)") (deftest print-level.9 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) (*print-pretty* t) (s (make-print-level-struct))) (values (write-to-string s :level 0 :readably nil) (write-to-string s :level 1 :readably nil) (write-to-string s :level nil :readably nil)))) "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)" "#S(PRINT-LEVEL-STRUCT)") (defstruct print-level-struct2 a b c) #| (deftest print-level.10 (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string (make-print-level-struct2) :level 0 :pretty nil :readably nil))) "#") (deftest print-level.11 (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string (make-print-level-struct2) :level 0 :pretty t :readably nil))) "#") |# (deftest print-level.12 (with-standard-io-syntax (let ((*print-level* (1+ most-positive-fixnum))) (write-to-string '((1 2) (3 4)) :pretty nil :readably nil))) "((1 2) (3 4))") gcl-2.7.1/ansi-tests/PaxHeaders/rassoc-if.lsp0000644000000000000000000000013114542551763016057 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.381788696 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rassoc-if.lsp0000644000175000017500000000670014542551763015461 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:34:59 2003 ;;;; Contains: Tests of RASSOC-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (rassoc-if) program-error) t) (deftest rassoc-if.error.2 (signals-error (rassoc-if #'null) program-error) t) (deftest rassoc-if.error.3 (signals-error (rassoc-if #'null nil :bad t) program-error) t) (deftest rassoc-if.error.4 (signals-error (rassoc-if #'null nil :key) program-error) t) (deftest rassoc-if.error.5 (signals-error (rassoc-if #'null nil 1 1) program-error) t) (deftest rassoc-if.error.6 (signals-error (rassoc-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest rassoc-if.error.7 (signals-error (rassoc-if #'cons '((a . b)(c . d))) program-error) t) (deftest rassoc-if.error.8 (signals-error (rassoc-if #'car '((a . b)(c . d))) type-error) t) (deftest rassoc-if.error.9 (signals-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons) program-error) t) (deftest rassoc-if.error.10 (signals-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car) type-error) t) (deftest rassoc-if.error.11 (signals-error (rassoc-if #'not '((a . b) . c)) type-error) t) (deftest rassoc-if.error.12 (check-type-error #'(lambda (x) (rassoc-if #'identity x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/string-aux.lsp0000644000000000000000000000013214542551763016273 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.381788696 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-aux.lsp0000644000175000017500000001117214542551763015673 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:51:32 2002 ;;;; Contains: Auxiliary functions for string testing (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) (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 (my-aref string1 i1)) (c2 (my-aref 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)) ;; Maximum 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)))) (s1 (make-random-string len1)) (s2 (make-random-string len2)) ;; Actual lengths of the strings (len1 (length s1)) (len2 (length s2)) ;; 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)) ) #| (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 (and (coin) (equal (array-element-type s1) (array-element-type s2))) (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 "Strings: ~s ~s - Args = ~S~%" s1 s2 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 string-all-the-same (s) (let ((len (length s))) (or (= len 0) (let ((c (my-aref s 0))) (loop for i below len for d = (my-aref s i) always (eql c d)))))) gcl-2.7.1/ansi-tests/PaxHeaders/conjugate.lsp0000644000000000000000000000013014542551762016146 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.381788696 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/conjugate.lsp0000644000175000017500000000257714542551762015561 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 21:07:36 2003 ;;;; Contains: Tests of CONJUGATE (in-package :cl-test) ;;; Error tests (deftest conjugate.error.1 (signals-error (conjugate) program-error) t) (deftest conjugate.error.2 (signals-error (conjugate 0 0) program-error) t) ;;; Non-error tests (deftest conjugate.1 (loop for x in *reals* for vals = (multiple-value-list (conjugate x)) for xc = (car vals) always (and (= (length vals) 1) (eql x xc))) t) (deftest conjugate.2 (loop for x in *complexes* for vals = (multiple-value-list (conjugate x)) for xc = (car vals) always (and (= (length vals) 1) (eql (realpart x) (realpart xc)) (eql (- (imagpart x)) (imagpart xc)))) t) (deftest conjugate.3 (eqlt (conjugate #c(0.0s0 0.0s0)) #c(0.0s0 -0.0s0)) t) (deftest conjugate.4 (eqlt (conjugate #c(1.0s0 0.0s0)) #c(1.0s0 -0.0s0)) t) (deftest conjugate.5 (eqlt (conjugate #c(0.0f0 0.0f0)) #c(0.0f0 -0.0f0)) t) (deftest conjugate.6 (eqlt (conjugate #c(1.0f0 0.0f0)) #c(1.0f0 -0.0f0)) t) (deftest conjugate.7 (eqlt (conjugate #c(0.0d0 0.0d0)) #c(0.0d0 -0.0d0)) t) (deftest conjugate.8 (eqlt (conjugate #c(1.0d0 0.0d0)) #c(1.0d0 -0.0d0)) t) (deftest conjugate.9 (eqlt (conjugate #c(0.0l0 0.0l0)) #c(0.0l0 -0.0l0)) t) (deftest conjugate.10 (eqlt (conjugate #c(1.0l0 0.0l0)) #c(1.0l0 -0.0l0)) t) gcl-2.7.1/ansi-tests/PaxHeaders/declaim.lsp0000644000000000000000000000013214542551762015567 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.381788696 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/declaim.lsp0000644000175000017500000000207714542551762015173 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 07:44:07 2005 ;;;; Contains: Tests of DECLAIM (in-package :cl-test) (deftest declaim.1 (progn (declaim) nil) nil) (deftest declaim.2 (progn (eval `(declaim (optimize))) nil) nil) (deftest declaim.3 (progn (eval `(declaim (inline))) nil) nil) (deftest declaim.4 (progn (eval `(declaim (notinline))) nil) nil) (deftest declaim.5 (progn (eval `(declaim (type t))) nil) nil) (deftest declaim.6 (progn (eval `(declaim (special))) nil) nil) (deftest declaim.7 (progn (eval `(declaim (integer))) nil) nil) (deftest declaim.8 (progn (eval `(declaim (declaration))) nil) nil) (deftest declaim.9 (progn (eval `(declaim (ftype (function (t) t)))) nil) nil) (deftest declaim.10 (let ((sym (gensym))) (eval `(declaim (declaration ,sym))) (eval `(declaim (,sym))) nil) nil) (deftest declaim.11 (let ((sym (gensym))) (eval `(declaim (optimize) (special ,sym) (inline) (special))) (eval `(flet ((%f () ,sym)) (let ((,sym :good)) (%f))))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/hash-table-count.lsp0000644000000000000000000000013114542551762017326 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.381788696 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table-count.lsp0000644000175000017500000000300114542551762016717 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:14:25 2003 ;;;; Contains: Tests of HASH-TABLE-COUNT (in-package :cl-test) (deftest hash-table-count.1 (hash-table-count (make-hash-table)) 0) (deftest hash-table-count.2 (hash-table-count (make-hash-table :test 'eq)) 0) (deftest hash-table-count.3 (hash-table-count (make-hash-table :test 'eql)) 0) (deftest hash-table-count.4 (hash-table-count (make-hash-table :test 'equal)) 0) (deftest hash-table-count.5 (hash-table-count (make-hash-table :test 'equalp)) 0) (deftest hash-table-count.6 (hash-table-count (make-hash-table :test #'eq)) 0) (deftest hash-table-count.7 (hash-table-count (make-hash-table :test #'eql)) 0) (deftest hash-table-count.8 (hash-table-count (make-hash-table :test #'equal)) 0) (deftest hash-table-count.9 (hash-table-count (make-hash-table :test #'equalp)) 0) (deftest hash-table-count.10 (hash-table-count (let ((table (make-hash-table))) (setf (gethash 'x table) 1) table)) 1) (deftest hash-table-count.11 (let ((table (make-hash-table))) (setf (gethash 'x table) 1) (values (hash-table-count table) (progn (remhash 'x table) (hash-table-count table)))) 1 0) ;; This function is mostly tested by calls to test-hash-table-1 (deftest hash-table-count.error.1 (signals-error (hash-table-count) program-error) t) (deftest hash-table-count.error.2 (signals-error (hash-table-count (make-hash-table) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-types-and-class.lsp0000644000000000000000000000013214772071561020114 xustar0030 mtime=1743287153.570909322 30 atime=1744294960.381788696 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-types-and-class.lsp0000644000175000017500000000107214772071561017512 0ustar00cammcamm;;; 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") (load "subtypep-function.lsp") (load "subtypep-complex.lsp") (load "deftype.lsp") (load "standard-generic-function.lsp") (load "type-of.lsp") (load "typep.lsp") (load "class-precedence-lists.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/slot-makunbound.lsp0000644000000000000000000000013214542551763017314 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.381788696 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/slot-makunbound.lsp0000644000175000017500000000437314542551763016721 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 10 14:39:01 2003 ;;;; Contains: Tests for SLOT-MAKUNBOUND (in-package :cl-test) ;;; This function is heavily tested in other files as well (defclass slot-makunbound-class-01 () (a (b :allocation :instance) (c :allocation :class) (d :type fixnum) (e :type t) (f :type cons))) (deftest slot-makunbound.1 (loop for slot-name in '(a b c d e) unless (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) (and (equalt (multiple-value-list (slot-makunbound obj slot-name)) (list obj)) (not (slot-boundp obj slot-name)))) collect slot-name) nil) (deftest slot-makunbound.2 (loop for slot-name in '(a b c d e) for slot-value in '(t t t 10 t '(a)) unless (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) (setf (slot-value obj slot-name) slot-value) (and (equalt (multiple-value-list (slot-makunbound obj slot-name)) (list obj)) (not (slot-boundp obj slot-name)))) collect slot-name) nil) ;;; Order of evaluation test(s) (deftest slot-makunbound.order.1 (let ((obj (make-instance 'slot-makunbound-class-01)) (i 0) x y) (values (eqt (slot-makunbound (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) obj) i x y)) t 2 1 2) (deftest slot-makunbound.order.2 (let ((obj (make-instance 'slot-makunbound-class-01)) (i 0) x y) (setf (slot-value obj 'a) t) (values (eqt (slot-makunbound (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) obj) i x y)) t 2 1 2) ;;; Error cases (deftest slot-makunbound.error.1 (signals-error (slot-makunbound) program-error) t) (deftest slot-makunbound.error.2 (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01)) program-error) t) (deftest slot-makunbound.error.3 (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01) 'a nil) program-error) t) (deftest slot-makunbound.error.4 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (slot-makunbound e 'foo) t) (error () nil))) collect e)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/ftruncate-aux.lsp0000644000000000000000000000013214542551762016757 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.381788696 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ftruncate-aux.lsp0000644000175000017500000000104114542551762016351 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:37:01 2003 ;;;; Contains: Aux. functions for testing FTRUNCATE (in-package :cl-test) (defun ftruncate.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (ftruncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (if (>= n 0) (< -1 r d) (< -1 (- r) d))) collect (list n d q r n2))) gcl-2.7.1/ansi-tests/PaxHeaders/print-lines.lsp0000644000000000000000000000013114542551763016435 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.381788696 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-lines.lsp0000644000175000017500000000151114542551763016032 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 09:32:46 2004 ;;;; Contains: Tests involving PRINT-LINES (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print-lines.1 *print-lines* nil) (deftest print-lines.2 (with-standard-io-syntax (let ((*print-lines* 1) (*print-readably* nil) (*print-miser-width* nil) (*print-pprint-dispatch* (copy-pprint-dispatch))) (set-pprint-dispatch '(cons (eql 1) t) 'pprint-fill) (apply #'values (loop for i from 1 to 10 collect (let ((*print-right-margin* i)) (subseq (with-output-to-string (*standard-output*) (terpri) (pprint '(1 2 3 4 5 6 7 8 9))) 2)))))) "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 ..)" "(1 2 ..)" "(1 2 ..)" "(1 2 3 ..)") gcl-2.7.1/ansi-tests/PaxHeaders/rt.system0000644000000000000000000000013214542551763015345 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.381788696 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rt.system0000644000175000017500000000125014542551763014741 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/division-aux.lsp0000644000000000000000000000013214542551762016610 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.381788696 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/division-aux.lsp0000644000175000017500000000046414542551762016212 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 07:57:02 2003 ;;;; Contains: Aux. functions for testing / (in-package :cl-test) (defun divide-by-zero-test (&rest args) (handler-case (progn (apply #'/ args) (values)) (division-by-zero () (values)) (condition (c) c))) gcl-2.7.1/ansi-tests/PaxHeaders/gclload.lsp0000644000000000000000000000013214772071543015575 xustar0030 mtime=1743287139.734896413 30 atime=1744294960.389788731 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/gclload.lsp0000644000175000017500000000261014772071543015172 0ustar00cammcamm;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (setq *enclose-printer-errors* nil) ;;; Remove compiled files (let* ((fn (compile-file-pathname "doit.lsp")) (type (pathname-type fn)) (dir-pathname (make-pathname :name :wild :type type)) (files (directory dir-pathname))) (assert type) (assert (not (string-equal type "lsp"))) (mapc #'delete-file files)) #+(and gcl x86_64)(si::set-log-maxpage-bound 30) (load "gclload1.lsp") (load "gclload2.lsp") #+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) ;#+gcl(si::use-fast-links nil) (in-package :cl-test) ;;; These two tests will misbehave if the tests are being ;;; invoked from a file that is being loaded, so remove them (when *load-pathname* (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) ;#+gcl(fpe::break-on-floating-point-exceptions :division-by-zero t :floating-point-overflow t :floating-point-underflow t) (time (regression-test:do-tests)) gcl-2.7.1/ansi-tests/PaxHeaders/package-error-package.lsp0000644000000000000000000000013114542551763020304 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.389788731 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-error-package.lsp0000644000175000017500000000217514542551763017710 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:52:56 2004 ;;;; Contains: Tests of PACKAGE-ERROR-PACKAGE (in-package :cl-test) (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 (signals-error (package-error-package) program-error) t) (deftest package-error-package.error.2 (signals-error (package-error-package (make-condition 'package-error :package #\A) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-or.lsp0000644000000000000000000000013214542551762022460 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.389788731 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-or.lsp0000644000175000017500000001326314542551762022063 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination OR (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.or.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.or.1 (x) (:method-combination or) (:method or ((x integer)) (push 4 *x*) nil) (:method or ((x rational)) (push 3 *x*) nil) (:method or ((x number)) (push 2 *x*) nil) (:method or ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (1 2 3 4)) (a (1 2 3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.or.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.or.2 (x) (:method-combination or :most-specific-first) (:method or ((x integer)) (push 4 *x*) nil) (:method or ((x rational)) (push 3 *x*) 'a) (:method or ((x number)) (push 2 *x*) nil) (:method or ((x t)) (push 1 *x*) 'b))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (3 4)) (a (3)) (b (1 2)) (b (1))) (deftest defgeneric-method-combination.or.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.or.3 (x) (:method-combination or :most-specific-last) (:method or ((x integer)) (push 4 *x*) 'a) (:method or ((x rational)) (push 3 *x*) nil) (:method or ((x number)) (push 2 *x*) nil) (:method or ((x t)) (push 1 *x*) nil))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (4 3 2 1)) (nil (3 2 1)) (nil (2 1)) (nil (1))) (deftest defgeneric-method-combination.or.4 (let ((fn (eval '(defgeneric dg-mc.or.4 (x) (:method-combination or) (:method or ((x integer)) nil) (:method :around ((x rational)) 'foo) (:method or ((x number)) 'b) (:method or ((x symbol)) nil) (:method or ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo b a a) (deftest defgeneric-method-combination.or.5 (let ((fn (eval '(defgeneric dg-mc.or.5 (x) (:method-combination or) (:method or ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method or ((x number)) nil) (:method or ((x symbol)) 'b) (:method or ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo a) (foo c) c b c) (deftest defgeneric-method-combination.or.6 (let ((fn (eval '(defgeneric dg-mc.or.6 (x) (:method-combination or) (:method or ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method or ((x number)) 'b) (:method or ((x symbol)) 'c) (:method or ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar a)) (foo (bar b)) (bar b) b c d) (deftest defgeneric-method-combination.or.7 (let ((fn (eval '(defgeneric dg-mc.or.7 (x) (:method-combination or) (:method or ((x dgmc-class-04)) nil) (:method or ((x dgmc-class-03)) nil) (:method or ((x dgmc-class-02)) 'b) (:method or ((x dgmc-class-01)) 'c))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) c b c b) (deftest defgeneric-method-combination.or.8 (let ((fn (eval '(defgeneric dg-mc.or.8 (x) (:method-combination or) (:method or ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method or ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (b)) (deftest defgeneric-method-combination.or.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.or.9 (x) (:method-combination or))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.or.10 (progn (eval '(defgeneric dg-mc.or.10 (x) (:method-combination or) (:method ((x t)) 0))) (handler-case (dg-mc.or.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.or.11 (progn (eval '(defgeneric dg-mc.or.11 (x) (:method-combination or) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.or.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.or.12 (let ((fn (eval '(defgeneric dg-mc.or.12 (x) (:method-combination or) (:method :around ((x t)) t) (:method or ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/get-properties.lsp0000644000000000000000000000013114542551762017141 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.393788749 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/get-properties.lsp0000644000175000017500000000446014542551762016544 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:37:00 2003 ;;;; Contains: Tests of GET-PROPERTIES (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;;; I removed the next test (noticed by Duane Rettig) because ;;; the non-eqness of numbers may not be necesarily preserved. ;;; The standard says numbers may be copied at any time, and ;;; this might mean eql numbers are copied to a canonical eq ;;; value #| (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 (signals-error (get-properties) program-error) t) (deftest get-properties.error.2 (signals-error (get-properties nil) program-error) t) (deftest get-properties.error.3 (signals-error (get-properties nil nil nil) program-error) t) (deftest get-properties.error.4 (signals-error (get-properties '(a 1 b 2 c 3) '(x . y)) type-error) t) (deftest get-properties.error.5 (signals-error (get-properties '(a 1 b 2 c 3 . d) '(x y)) type-error) t) (deftest get-properties.error.6 (signals-error (get-properties '(a 1 b 2 c . d) '(x y)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/sleep.lsp0000644000000000000000000000013214542551763015302 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.393788749 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sleep.lsp0000644000175000017500000000207714542551763014706 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 19:53:39 2005 ;;;; Contains: Tests of SLEEP (in-package :cl-test) (deftest sleep.1 (sleep 0) nil) (deftest sleep.2 (sleep 0.0s0) nil) (deftest sleep.3 (sleep 0.0f0) nil) (deftest sleep.4 (sleep 0.0d0) nil) (deftest sleep.5 (sleep 0.0l0) nil) (deftest sleep.6 (sleep 1.0f-8) nil) (deftest sleep.7 (sleep 1/100) nil) (deftest sleep.8 (sleep (/ internal-time-units-per-second)) nil) (deftest sleep.9 (sleep (/ 1000000000000000000000000000000)) nil) (deftest sleep.10 (sleep least-positive-short-float) nil) (deftest sleep.11 (sleep least-positive-single-float) nil) (deftest sleep.12 (sleep least-positive-double-float) nil) (deftest sleep.13 (sleep least-positive-long-float) nil) ;;; Error cases (deftest sleep.error.1 (signals-error (sleep) program-error) t) (deftest sleep.error.2 (signals-error (sleep 100 nil) program-error) t) (deftest sleep.error.3 (check-type-error #'sleep #'(lambda (x) (and (realp x) (>= x 0)))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/print-bit-vector.lsp0000644000000000000000000000013114542551763017401 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.393788749 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-bit-vector.lsp0000644000175000017500000000326514542551763017006 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 20 22:10:53 2004 ;;;; Contains: Tests for printing of bit vectors (compile-and-load "printer-aux.lsp") (in-package :cl-test) (deftest print.bit-vector.1 (with-standard-io-syntax (write-to-string #* :readably nil :escape nil)) "#*") (deftest print.bit-vector.2 (with-standard-io-syntax (subseq (write-to-string #* :readably nil :escape nil :array nil) 0 2)) "#<") (deftest print.bit-vector.3 (with-standard-io-syntax (write-to-string #*001101010011011 :readably nil :escape nil)) "#*001101010011011") (deftest print.bit-vector.4 (with-standard-io-syntax (subseq (write-to-string #*11010011010110101 :readably nil :escape nil :array nil) 0 2)) "#<") (deftest print.bit-vector.5 (let* ((bv1 #*0001100101) (bv2 (make-array 5 :displaced-to bv1 :displaced-index-offset 1 :element-type 'bit))) (with-standard-io-syntax (write-to-string bv2 :readably nil :escape nil))) "#*00110") (deftest print.bit-vector.6 (let* ((bv (make-array 10 :element-type 'bit :initial-contents '(1 0 0 1 0 0 1 1 1 0) :fill-pointer 5))) (with-standard-io-syntax (write-to-string bv :readably nil :escape nil))) "#*10010") (deftest print.bit-vector.7 (let* ((bv (make-array 10 :element-type 'bit :initial-contents '(1 0 0 1 0 0 1 1 1 0) :adjustable t))) (with-standard-io-syntax (write-to-string bv :readably nil :escape nil))) "#*1001001110") (deftest print.bit-vector.random (loop for len = (random 100) for bv = (coerce (loop repeat len collect (random 2)) 'bit-vector) repeat 1000 nconc (randomly-check-readability bv)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/defclass-03.lsp0000644000000000000000000000013214542551762016175 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.393788749 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defclass-03.lsp0000644000175000017500000001467514542551762015610 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 27 16:23:59 2003 ;;;; Contains: Tests of DEFCLASS with more involved inheritance (in-package :cl-test) ;;; (defclass class-0301a () (a b)) (defclass class-0301b () (a c)) (defclass class-0301c (class-0301a class-0301b) (d)) (deftest class-0301.1 (let ((c (make-instance 'class-0301c))) (values (typep* c 'class-0301a) (typep* c 'class-0301b) (typep* c 'class-0301c) (typep* c (find-class 'class-0301a)) (typep* c (find-class 'class-0301b)) (typep* c (find-class 'class-0301c)) (map-slot-boundp* c '(a b c d)) (setf (slot-value c 'a) 'w) (setf (slot-value c 'b) 'x) (setf (slot-value c 'c) 'y) (setf (slot-value c 'd) 'z) (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c d)))) t t t t t t (nil nil nil nil) w x y z (t t t t) (w x y z)) ;;; (defclass class-0302a () ((a :initform 'x) b (c :initform 'w))) (defclass class-0302b () ((a :initform 'y) (b :initform 'z))) (defclass class-0302c (class-0302a class-0302b) (a b (c :initform 'v) d)) (deftest class-0302.1 (let ((c (make-instance 'class-0302c))) (values (map-slot-boundp* c '(a b c d)) (map-slot-value c '(a b c)))) (t t t nil) (x z v)) ;;; (defclass class-0303a () ((a :allocation :class) b)) (defclass class-0303b () (a (b :allocation :class))) (defclass class-0303c (class-0303a class-0303b) ()) (deftest class-0303.1 (let ((c1 (make-instance 'class-0303a)) (c2 (make-instance 'class-0303b)) (c3 (make-instance 'class-0303c))) (slot-makunbound c1 'a) (slot-makunbound c2 'b) (values (loop for c in (list c1 c2 c3) collect (map-slot-boundp* c '(a b))) (list (setf (slot-value c1 'a) 'x1) (slot-boundp* c2 'a) (slot-value c3 'a)) (list (setf (slot-value c2 'a) 'x2) (slot-value c1 'a) (slot-value c2 'a) (slot-value c3 'a)) (list (setf (slot-value c3 'a) 'x3) (slot-value c1 'a) (slot-value c2 'a) (slot-value c3 'a)) ;;; (list (setf (slot-value c1 'b) 'y1) (slot-value c1 'b) (slot-boundp* c2 'b) (slot-boundp* c3 'b)) (list (setf (slot-value c2 'b) 'y2) (slot-value c1 'b) (slot-value c2 'b) (slot-boundp c3 'b)) (list (setf (slot-value c3 'b) 'y3) (slot-value c1 'b) (slot-value c2 'b) (slot-value c3 'b)))) ((nil nil) (nil nil) (nil nil)) (x1 nil x1) (x2 x1 x2 x1) (x3 x3 x2 x3) ;; (y1 y1 nil nil) (y2 y1 y2 nil) (y3 y1 y2 y3)) ;;; (defclass class-0304a () ((a :initform 'x))) (defclass class-0304b (class-0304a) ()) (defclass class-0304c (class-0304a) ((a :initform 'y))) (defclass class-0304d (class-0304b class-0304c) ()) (deftest class-0304.1 (slot-value (make-instance 'class-0304d) 'a) y) ;;; (defclass class-0305a () ((a :initarg :a)) (:default-initargs :a 'x)) (defclass class-0305b (class-0305a) ()) (defclass class-0305c (class-0305a) () (:default-initargs :a 'y)) (defclass class-0305d (class-0305b class-0305c) ()) (deftest class-0305.1 (slot-value (make-instance 'class-0305d) 'a) y) ;;; A test showing nonmonotonicity in the CLOS CPL algorithm (defclass class-0306a () ((a :initform nil :reader a-slot))) (defclass class-0306b (class-0306a) ((a :initform 'x))) (defclass class-0306c (class-0306a) ((a :initform 'y))) (defclass class-0306d (class-0306b) ()) (defclass class-0306e (class-0306b) ()) (defclass class-0306f (class-0306d class-0306c) ()) (defclass class-0306g (class-0306e) ()) (defclass class-0306h (class-0306f class-0306g) ()) ;;; Class class-0306c should precede class-0306b in the ;;; CPL for class-0306h, even though it follows it in the CPLs ;;; for the direct superclasses of class-0306h. (deftest class-0306.1 (loop for obj in (mapcar #'make-instance '(class-0306a class-0306b class-0306c class-0306d class-0306e class-0306f class-0306g class-0306h)) collect (slot-value obj 'a)) (nil x y x x x x y)) (deftest class-0306.2 (loop for obj in (mapcar #'make-instance '(class-0306a class-0306b class-0306c class-0306d class-0306e class-0306f class-0306g class-0306h)) collect (a-slot obj)) (nil x y x x x x y)) ;;; A class redefinition test that came up in cmucl (deftest class-0307.1 (progn (setf (find-class 'class-0307a) nil (find-class 'class-0307b) nil) (eval '(defclass class-0307a () ())) (eval '(defclass class-0307b (class-0307a) (a))) (eval '(defclass class-0307a () ((a :initform nil)))) (eval '(defclass class-0307b (class-0307a) ((a :initform 'x)))) (slot-value (make-instance 'class-0307b) 'a)) x) (deftest class-0308.1 (progn (setf (find-class 'class-0308a) nil (find-class 'class-0308b) nil) (eval '(defclass class-0308a () ())) (eval '(defclass class-0308b (class-0308a) (a))) (eval '(defclass class-0308a () ((a :initarg :a)))) (eval '(defclass class-0308b (class-0308a) ())) (slot-value (make-instance 'class-0308b :a 'x) 'a)) x) ;;; More class redefinition tests (deftest class-0309.1 (progn (setf (find-class 'class-0309) nil) (let* ((class1 (eval '(defclass class-0309 () ((a) (b) (c))))) (obj1 (make-instance 'class-0309))) (setf (class-name class1) nil) (let ((class2 (eval '(defclass class-0309 () ((a) (b) (c)))))) (values (eqt (class-of obj1) class1) (eqt class1 class2) (typep* obj1 class1) (typep* obj1 class2))))) t nil t nil) (deftest class-0310.1 (progn (setf (find-class 'class-0310a) nil (find-class 'class-0310b) nil) (let* ((class1 (eval '(defclass class-0310a () ((a) (b) (c))))) (obj1 (make-instance 'class-0310a))) (setf (class-name class1) 'class-0310b) (let ((class2 (eval '(defclass class-0310a () ((a) (b) (c)))))) (values (eqt (class-of obj1) class1) (eqt class1 class2) (typep* obj1 class1) (typep* obj1 class2) (class-name class1) (class-name class2))))) t nil t nil class-0310b class-0310a) (deftest class-0311.1 (progn (setf (find-class 'class-0311) nil) (let* ((class1 (eval '(defclass class-0311 () ((a) (b) (c))))) (obj1 (make-instance 'class-0311))) (setf (find-class 'class-0311) nil) (let ((class2 (eval '(defclass class-0311 () ((a) (b) (c)))))) (values (eqt (class-of obj1) class1) (eqt class1 class2) (typep* obj1 class1) (typep* obj1 class2) (class-name class1) (class-name class2) (eqt (find-class 'class-0311) class1) (eqt (find-class 'class-0311) class2))))) t nil t nil class-0311 class-0311 nil t) gcl-2.7.1/ansi-tests/PaxHeaders/phase.lsp0000644000000000000000000000013114542551763015271 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.393788749 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/phase.lsp0000644000175000017500000000453014542551763014672 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 21:15:54 2003 ;;;; Contains: Tests of PHASE (in-package :cl-test) (deftest phase.error.1 (signals-error (phase) program-error) t) (deftest phase.error.2 (signals-error (phase 0 0) program-error) t) (deftest phase.error.3 (check-type-error #'phase #'numberp) nil) (deftest phase.1 (eqlt (phase 0) 0.0f0) t) (deftest phase.2 (eqlt (phase 1) 0.0f0) t) (deftest phase.3 (eqlt (phase 1/2) 0.0f0) t) (deftest phase.4 (eqlt (phase 100.0f0) 0.0f0) t) (deftest phase.5 (eqlt (phase 100.0s0) 0.0s0) t) (deftest phase.6 (eqlt (phase 100.0d0) 0.0d0) t) (deftest phase.7 (eqlt (phase 100.0l0) 0.0l0) t) (deftest phase.8 (eqlt (phase -1) (coerce pi 'single-float)) t) (deftest phase.9 (eqlt (phase -1/2) (coerce pi 'single-float)) t) (deftest phase.10 (let ((p1 (phase #c(0 1))) (p2 (phase #c(0.0f0 1.0f0)))) (and (eql p1 p2) (approx= p1 (coerce (/ pi 2) 'single-float)))) t) (deftest phase.11 (let ((p (phase #c(0.0d0 1.0d0)))) (approx= p (coerce (/ pi 2) 'double-float))) t) (deftest phase.12 (let ((p (phase #c(0.0s0 1.0s0)))) (approx= p (coerce (/ pi 2) 'single-float))) t) (deftest phase.13 (let ((p (phase #c(0.0l0 1.0l0)))) (approx= p (/ pi 2))) t) (deftest phase.14 (let ((p1 (phase #c(1 1))) (p2 (phase #c(1.0f0 1.0f0)))) (and (eql p1 p2) (approx= p1 (coerce (/ pi 4) 'single-float) (* 2 single-float-epsilon)))) t) (deftest phase.15 (let ((p (phase #c(1.0d0 1.0d0)))) (approx= p (coerce (/ pi 4) 'double-float) (* 2 double-float-epsilon))) t) (deftest phase.16 (let ((p (phase #c(1.0s0 1.0s0)))) (approx= p (coerce (/ pi 4) 'single-float) (* 2 short-float-epsilon))) t) (deftest phase.17 (let ((p (phase #c(1.0l0 1.0l0)))) (approx= p (/ pi 4) (* 2 long-float-epsilon))) t) ;;; Negative zeros (deftest phase.18 (or (eqlt -0.0s0 0.0s0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'short-float))) t) (deftest phase.19 (or (eqlt -0.0f0 0.0f0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'single-float))) t) (deftest phase.20 (or (eqlt -0.0d0 0.0d0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'double-float))) t) (deftest phase.21 (or (eqlt -0.0l0 0.0l0) (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'long-float))) t) gcl-2.7.1/ansi-tests/PaxHeaders/fboundp.lsp0000644000000000000000000000013214542551762015626 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.393788749 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fboundp.lsp0000644000175000017500000000404014542551762015222 0ustar00cammcamm;-*- 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) (report-and-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) ;;; See 11.1.2.1.1 (deftest fboundp.8 (loop for x in *cl-non-function-macro-special-operator-symbols* when (and (fboundp x) (not (eq x 'ed))) collect x) nil) (deftest fboundp.order.1 (let ((i 0)) (values (notnot (fboundp (progn (incf i) 'car))) i)) t 1) (deftest fboundp.error.1 (check-type-error #'fboundp #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) nil) (deftest fboundp.error.2 (signals-type-error x '(x) (fboundp x)) t) (deftest fboundp.error.3 (signals-type-error x '(setf) (fboundp x)) t) (deftest fboundp.error.4 (signals-type-error x '(setf foo . bar) (fboundp x)) t) (deftest fboundp.error.5 (signals-type-error x '(setf foo bar) (fboundp x)) t) (deftest fboundp.error.6 (signals-error (fboundp) program-error) t) (deftest fboundp.error.7 (signals-error (fboundp 'cons nil) program-error) t) (deftest fboundp.error.8 (signals-error (locally (fboundp 1) t) type-error) t) (deftest fboundp.error.9 (signals-type-error x '(setf . foo) (fboundp x)) t) (deftest fboundp.error.10 (loop for x in *mini-universe* unless (symbolp x) nconc (handler-case (list x (fboundp `(setf ,x))) (type-error (c) (assert (not (typep (type-error-datum c) (type-error-expected-type c)))) nil) (error (c) (list (list x c))))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-09.lsp0000644000000000000000000000013114542551763020774 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.393788749 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-09.lsp0000644000175000017500000004664714542551763020414 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Random type prop tests, part 9 (sequences) (in-package :cl-test) ;;; FIND (def-type-prop-test find.1 'find (list t #'make-random-sequence-type-containing) 2) (def-type-prop-test find.2 'find (list 'integer #'make-random-sequence-type-containing) 2) (def-type-prop-test find.3 'find (list 'character #'make-random-sequence-type-containing) 2) (def-type-prop-test find.4 'find (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find.5 'find (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find.6 'find (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (v s k1 start k2) (declare (ignore v k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test find.7 'find (list 'integer #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real number)))) '(eql :key) '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) 4) (def-type-prop-test find.8 'find (list 'character #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(character base-char standard-char)))) '(eql :key) '(member char-upcase #.#'char-upcase char-downcase #.#'char-downcase upper-case-p #.#'upper-case-p lower-case-p #.#'lower-case-p both-case-p #.#'both-case-p char-code #.#'char-code char-int #.#'char-int alpha-char-p #.#'alpha-char-p digit-char-p #.#'digit-char-p alphanumericp #.#'alphanumericp)) 4) (def-type-prop-test find.9 'find (list t #'make-random-sequence-type-containing '(eql :from-end) '(or null t)) 4) (def-type-prop-test find.10 'find (list 'real #'(lambda (x) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real)))) '(eql :from-end) '(or null t) '(member :test :test-not) (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= 'equal #'equal 'eql #'eql)) 6) ;;; FIND-IF (def-type-prop-test find-if.1 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test find-if.2 'find-if (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test find-if.3 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test find-if.4 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if.5 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if.6 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test find-if.7 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test find-if.8 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test find-if.9 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test find-if.10 'find-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) ;;; FIND-IF-NOT (def-type-prop-test find-if-not.1 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test find-if-not.2 'find-if-not (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test find-if-not.3 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test find-if-not.4 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if-not.5 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test find-if-not.6 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test find-if-not.7 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test find-if-not.8 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test find-if-not.9 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test find-if-not.10 'find-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) ;;; POSITION (def-type-prop-test position.1 'position (list t #'make-random-sequence-type-containing) 2) (def-type-prop-test position.2 'position (list 'integer #'make-random-sequence-type-containing) 2) (def-type-prop-test position.3 'position (list 'character #'make-random-sequence-type-containing) 2) (def-type-prop-test position.4 'position (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position.5 'position (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position.6 'position (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (v s k1 start k2) (declare (ignore v k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test position.7 'position (list 'integer #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real number)))) '(eql :key) '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) 4) (def-type-prop-test position.8 'position (list 'character #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) (random-from-seq #(character base-char standard-char)))) '(eql :key) '(member char-upcase #.#'char-upcase char-downcase #.#'char-downcase upper-case-p #.#'upper-case-p lower-case-p #.#'lower-case-p both-case-p #.#'both-case-p char-code #.#'char-code char-int #.#'char-int alpha-char-p #.#'alpha-char-p digit-char-p #.#'digit-char-p alphanumericp #.#'alphanumericp)) 4) (def-type-prop-test position.9 'position (list t #'make-random-sequence-type-containing '(eql :from-end) '(or null t)) 4) (def-type-prop-test position.10 'position (list 'real #'(lambda (x) (make-sequence-type (random 10) (random-from-seq #(bit integer float rational real)))) '(eql :from-end) '(or null t) '(member :test :test-not) (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= 'equal #'equal 'eql #'eql)) 6) ;;; POSITION-IF (def-type-prop-test position-if.1 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test position-if.2 'position-if (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test position-if.3 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test position-if.4 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if.5 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if.6 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test position-if.7 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test position-if.8 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test position-if.9 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test position-if.10 'position-if (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) ;;; POSITION-IF-NOT (def-type-prop-test position-if-not.1 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test position-if-not.2 'position-if-not (list (let ((char-predicates '(alpha-char-p digit-char-p upper-case-p lower-case-p both-case-p alphanumericp graphic-char-p standard-char-p))) (append '(member) char-predicates (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) '(or standard-char base-char character)))) 2) (def-type-prop-test position-if-not.3 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x)))))) 2) (def-type-prop-test position-if-not.4 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if-not.5 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len)))) 4) (def-type-prop-test position-if-not.6 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6) (def-type-prop-test position-if-not.7 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test position-if-not.8 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) `(or bit bit bit bit bit bit bit ,@(loop for x from 2 to 32 collect `(unsigned-byte ,x)) ,@(loop for x from 2 to 32 collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) (def-type-prop-test position-if-not.9 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) (def-type-prop-test position-if-not.10 'position-if-not (list (append '(member) *cl-safe-predicates* (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) gcl-2.7.1/ansi-tests/PaxHeaders/equal.lsp0000644000000000000000000000013214542551762015300 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.393788749 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/equal.lsp0000644000175000017500000000541614542551762014704 0ustar00cammcamm;-*- 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.13 :notes (:nil-vectors-are-strings) (let ((x (make-array '(0) :element-type nil)) (y (make-array '(0) :element-type nil))) (equalt x y)) t) (deftest equal.14 :notes (:nil-vectors-are-strings) (and (equalt (make-array '(0) :element-type nil) "") (equalt "" (make-array '(0) :element-type nil))) t) (deftest equal.15 (equalt (make-array '(0) :element-type 'character) (make-array '(0) :element-type 'base-char)) t) (deftest equal.16 (equalt "abc" (make-array '(3) :element-type 'base-char :initial-contents '(#\a #\b #\c))) t) (deftest equal.17 (let ((s (make-array '(10) :element-type 'character :initial-contents "0123456789" :fill-pointer 3))) (values (equalt s "012") (equalt "012" s))) t t) (deftest equal.18 (let ((b (make-array '(10) :element-type 'bit :initial-contents #*0110001110 :fill-pointer 5))) (values (equalt #*01100 b) (equalt #*01100 b))) t t) (deftest equal.19 (let ((s (make-array '(10) :element-type 'base-char :initial-contents "0123456789" :fill-pointer 3))) (values (equalt s "012") (equalt "012" s))) t t) ;;; Should add more pathname equality tests (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) ;;; Error tests (deftest equal.error.1 (signals-error (equal) program-error) t) (deftest equal.error.2 (signals-error (equal nil) program-error) t) (deftest equal.error.3 (signals-error (equal nil nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/package-name.lsp0000644000000000000000000000013114542551763016502 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.393788749 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-name.lsp0000644000175000017500000001023014542551763016075 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 17:48:05 2004 ;;;; Contains: Tests of PACKAGE-NAME (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-name (deftest package-name.1 (progn (set-up-packages) (package-name "A")) "A") (deftest package-name.2 (progn (set-up-packages) (package-name #\A)) "A") (deftest package-name.3 (progn (set-up-packages) (package-name "Q")) "A") (deftest package-name.4 (progn (set-up-packages) (package-name #\Q)) "A") (deftest package-name.5 (handler-case (locally (declare (optimize safety)) (eval '(package-name "NOT-THERE")) nil) (type-error () t) (package-error () t)) t) (deftest package-name.6 (handler-case (locally (declare (optimize safety)) (eval '(package-name #\*)) nil) (type-error () t) (package-error () t)) t) (deftest package-name.6a (handler-case (locally (declare (optimize safety)) (eval '(locally (package-name #\*) t)) nil) (type-error () t) (package-error () t)) 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) (package-name (package-name p))))) 0) ;;; Specialized sequence tests (defmacro def-package-name-test (test-name name-form expected-name-form) `(deftest ,test-name (let ((name ,name-form) (expected-name ,expected-name-form)) (assert (string= name expected-name)) (safely-delete-package name) (let ((p (make-package name :use nil))) (equalt (package-name p) expected-name))) t)) (def-package-name-test package-name.16 (make-array 5 :element-type 'base-char :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.17 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????") "TEST1") (def-package-name-test package-name.18 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????") "TEST1") (def-package-name-test package-name.19 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.20 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.21 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2)) "TEST1") (def-package-name-test package-name.22 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2)) "TEST1") (deftest package-name.error.1 (signals-error (package-name) program-error) t) (deftest package-name.error.2 (signals-error (package-name "CL" nil) program-error) t) (deftest package-name.error.3 (check-type-error #'package-name #'package-designator-p) nil) gcl-2.7.1/ansi-tests/PaxHeaders/copy-seq.lsp0000644000000000000000000000013214542551762015731 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.393788749 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/copy-seq.lsp0000644000175000017500000001370614542551762015336 0ustar00cammcamm;-*- 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.19 :notes (:nil-vectors-are-strings) (copy-seq (make-array '(0) :element-type nil)) "") ;;; Specialized string tests (deftest copy-seq.20 (do-special-strings (s "abcde" nil) (let ((s2 (copy-seq s))) (assert (typep s2 'simple-array)) (assert (string= s s2)) (assert (equal (array-element-type s) (array-element-type s2))))) nil) ;;; Specialized vector tests (deftest copy-seq.21 (let ((v0 #(1 1 0 1 1 2))) (do-special-integer-vectors (v v0 nil) (let ((v2 (copy-seq v))) (assert (typep v2 'simple-array)) (assert (equalp v v2)) (assert (equalp v v0)) (assert (equal (array-element-type v) (array-element-type v2)))))) nil) (deftest copy-seq.22 (let ((v0 #(-1 1 1 0 1 -1 0))) (do-special-integer-vectors (v v0 nil) (let ((v2 (copy-seq v))) (assert (typep v2 'simple-array)) (assert (equalp v v2)) (assert (equalp v v0)) (assert (equal (array-element-type v) (array-element-type v2)))))) nil) (deftest copy-seq.23 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for vec = (make-array len :element-type type :initial-contents vals) for result = (copy-seq vec) unless (and (= (length result) len) (equal (array-element-type vec) (array-element-type result)) (equalp vec result)) collect (list type vals result)) nil) (deftest copy-seq.24 (loop for etype in '(short-float single-float long-float double-float) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for vec = (make-array len :element-type type :initial-contents vals) for result = (copy-seq vec) unless (and (= (length result) len) (equal (array-element-type vec) (array-element-type result)) (equalp vec result)) collect (list type vals result)) nil) ;;; Order of evaluation test (deftest copy-seq.order.1 (let ((i 0)) (values (copy-seq (progn (incf i) "abc")) i)) "abc" 1) (def-fold-test copy-seq.fold.1 (copy-seq '(a b c))) (def-fold-test copy-seq.fold.2 (copy-seq #(a b c))) (def-fold-test copy-seq.fold.3 (copy-seq #*01101100)) (def-fold-test copy-seq.fold.4 (copy-seq "abcdef")) ;;; Error tests (deftest copy-seq.error.1 (check-type-error #'copy-seq #'sequencep) nil) (deftest copy-seq.error.4 (signals-error (copy-seq) program-error) t) (deftest copy-seq.error.5 (signals-error (copy-seq "abc" 2 nil) program-error) t) (deftest copy-seq.error.6 (signals-error (locally (copy-seq 10) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-data-and-control-flow.lsp0000644000000000000000000000013214772071550021177 xustar0030 mtime=1743287144.986901119 30 atime=1744294960.397788766 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-data-and-control-flow.lsp0000644000175000017500000000344414772071550020602 0ustar00cammcamm;;; Tests of data and control flow (load "data-and-control-flow.lsp") (load "places.lsp") (load "psetq.lsp") (load "psetf.lsp") (load "shiftf.lsp") (load "rotatef.lsp") (load "return.lsp") (load "return-from.lsp") (load "defsetf.lsp") (load "define-setf-expander.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 "letstar.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 "multiple-value-list.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.7.1/ansi-tests/PaxHeaders/array-element-type.lsp0000644000000000000000000000013214542551762017715 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.397788766 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-element-type.lsp0000644000175000017500000000154514542551762017320 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of the function ARRAY-ELEMENT-TYPE (in-package :cl-test) ;;; Mosts tests are in other files, incidental to testing of ;;; other things (deftest array-element-type.1 (macrolet ((%m (z) z)) (notnot (array-element-type (expand-in-current-env (%m #(a b c)))))) t) (deftest array-element-type.order.1 (let ((i 0)) (array-element-type (progn (incf i) #(a b c))) i) 1) ;;; Error tests (deftest array-element-type.error.1 (signals-error (array-element-type) program-error) t) (deftest array-element-type.error.2 (signals-error (array-element-type #(a b c) nil) program-error) t) (deftest array-element-type.error.3 (check-type-error #'array-element-type #'arrayp) nil) (deftest array-element-type.error.4 (signals-type-error x nil (array-element-type x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-echo-stream.lsp0000644000000000000000000000013214542551763017314 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.397788766 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-echo-stream.lsp0000644000175000017500000002175014542551763016717 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/pprint-tabular.lsp0000644000000000000000000000013114542551763017135 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.397788766 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-tabular.lsp0000644000175000017500000001151714542551763016541 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 27 06:29:39 2004 ;;;; Contains: Tests of PPRINT-TABULAR (in-package :cl-test) ;;; When printing a non-list, the result is the same as calling WRITE." (deftest pprint-tabular.1 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-tabular s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (deftest pprint-tabular.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-tabular s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-tabular-test (name args expected-value &key (margin 100) (circle nil) (pre nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* ,margin) (*package* (find-package :cl-test)) (*print-circle* ,circle)) (with-output-to-string (s) ,@(when pre (list pre)) (pprint-tabular s ,@args)))) ,expected-value)) ;;; ;;; Note ;;; The prefix and suffix "(" and ")" are not considered part of the ;;; logical block they enclose (see the spec page for pprint-logical-block. ;;; (def-pprint-tabular-test pprint-tabular.3 ('(|M|)) "(M)") (def-pprint-tabular-test pprint-tabular.4 ('(|M|) t) "(M)") (def-pprint-tabular-test pprint-tabular.5 ('(|M|) nil) "M") (def-pprint-tabular-test pprint-tabular.6 ('(|M| |M|)) "(M M)") (def-pprint-tabular-test pprint-tabular.7 ('(|M| |M|) t nil 1) "(M M)") (def-pprint-tabular-test pprint-tabular.8 ('(|M| |M|) t t 3) "(M M)") (def-pprint-tabular-test pprint-tabular.9 ('(|M| |M|) t nil 4) "(M M)") (def-pprint-tabular-test pprint-tabular.10 ('(|MM| |MM|) t nil 4) "(MM MM)") (def-pprint-tabular-test pprint-tabular.11 ('(|MM| |MM|) t nil 5) "(MM MM)") (def-pprint-tabular-test pprint-tabular.12 ('(|M| |MM|) t nil 5) "(M MM)") (def-pprint-tabular-test pprint-tabular.13 ((let ((x (list '|A|))) (list x x)) t nil 1) "(#1=(A) #1#)" :circle t) (def-pprint-tabular-test pprint-tabular.14 ('(|M| |M|) t t 4) "(M M)") (def-pprint-tabular-test pprint-tabular.15 ('(1 2 3 4) t t 1) "(1 2 3 4)") (def-pprint-tabular-test pprint-tabular.16 ('(10 20 30 40) t t 1) "(10 20 30 40)") (def-pprint-tabular-test pprint-tabular.17 ('(10 200 3000 40000) t t 1) "(10 200 3000 40000)") (def-pprint-tabular-test pprint-tabular.18 ('(10 20 30 40) t t 2) "(10 20 30 40)") (def-pprint-tabular-test pprint-tabular.19 ('(10 200 3000 40000) t t 2) "(10 200 3000 40000)") (def-pprint-tabular-test pprint-tabular.20 ('(1 2 3) t nil 1) " (1 2 3)" :pre (write " " :stream s :escape nil)) (def-pprint-tabular-test pprint-tabular.21 ('(1 2 3) t nil 1) " (1 2 3)" :pre (write " " :stream s :escape nil) :margin 9) (def-pprint-tabular-test pprint-tabular.22 ('(1 2 3) t nil 1) " (1 2 3)" :pre (write " " :stream s :escape nil) :margin 10) ;;; Takes T, NIL as stream designators (deftest pprint-tabular.23 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-tabular t '(1 2 3) t nil 1)))))) "(1 2 3)") (deftest pprint-tabular.24 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-tabular nil '(1 2 3) t nil 1)))) "(1 2 3)") ;;; FIXME: add test for colon-p argument of NIL ;;; Test that pprint-tabular returns NIL (deftest pprint-tabular.return-values.1 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) (pprint-tabular s '(a b))))) nil) (deftest pprint-tabular.return-values.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) (pprint-tabular s 10 nil nil 100)))) nil) ;;; Error tests (deftest pprint-tabular.error.1 (signals-error (pprint-tabular) program-error) t) (deftest pprint-tabular.error.2 (signals-error (pprint-tabular *standard-output*) program-error) t) (deftest pprint-tabular.error.3 (signals-error (pprint-tabular *standard-output* nil t nil 1 nil) program-error) t) (deftest pprint-tabular.error.4 (signals-error (pprint-tabular *standard-output* '(a b c) t t 1 nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ldiff.lsp0000644000000000000000000000013114542551762015254 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.397788766 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ldiff.lsp0000644000175000017500000000766514542551762014671 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:46:56 2003 ;;;; Contains: Tests of LDIFF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test ldiff.fold.1 (ldiff '(a b c) 'x)) (def-fold-test ldiff.fold.2 (let ((x '(a b c))) (ldiff x (cddr x)))) ;; Error checking (deftest ldiff.error.1 (signals-type-error x 10 (ldiff x 'a)) t) ;; Single atoms are not dotted lists, so the next ;; case should be a type-error (deftest ldiff.error.2 (signals-type-error x 'a (ldiff x 'a)) t) (deftest ldiff.error.3 (signals-type-error x (make-array '(10) :initial-element 'a) (ldiff x '(a))) t) (deftest ldiff.error.4 (signals-type-error x 1.23 (ldiff x t)) t) (deftest ldiff.error.5 (signals-type-error x #\w (ldiff x 'a)) t) (deftest ldiff.error.6 (signals-error (ldiff) program-error) t) (deftest ldiff.error.7 (signals-error (ldiff nil) program-error) t) (deftest ldiff.error.8 (signals-error (ldiff nil nil nil) program-error) t) ;; 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) |# gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-23.lsp0000644000000000000000000000013214542551762016332 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.397788766 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-23.lsp0000644000175000017500000004006614542551762015736 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/in-package.lsp0000644000000000000000000000013114542551762016167 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.401788784 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/in-package.lsp0000644000175000017500000000544014542551762015571 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:03 1998 ;;;; Contains: Tests of IN-PACKAGE (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; in-package (deftest in-package.1 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package "H"))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.2 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package |H|))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.3 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package :|H|))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.4 (let ((*package* *package*)) (safely-delete-package "H") (make-package "H" :use ()) (let ((p2 (in-package #\H))) (and (eqt p2 (find-package "H")) (eqt *package* p2)))) t) (deftest in-package.5 (let ((*package* *package*)) (safely-delete-package "H") (handler-case (eval '(in-package "H")) (package-error () 'package-error) (error (c) c))) package-error) (def-macro-test in-package.error.1 (in-package :cl-test)) (defmacro def-in-package-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (prog1 (let* ((p (make-package name :use nil)) (*package* *package*) (p2 (eval `(in-package ,name)))) (list (eqt p p2) (eqt p *package*))) (safely-delete-package name))) (t t))) (def-in-package-test in-package.7 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-in-package-test in-package.8 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-in-package-test in-package.9 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-in-package-test in-package.10 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-in-package-test in-package.11 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-in-package-test in-package.12 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-in-package-test in-package.13 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5)))gcl-2.7.1/ansi-tests/PaxHeaders/intersection.lsp0000644000000000000000000000013114542551762016676 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.401788784 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/intersection.lsp0000644000175000017500000002310714542551762016300 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:39:19 2003 ;;;; Contains: Tests of INTERSECTION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless intersection.test-and-test-not.1 (intersection '(a b c) '(a c e) :test #'eql :test-not #'eql)) (defharmless intersection.test-and-test-not.2 (intersection '(a b c) '(a c e) :test-not #'eql :test #'eql)) ;;; 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)) (def-fold-test intersection.fold.1 (intersection '(a b c d e f) '(d w a x b y))) ;;; Error tests (deftest intersection.error.1 (signals-error (intersection) program-error) t) (deftest intersection.error.2 (signals-error (intersection nil) program-error) t) (deftest intersection.error.3 (signals-error (intersection nil nil :bad t) program-error) t) (deftest intersection.error.4 (signals-error (intersection nil nil :key) program-error) t) (deftest intersection.error.5 (signals-error (intersection nil nil 1 2) program-error) t) (deftest intersection.error.6 (signals-error (intersection nil nil :bad t :allow-other-keys nil) program-error) t) (deftest intersection.error.7 (signals-error (intersection '(a b c) '(d e f) :test #'identity) program-error) t) (deftest intersection.error.8 (signals-error (intersection '(a b c) '(d e f) :test-not #'identity) program-error) t) (deftest intersection.error.9 (signals-error (intersection '(a b c) '(d e f) :key #'cons) program-error) t) (deftest intersection.error.10 (signals-error (intersection '(a b c) '(d e f) :key #'car) type-error) t) (deftest intersection.error.11 (signals-error (intersection '(a b c) '(d e f . g)) type-error) t) (deftest intersection.error.12 (signals-error (intersection '(a b . c) '(d e f)) type-error) t) (deftest intersection.error.13 (check-type-error #'(lambda (x) (intersection x '(a b c))) #'listp) nil) (deftest intersection.error.14 (check-type-error #'(lambda (x) (intersection '(a b c) x)) #'listp) nil)gcl-2.7.1/ansi-tests/PaxHeaders/types-and-class-2.lsp0000644000000000000000000000013114542551763017337 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.401788784 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/types-and-class-2.lsp0000644000175000017500000001016014542551763016734 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 5 21:20:05 2003 ;;;; Contains: More tests of types and classes (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; 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.7.1/ansi-tests/PaxHeaders/cons-test-25.lsp0000644000000000000000000000013214542551762016334 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.401788784 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-25.lsp0000644000175000017500000000263514542551762015740 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/plusp.lsp0000644000000000000000000000013114542551763015334 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.401788784 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/plusp.lsp0000644000175000017500000000244214542551763014735 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:42:14 2003 ;;;; Contains: Tests for PLUSP (in-package :cl-test) ;;; Error tests (deftest plusp.error.1 (signals-error (plusp) program-error) t) (deftest plusp.error.2 (signals-error (plusp 0 0) program-error) t) (deftest plusp.error.3 (signals-error (plusp 0 nil) program-error) t) (deftest plusp.error.4 (check-type-error #'plusp #'realp) nil) ;;; Non-error tests (deftest plusp.1 (plusp 0) nil) (deftest plusp.2 (plusp -1) nil) (deftest plusp.3 (notnot-mv (plusp 1)) t) (deftest plusp.4 (loop for x in *reals* when (if (plusp x) (<= x 0) (> x 0)) collect x) nil) (deftest plusp.5 (some #'plusp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) nil) (deftest plusp.6 (some #'plusp '(0.0s0 0.0f0 0.0d0 0.0l0)) nil) (deftest plusp.7 (remove-if #'plusp (list 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 most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/progn.lsp0000644000000000000000000000013114542551763015316 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.401788784 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/progn.lsp0000644000175000017500000000177714542551763014731 0ustar00cammcamm;-*- 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) ;;; No implicit tagbody (deftest progn.8 (block nil (tagbody (progn (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest progn.9 (macrolet ((%m (z) z)) (progn (expand-in-current-env (%m :good)))) :good) (deftest progn.10 (macrolet ((%m (z) z)) (progn (expand-in-current-env (%m :bad)) (expand-in-current-env (%m :good)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/two-way-stream-input-stream.lsp0000644000000000000000000000013114542551763021517 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.401788784 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/two-way-stream-input-stream.lsp0000644000175000017500000000140014542551763021111 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/mapc.lsp0000644000000000000000000000013214542551763015112 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.401788784 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/mapc.lsp0000644000175000017500000000410414542551763014507 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:21:24 2003 ;;;; Contains: Tests of MAPC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (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) ;;; Error tests (deftest mapc.error.1 (check-type-error #'(lambda (x) (mapc #'identity x)) #'listp) nil) (deftest mapc.error.2 (signals-error (mapc) program-error) t) (deftest mapc.error.3 (signals-error (mapc #'append) program-error) t) (deftest mapc.error.4 (signals-error (locally (mapc #'identity 1) t) type-error) t) (deftest mapc.error.5 (signals-error (mapc #'cons '(a b c)) program-error) t) (deftest mapc.error.6 (signals-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapc.error.7 (signals-error (mapc #'car '(a b c)) type-error) t) (deftest mapc.error.8 (signals-error (mapc #'identity (list* 1 2 3 4)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/loop5.lsp0000644000000000000000000000013214542551763015230 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.401788784 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop5.lsp0000644000175000017500000001404214542551763014627 0ustar00cammcamm;-*- 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 (make-array '(4) :initial-contents "abcd" :element-type 'base-char))) (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)) (deftest loop.5.39 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 6))) (loop for x across v collect x)) (1 2 3 4 5 6)) (deftest loop.5.40 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) for v = (make-array '(10) :initial-contents '(0 0 1 1 0 1 1 1 0 0) :element-type type) for r = (loop for x across v collect x) unless (equal r '(0 0 1 1 0 1 1 1 0 0)) collect (list i r)) nil) (deftest loop.5.41 (loop for i from 1 to 40 for type = `(signed-byte ,i) for v = (make-array '(10) :initial-contents '(0 0 -1 -1 0 -1 -1 -1 0 0) :element-type type) for r = (loop for x across v collect x) unless (equal r '(0 0 -1 -1 0 -1 -1 -1 0 0)) collect (list i r)) nil) (deftest loop.5.42 (let ((vals '(0 0 1 1 0 1 1 1 0 0))) (loop for type in '(short-float single-float double-float long-float) for fvals = (loop for v in vals collect (coerce v type)) for v = (make-array '(10) :initial-contents fvals :element-type type) for r = (loop for x across v collect x) unless (equal r fvals) collect (list fvals r))) nil) (deftest loop.5.43 (let ((vals '(0 0 1 1 0 1 1 1 0 0))) (loop for etype in '(short-float single-float double-float long-float) for type = `(complex ,etype) for fvals = (loop for v in vals collect (coerce v type)) for v = (make-array '(10) :initial-contents fvals :element-type type) for r = (loop for x across v collect x) unless (equal r fvals) collect (list fvals r))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.5.44 (macrolet ((%m (z) z)) (loop for x across (expand-in-current-env (%m "148X")) collect x)) (#\1 #\4 #\8 #\X)) (deftest loop.5.45 (macrolet ((%m (z) z)) (loop as x across (expand-in-current-env (%m #*00110110)) collect x)) (0 0 1 1 0 1 1 0)) ;;; FIXME ;;; Add tests for other specialized array types (integer types, floats, complex) ;;; Error cases (deftest loop.5.error.1 (signals-error (loop for (e . e) across (vector '(x . y) '(u . v)) collect e) program-error) t) (deftest loop.5.error.2 (signals-error (loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e) program-error) t) (deftest loop.5.error.3 (signals-error (macroexpand '(loop for (e . e) across (vector '(x . y) '(u . v)) collect e)) program-error) t) (deftest loop.5.error.4 (signals-error (macroexpand '(loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/nstring-upcase.lsp0000644000000000000000000000013114542551763017133 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.401788784 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nstring-upcase.lsp0000644000175000017500000001076114542551763016537 0ustar00cammcamm;-*- 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.11 :notes (:nil-vectors-are-strings) (nstring-upcase (make-array '(0) :element-type nil)) "") (deftest nstring-upcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list (copy-seq s) (copy-seq (nstring-upcase s)) (copy-seq s) (progn (setf (fill-pointer s) 10) (copy-seq s)) )) (("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi"))) (deftest nstring-upcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list (copy-seq s) (nstring-upcase s) (copy-seq s) s0)) (("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG"))) (deftest nstring-upcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list (copy-seq s) (nstring-upcase s) (copy-seq s))) (("aB0cD" "AB0CD" "AB0CD") ("aB0cD" "AB0CD" "AB0CD") ("aB0cD" "AB0CD" "AB0CD"))) ;;; Order of evaluation tests (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 (signals-error (nstring-upcase) program-error) t) (deftest nstring-upcase.error.2 (signals-error (nstring-upcase (copy-seq "abc") :bad t) program-error) t) (deftest nstring-upcase.error.3 (signals-error (nstring-upcase (copy-seq "abc") :start) program-error) t) (deftest nstring-upcase.error.4 (signals-error (nstring-upcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest nstring-upcase.error.5 (signals-error (nstring-upcase (copy-seq "abc") :end) program-error) t) (deftest nstring-upcase.error.6 (signals-error (nstring-upcase (copy-seq "abc") 1 2) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/remove-duplicates-aux.lsp0000644000000000000000000000013114542551763020414 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.401788784 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remove-duplicates-aux.lsp0000644000175000017500000000631214542551763020015 0ustar00cammcamm;-*- 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)) (setf key (coerce key 'function)) (cond (test (setf test (coerce test 'function)) (assert (not test-not))) (test-not (setf test-not (coerce test-not 'function)) (setq test #'(lambda (x y) (not (funcall (the function 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 = (funcall (the function key) x) unless (position kx sequence :start (1+ i) :end end :test (the function test) :key (the function 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 len 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))) (list :fail1 seq seq1r seq2r arg-list)) ((and pure (not (equalp seq seq2))) (list :fail2 seq seq1r seq2r arg-list)) ((not (equalp seq1r seq2r)) (list :fail3 seq seq1r seq2r arg-list)) (t t))))) gcl-2.7.1/ansi-tests/PaxHeaders/array-has-fill-pointer-p.lsp0000644000000000000000000000013214542551762020717 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.405788802 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-has-fill-pointer-p.lsp0000644000175000017500000000240414542551762020315 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of the function ARRAY-HAS-FILL-POINTER-P (in-package :cl-test) ;;; Many tests are in other files, incidental to testing of ;;; other things (deftest array-has-fill-pointer-p.1 (array-has-fill-pointer-p #0a1) nil) (deftest array-has-fill-pointer-p.2 (array-has-fill-pointer-p #2a((a b)(c d))) nil) (deftest array-has-fill-pointer-p.3 (array-has-fill-pointer-p #3a(((a)))) nil) (deftest array-has-fill-pointer-p.4 (array-has-fill-pointer-p #4a((((a))))) nil) (deftest array-has-fill-pointer-p.5 (macrolet ((%m (z) z)) (array-has-fill-pointer-p (expand-in-current-env (%m #2a((a b)(c d)))))) nil) (deftest array-has-fill-pointer-p.order.1 (let ((i 0)) (array-has-fill-pointer-p (progn (incf i) #(a b c))) i) 1) ;;; Error tests (deftest array-has-fill-pointer-p.error.1 (signals-error (array-has-fill-pointer-p) program-error) t) (deftest array-has-fill-pointer-p.error.2 (signals-error (array-has-fill-pointer-p #(a b c) nil) program-error) t) (deftest array-has-fill-pointer-p.error.3 (check-type-error #'array-has-fill-pointer-p #'arrayp) nil) (deftest array-has-fill-pointer-p.error.4 (signals-type-error x nil (array-has-fill-pointer-p x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/set-exclusive-or.lsp0000644000000000000000000000013214542551763017410 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.405788802 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/set-exclusive-or.lsp0000644000175000017500000002165314542551763017015 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:45:46 2003 ;;;; Contains: Tests of SET-EXCLUSIVE-OR (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (defharmless set-exclusive-or.test-and-test-not.1 (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless set-exclusive-or.test-and-test-not.2 (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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) (def-fold-test set-exclusive-or.fold.1 (set-exclusive-or '(a b c d e f) '(b x e y z c))) ;;; Error tests (deftest set-exclusive-or.error.1 (signals-error (set-exclusive-or) program-error) t) (deftest set-exclusive-or.error.2 (signals-error (set-exclusive-or nil) program-error) t) (deftest set-exclusive-or.error.3 (signals-error (set-exclusive-or nil nil :bad t) program-error) t) (deftest set-exclusive-or.error.4 (signals-error (set-exclusive-or nil nil :key) program-error) t) (deftest set-exclusive-or.error.5 (signals-error (set-exclusive-or nil nil 1 2) program-error) t) (deftest set-exclusive-or.error.6 (signals-error (set-exclusive-or nil nil :bad t :allow-other-keys nil) program-error) t) (deftest set-exclusive-or.error.7 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest set-exclusive-or.error.8 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest set-exclusive-or.error.9 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest set-exclusive-or.error.10 (signals-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest set-exclusive-or.error.11 (signals-error (set-exclusive-or (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest set-exclusive-or.error.12 (signals-error (set-exclusive-or (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest set-exclusive-or.error.13 (check-type-error #'(lambda (x) (set-exclusive-or x '(a b c))) #'listp) nil) (deftest set-exclusive-or.error.14 (check-type-error #'(lambda (x) (set-exclusive-or '(a b c) x)) #'listp) nil) ;;; Randomized test (deftest random-set-exclusive-or (random-set-exclusive-or-test 10 100) nil) gcl-2.7.1/ansi-tests/PaxHeaders/format-s.lsp0000644000000000000000000000013214542551762015721 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.405788802 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-s.lsp0000644000175000017500000002005314542551762015317 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 3 11:55:07 2004 ;;;; Contains: Test of the ~S format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.s.1 (let ((*print-readably* nil) (*print-case* :upcase)) (format nil "~s" nil)) "NIL") (deftest formatter.s.1 (let ((*print-readably* nil) (*print-case* :upcase)) (formatter-call-to-string (formatter "~s") nil)) "NIL") (def-format-test format.s.2 "~:s" (nil) "()") (deftest format.s.3 (let ((*print-readably* nil) (*print-case* :upcase)) (format nil "~:s" '(nil))) "(NIL)") (deftest formatter.s.3 (let ((*print-readably* nil) (*print-case* :upcase)) (formatter-call-to-string (formatter "~:s") '(nil))) "(NIL)") (deftest format.s.4 (let ((*print-readably* nil) (*print-case* :downcase)) (format nil "~s" 'nil)) "nil") (deftest formatter.s.4 (let ((*print-readably* nil) (*print-case* :downcase)) (formatter-call-to-string (formatter "~s") 'nil)) "nil") (deftest format.s.5 (let ((*print-readably* nil) (*print-case* :capitalize)) (format nil "~s" 'nil)) "Nil") (deftest formatter.s.5 (let ((*print-readably* nil) (*print-case* :capitalize)) (formatter-call-to-string (formatter "~s") 'nil)) "Nil") (def-format-test format.s.6 "~:s" (#(nil)) "#(NIL)") (deftest format.s.7 (let ((fn (formatter "~S"))) (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +standard-chars+ for s = (format nil "~S" c) for s2 = (formatter-call-to-string fn c) for c2 = (read-from-string s) unless (and (eql c c2) (string= s s2)) collect (list c s c2 s2))))) nil) (deftest format.s.8 (let ((fn (formatter "~s"))) (with-standard-io-syntax (let ((*print-readably* nil)) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s1 = (and c (format nil "#\\~:c" c)) for s2 = (and c (format nil "~S" c)) for s3 = (formatter-call-to-string fn c) unless (or (null c) (graphic-char-p c) (and (string= s1 s2) (string= s2 s3))) do (incf count) and collect (list c s1 s2) when (> count 100) collect "count limit exceeded" and do (loop-finish))))) nil) (deftest format.s.9 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@s" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "NIL" "NIL" "NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL") (deftest format.s.10 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~dS" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "NIL" "NIL" "NIL" "NIL " "NIL " "NIL " "NIL " "NIL " "NIL " "NIL ") (deftest format.s.11 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@:S" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (deftest format.s.12 (with-standard-io-syntax (let ((*print-readably* nil)) (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d:s" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s)))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.s.13 (with-standard-io-syntax (let ((*print-readably* nil) (fn (formatter "~V:s"))) (apply #'values (loop for i from 1 to 10 for s = (format nil "~v:S" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.s.14 (with-standard-io-syntax (let ((*print-readably* nil) (fn (formatter "~V@:s"))) (apply #'values (loop for i from 1 to 10 for s = (format nil "~v:@s" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (def-format-test format.s.15 "~vS" (nil nil) "NIL") (def-format-test format.s.16 "~v:S" (nil nil) "()") (def-format-test format.s.17 "~@S" (nil) "NIL") (def-format-test format.s.18 "~v@S" (nil nil) "NIL") (def-format-test format.s.19 "~v:@s" (nil nil) "()") (def-format-test format.s.20 "~v@:s" (nil nil) "()") ;;; With colinc specified (def-format-test format.s.21 "~3,1s" (nil) "NIL") (def-format-test format.s.22 "~4,3s" (nil) "NIL ") (def-format-test format.s.23 "~3,3@s" (nil) "NIL") (def-format-test format.s.24 "~4,4@s" (nil) " NIL") (def-format-test format.s.25 "~5,3@s" (nil) " NIL") (def-format-test format.s.26 "~5,3S" (nil) "NIL ") (def-format-test format.s.27 "~7,3@s" (nil) " NIL") (def-format-test format.s.28 "~7,3S" (nil) "NIL ") ;;; With minpad (deftest format.s.29 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (fn (formatter "~V,,2s"))) (loop for i from -4 to 10 for s = (format nil "~v,,2S" i 'ABC) for s2 = (formatter-call-to-string fn i 'ABC) do (assert (string= s s2)) collect s))) ("ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (def-format-test format.s.30 "~3,,+2S" ('ABC) "ABC ") (def-format-test format.s.31 "~3,,0S" ('ABC) "ABC") (def-format-test format.s.32 "~3,,-1S" ('ABC) "ABC") (def-format-test format.s.33 "~3,,0S" ('ABCD) "ABCD") (def-format-test format.s.34 "~3,,-1S" ('ABCD) "ABCD") ;;; With padchar (def-format-test format.s.35 "~4,,,'XS" ('AB) "ABXX") (def-format-test format.s.36 "~4,,,s" ('AB) "AB ") (def-format-test format.s.37 "~4,,,'X@s" ('AB) "XXAB") (def-format-test format.s.38 "~4,,,@S" ('AB) " AB") (def-format-test format.s.39 "~10,,,vS" (nil 'ABCDE) "ABCDE ") (def-format-test format.s.40 "~10,,,v@S" (nil 'ABCDE) " ABCDE") (def-format-test format.s.41 "~10,,,vs" (#\* 'ABCDE) "ABCDE*****") (def-format-test format.s.42 "~10,,,v@s" (#\* 'ABCDE) "*****ABCDE") ;;; Other tests (def-format-test format.s.43 "~3,,vS" (nil 246) "246") (deftest format.s.44 (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (fn (formatter "~3,,vs"))) (loop for i from 0 to 6 for s = (format nil "~3,,vS" i 'ABC) for s2 = (formatter-call-to-string fn i 'ABC) do (assert (string= s s2)) collect s))) ("ABC" "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (deftest format.s.44a (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl-test)) (fn (formatter "~3,,V@S"))) (loop for i from 0 to 6 for s = (format nil "~3,,v@S" i 'ABC) for s2 = (formatter-call-to-string fn i 'ABC) do (assert (string= s s2)) collect s))) ("ABC" " ABC" " ABC" " ABC" " ABC" " ABC" " ABC")) (def-format-test format.s.45 "~4,,vs" (-1 1234) "1234") (def-format-test format.s.46 "~5,vS" (nil 123) "123 ") (def-format-test format.s.47 "~5,vS" (3 456) "456 ") (def-format-test format.s.48 "~5,v@S" (3 789) " 789") gcl-2.7.1/ansi-tests/PaxHeaders/coerce.lsp0000644000000000000000000000013014542551762015427 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.405788802 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/coerce.lsp0000644000175000017500000001044014542551762015026 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 13 20:48:04 2002 ;;;; Contains: Tests for COERCE (in-package :cl-test) (deftest coerce.1 (check-predicate #'(lambda (x) (let ((type (type-of x))) (or (and (consp type) (eqt (car type) 'function)) (eql (coerce x type) x))))) nil) (deftest coerce.2 (check-predicate #'(lambda (x) (eql (coerce x t) x))) nil) (deftest coerce.3 (check-predicate #'(lambda (x) (let ((class (class-of x))) (eql (coerce x class) x)))) nil) (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) ;;; Constant folding test ;;; If the coerce call is folded to a constant, this will fail ;;; when that constant is modified. (def-fold-test coerce.fold.1 (coerce '(1 2 3) 'vector)) (def-fold-test coerce.fold.2 (coerce '(1 0 1) 'bit-vector)) (def-fold-test coerce.fold.3 (coerce '(#\a #\b #\c) 'string)) ;;; Error tests ;;; (deftest coerce.error.1 ;;; (signals-error (coerce -1 '(integer 0 100)) type-error) ;;; t) (deftest coerce.error.2 (signals-error (coerce '(a b c) '(vector * 2)) type-error) t) (deftest coerce.error.3 (signals-error (coerce '(a b c) '(vector * 4)) type-error) t) (deftest coerce.error.4 (signals-error (coerce nil 'cons) type-error) t) (deftest coerce.error.5 (handler-case (eval '(coerce 'not-a-bound-function 'function)) (error () :caught)) :caught) (deftest coerce.error.6 (signals-error (coerce) program-error) t) (deftest coerce.error.7 (signals-error (coerce t) program-error) t) (deftest coerce.error.8 (signals-error (coerce 'x t 'foo) program-error) t) (deftest coerce.error.9 (signals-error (locally (coerce nil 'cons) t) type-error) t) (deftest coerce.error.10 :notes (:result-type-element-type-by-subtype) (let* ((tp1 '(vector character)) (tp2 `(vector t)) (tp3 `(or ,tp1 ,tp2))) (if (not (subtypep tp3 'vector)) t (handler-case (eval `(coerce '(#\a #\b #\c) ',tp3)) (type-error (c) (cond ((typep (type-error-datum c) (type-error-expected-type c)) `((typep ',(type-error-datum c) ',(type-error-expected-type c)) "==>" true)) (t t))) (error (c) (declare (ignore c)) t)))) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-string.lsp0000644000000000000000000000013214542551763016413 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.409788819 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-string.lsp0000644000175000017500000001002114542551763016003 0ustar00cammcamm;-*- 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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (string-all-the-same s) )) t) (deftest make-string.10 :notes (:nil-vectors-are-strings) (let ((s (make-string 0 :element-type nil))) (values (notnot (stringp s)) (eqlt (length s) 0) (equalt s ""))) t t t) (def-fold-test make-string.fold.1 (make-string 5 :initial-element #\a)) ;;; 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 (signals-error (make-string) program-error) t) (deftest make-string.error.2 (signals-error (make-string 10 :bad t) program-error) t) (deftest make-string.error.3 (signals-error (make-string 10 :bad t :allow-other-keys nil) program-error) t) (deftest make-string.error.4 (signals-error (make-string 10 :initial-element) program-error) t) (deftest make-string.error.5 (signals-error (make-string 10 1 1) program-error) t) (deftest make-string.error.6 (signals-error (make-string 10 :element-type) program-error) t) ;;; 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.7.1/ansi-tests/PaxHeaders/rt-test.lsp0000644000000000000000000000013214542551763015574 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rt-test.lsp0000644000175000017500000001634014542551763015176 0ustar00cammcamm;-*-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. (cl:defpackage :rt-tests (:use :cl :regression-test)) (in-package :rt-tests) ;; (require "RT") ;;(use-package :regression-test) (defmacro setup (&rest body) `(do-setup '(progn ., body))) (defmacro with-blank-tests (&body body) `(let ((regression-test::*entries* (list nil)) (regression-test::*entries-table* (make-hash-table :test #'equal)) (*test* nil) (regression-test::*in-test* nil)) (let ((regression-test::*entries-tail* regression-test::*entries*)) ,@body))) (defun do-setup (form) (with-blank-tests (let ((*do-tests-when-defined* 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 RT-TESTS::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 (RT-TESTS::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 RT-TESTS::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." " RT-TESTS::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." " RT-TESTS::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." " RT-TESTS::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." " RT-TESTS::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 :out s)))) () ("Doing 2 pending tests of 2 tests total." " RT-TESTS::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 :out s))) () ("Doing 2 pending tests of 2 tests total." " RT-TESTS::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.7.1/ansi-tests/PaxHeaders/string-downcase.lsp0000644000000000000000000000013214542551763017301 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-downcase.lsp0000644000175000017500000001071214542551763016700 0ustar00cammcamm;-*- 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.11 :notes (:nil-vectors-are-strings) (string-downcase (make-array '(0) :element-type nil)) "") (deftest string-downcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) (deftest string-downcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) (deftest string-downcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) ;;; Order of evaluation tests (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) (def-fold-test string-downcase.fold.1 (string-downcase "ABCDE")) ;;; Error cases (deftest string-downcase.error.1 (signals-error (string-downcase) program-error) t) (deftest string-downcase.error.2 (signals-error (string-downcase (copy-seq "abc") :bad t) program-error) t) (deftest string-downcase.error.3 (signals-error (string-downcase (copy-seq "abc") :start) program-error) t) (deftest string-downcase.error.4 (signals-error (string-downcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest string-downcase.error.5 (signals-error (string-downcase (copy-seq "abc") :end) program-error) t) (deftest string-downcase.error.6 (signals-error (string-downcase (copy-seq "abc") 1 2) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/use-package.lsp0000644000000000000000000000013114542551763016356 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/use-package.lsp0000644000175000017500000002457414542551763015771 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:08:41 1998 ;;;; Contains: Tests of USE-PACKAGE (in-package :cl-test) (compile-and-load "package-aux.lsp") (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) ;; Check that *PACKAGE* is used as a default (deftest use-package.7 (let ((user-name "H") (used-name "G")) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) (puser (make-package user-name :use nil)) (sym1 (intern "FOO" pused))) (and (eqt (export sym1 pused) t) (null (package-used-by-list pused)) (null (package-used-by-list puser)) (null (package-use-list pused)) (null (package-use-list puser)) (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used (multiple-value-bind (sym2 access) (find-symbol "FOO" puser) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list puser) (list pused)) (equal (package-used-by-list pused) (list puser)) (null (package-use-list pused)) (null (package-used-by-list puser)) (eqt (unuse-package pused puser) t) (null (find-symbol "FOO" puser))))) t) ;;; Tests for specialized sequence arguments (defmacro def-use-package-test (test-name &key (user "H") (used "G")) `(deftest ,test-name (let ((user-name ,user) (used-name ,used)) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) (puser (make-package user-name :use nil)) (sym1 (intern "FOO" pused))) (and (eqt (export sym1 pused) t) (null (package-used-by-list pused)) (null (package-used-by-list puser)) (null (package-use-list pused)) (null (package-use-list puser)) (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used (multiple-value-bind (sym2 access) (find-symbol "FOO" puser) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list puser) (list pused)) (equal (package-used-by-list pused) (list puser)) (null (package-use-list pused)) (null (package-used-by-list puser)) (eqt (unuse-package pused puser) t) (null (find-symbol "FOO" puser))))) t)) ;;; Specialized user package designator (def-use-package-test use-package.10 :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-use-package-test use-package.11 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-use-package-test use-package.12 :user (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-use-package-test use-package.13 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-use-package-test use-package.14 :user (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-use-package-test use-package.15 :user (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-use-package-test use-package.16 :user (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Specialed used package designator (def-use-package-test use-package.17 :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-use-package-test use-package.18 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-use-package-test use-package.19 :used (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-use-package-test use-package.20 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-use-package-test use-package.21 :used (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-use-package-test use-package.22 :used (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-use-package-test use-package.23 :used (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (deftest use-package.error.1 (signals-error (use-package) program-error) t) (deftest use-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use ()) (signals-error (use-package "UPE2" "UPE2A" nil) program-error)) t) gcl-2.7.1/ansi-tests/PaxHeaders/delete-file.lsp0000644000000000000000000000013214542551762016350 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.409788819 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/delete-file.lsp0000644000175000017500000000466514542551762015761 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/listen.lsp0000644000000000000000000000013114542551762015466 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.409788819 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/listen.lsp0000644000175000017500000000276414542551762015076 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/divide.lsp0000644000000000000000000000013214542551762015435 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.409788819 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/divide.lsp0000644000175000017500000001145214542551762015036 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 20:20:15 2003 ;;;; Contains: Tests of the / function (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "division-aux.lsp") (deftest /.error.1 (signals-error (/) program-error) t) (deftest /.error.2 (divide-by-zero-test 0)) (deftest /.error.3 (divide-by-zero-test 1 0)) (deftest /.error.4 (divide-by-zero-test 17 10 0 11)) (deftest /.error.5 (divide-by-zero-test 0.0s0)) (deftest /.error.6 (divide-by-zero-test 0.0f0)) (deftest /.error.7 (divide-by-zero-test 0.0d0)) (deftest /.error.8 (divide-by-zero-test 0.0l0)) ;;;;;;;;;; (deftest /.1 (/ 1) 1) (deftest /.2 (/ -1) -1) (deftest /.3 (loop for i = (random-fixnum) repeat 1000 unless (or (zerop i) (let ((q1 (/ i)) (q2 (/ 1 i))) (and (rationalp q1) (eql (denominator q1) (abs i)) (eql (numerator q1) (signum i)) (eql q1 q2) (eql (* q1 i) 1)))) collect i) nil) (deftest /.4 (loop for i = (random-from-interval 1000000 1) for j = (random-from-interval 1000000 1) for g = (gcd i j) for q = (/ i j) for q2 = (/ j) repeat 1000 unless (and (integerp g) (zerop (mod i g)) (zerop (mod j g)) (eql (numerator q) (/ i g)) (eql (denominator q) (/ j g)) (eql (/ q) (/ j i)) (eql q (* i q2))) collect (list i j q)) nil) (deftest /.5 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) nconc (loop for i = (1+ (random bound)) for r1 = (/ i) for r2 = (/ 1 i) repeat 1000 unless (eql r1 r2) collect (list i r1 r2))) nil) ;; Complex division (deftest /.6 (loop for i1 = (random-fixnum) for i = (if (zerop i1) 1 i1) for c = (complex 0 i) for r = (/ c) repeat 1000 unless (eql r (complex 0 (- (/ i)))) collect (list i c r)) nil) #| (deftest /.7 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) nconc (loop for i = (1+ (random bound)) for c = (complex 0 i) for r = (/ c) repeat 1000 unless (= r (complex 0 (- (/ i)))) collect (list i c r (complex 0 (- (/ i)))))) nil) |# (deftest /.8 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) for one = (float 1.0 bound) for zero = (float 0.0 bound) nconc (loop for i = (1+ (random bound)) for c = (complex i zero) for q = (/ c c) repeat 100 unless (eql q (complex one zero)) collect (list i c q (complex one zero)))) nil) (deftest /.9 (loop for a = (random-fixnum) for b = (random-fixnum) for m = (+ (* a a) (* b b)) repeat 1000 unless (or (zerop m) (let* ((q (/ (complex a b))) (c (/ a m)) (d (/ (- b) m)) (expected (complex c d))) (eql q expected))) collect (list a b (/ (complex a b)))) nil) (deftest /.10 (let ((bound 1000000000000000000)) (loop for a = (random-from-interval bound) for b = (random-from-interval bound) for m = (+ (* a a) (* b b)) repeat 1000 unless (or (zerop m) (let* ((q (/ (complex a b))) (c (/ a m)) (d (/ (- b) m)) (expected (complex c d))) (eql q expected))) collect (list a b (/ (complex a b))))) nil) (deftest /.11 (loop for a = (random-fixnum) for b = (random-fixnum) for n = (complex (random-fixnum) (random-fixnum)) for m = (+ (* a a) (* b b)) repeat 1000 unless (or (zerop m) (let* ((q (/ n (complex a b))) (c (/ a m)) (d (/ (- b) m)) (expected (* n (complex c d)))) (eql q expected))) collect (list a b (/ n (complex a b)))) nil) ;;; More floating point tests (deftest /.12 (loop for type in '(short-float single-float double-float long-float) for lower in (mapcar #'rational-safely (list least-positive-short-float least-positive-single-float least-positive-double-float least-positive-long-float)) for upper in (mapcar #'rational-safely (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)) for one = (coerce 1 type) for radix = (float-radix one) nconc (loop for i from 1 for rpos = radix then (* rpos radix) for rneg = (/ radix) then (/ rneg radix) while (<= lower rneg rpos upper) unless (let ((frpos (float rpos one)) (frneg (float rneg one))) (and (eql (/ frpos) (/ one frpos)) (eql (/ frpos) (/ 1.0s0 frpos)) (eql (/ frpos) (/ 1 frpos)) (eql (/ frpos) frneg) (eql (/ frneg) (/ 1.0s0 frneg)) (eql (/ frneg) (/ 1 frneg)) (eql (/ frneg) frpos))) collect (list i rpos rneg (float rpos one) (float rneg one)))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest /.13 (macrolet ((%m (z) z)) (values (/ (expand-in-current-env (%m 1/2))) (/ (expand-in-current-env (%m 2)) 3) (/ 5 (expand-in-current-env (%m 7))))) 2 2/3 5/7) gcl-2.7.1/ansi-tests/PaxHeaders/with-input-from-string.lsp0000644000000000000000000000013214542551763020547 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-input-from-string.lsp0000644000175000017500000001321514542551763020147 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/tree-equal.lsp0000644000000000000000000000013114542551763016235 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/tree-equal.lsp0000644000175000017500000000572414542551763015644 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 07:23:03 2003 ;;;; Contains: Tests of TREE-EQUAL (in-package :cl-test) (compile-and-load "cons-aux.lsp") (deftest tree-equal.1 (notnot-mv (tree-equal 'a 'a)) t) (deftest tree-equal.2 (tree-equal 'a 'b) nil) (deftest tree-equal.3 (notnot-mv (tree-equal (list 'a 'b (list 'c 'd)) (list 'a 'b (list 'c 'd)))) t) (deftest tree-equal.4 (tree-equal '(a b c d) '(a b c e)) nil) (deftest tree-equal.5 (notnot-mv (tree-equal 1 2 :test #'<)) t) (deftest tree-equal.6 (notnot-mv (tree-equal 1 2 :test #'(lambda (x y) (values (< x y) t)))) t) (deftest tree-equal.7 (tree-equal 1 2 :test #'>) nil) (deftest tree-equal.8 (tree-equal (list 1) 2 :test (constantly t)) nil) (deftest tree-equal.9 (tree-equal (list 1) (list 2) :test #'(lambda (x y) (or (and (consp x) (consp y)) (eql x y)))) nil) (deftest tree-equal.10 (notnot-mv (tree-equal '(10 20 . 30) '(11 22 . 34) :test #'<)) t) (deftest tree-equal.11 (let* ((x (list 'a 'b)) (y (list x x)) (z (list (list 'a 'b) (list 'a 'b)))) (notnot-mv (tree-equal y z))) t) (deftest tree-equal.12 (tree-equal 'a '(a b)) nil) (deftest tree-equal.13 (tree-equal '(a) '(a b)) nil) (deftest tree-equal.14 (tree-equal '(a b) '(a)) nil) (deftest tree-equal.15 (let ((x (vector 'a 'b 'c)) (y (vector 'a' 'b 'c))) (tree-equal x y)) nil) (deftest tree-equal.16 (let ((x (copy-seq "")) (y (copy-seq ""))) (tree-equal x y)) nil) (defharmless tree-equal.test-and-test-not.1 (tree-equal '(a b) '(a b) :test #'eql :test-not #'eql)) (defharmless tree-equal.test-and-test-not.2 (tree-equal '(a b) '(a b) :test-not #'eql :test #'eql)) ;;; Keywords tests (deftest tree-equal.allow-other-keys.1 (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys nil)) t) (deftest tree-equal.allow-other-keys.2 (tree-equal '(a b) (list 'a 'c) :allow-other-keys nil :test #'eql) nil) (deftest tree-equal.allow-other-keys.3 (tree-equal '(a b) (list 'a 'z) :allow-other-keys t :foo t) nil) (deftest tree-equal.allow-other-keys.4 (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys t :allow-other-keys nil :foo t)) t) (deftest tree-equal.keywords.1 (notnot-mv (tree-equal '(a . b) '(b . a) :test (complement #'eql) :test #'eql)) t) ;;; Error tests (deftest tree-equal.error.1 (signals-error (tree-equal) program-error) t) (deftest tree-equal.error.2 (signals-error (tree-equal '(a b)) program-error) t) (deftest tree-equal.error.3 (signals-error (tree-equal '(a b) '(a b) (gensym) t) program-error) t) (deftest tree-equal.error.4 (signals-error (tree-equal '(a b) '(a b) (gensym) t :allow-other-keys nil) program-error) t) (deftest tree-equal.error.5 (signals-error (tree-equal '(a b) '(a b) :test #'identity) program-error) t) (deftest tree-equal.error.6 (signals-error (tree-equal '(a b) '(a b) :test #'(lambda (x y z) (eq x y))) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/times.lsp0000644000000000000000000000013114542551763015312 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/times.lsp0000644000175000017500000002362414542551763014720 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 28 10:41:34 2003 ;;;; Contains: Tests of the multiplication function * (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "times-aux.lsp") (deftest *.1 (*) 1) (deftest *.2 (loop for x in *numbers* unless (eql x (* x)) collect x) nil) (deftest *.3 (loop for x in *numbers* for x1 = (* x 1) for x2 = (* 1 x) unless (and (eql x x1) (eql x x2) (eql x1 x2)) collect (list x x1 x2)) nil) (deftest *.4 (loop for x in *numbers* for x1 = (* x 0) for x2 = (* 0 x) unless (and (= x1 0) (= x2 0)) collect (list x x1 x2)) nil) (deftest *.5 (loop for bound in '(1.0s0 1.0f0 1.0d0 1.0l0) nconc (loop for x = (random bound) for x1 = (* x -1) for x2 = (* -1 x) for x3 = (* x bound) for x4 = (* bound x) repeat 1000 unless (and (eql (- x) x1) (eql (- x) x2) (eql x x3) (eql x x4)) collect (list x x1 x2 x3 x4))) nil) (deftest *.6 (let* ((upper-bound (* 1000 1000 1000 1000)) (lower-bound (- upper-bound)) (spread (1+ (- upper-bound lower-bound)))) (loop for x = (random-from-interval upper-bound) for y = (random-from-interval upper-bound) for prod = (* x y) for prod2 = (integer-times x y) repeat 1000 unless (eql prod prod2) collect (list x y prod prod2))) nil) (deftest *.7 (let* ((upper-bound (* 1000 1000 1000)) (lower-bound (- upper-bound)) (spread (1+ (- upper-bound lower-bound)))) (loop for x = (+ (rational (random (float spread 1.0f0))) lower-bound) for y = (+ (rational (random (float spread 1.0f0))) lower-bound) for prod = (* x y) for prod2 = (rat-times x y) repeat 1000 unless (eql prod prod2) collect (list x y prod prod2))) nil) ;; Testing of multiplication by integer constants (deftest *.8 (let ((bound (isqrt most-positive-fixnum))) (loop for x = (random bound) for y = (random bound) for f = (eval `(function (lambda (z) (declare (optimize (speed 3) (safety 0))) (declare (type (integer 0 (,bound)) z)) (* ,x z)))) for prod = (funcall f y) repeat 100 unless (and (eql prod (* x y)) (eql prod (integer-times x y))) collect (progn (format t "Failed on ~A~%" (list x y prod)) (list x y prod (* x y) (integer-times x y))))) nil) (deftest *.9 (let* ((upper-bound (* 1000 1000 1000 1000))) (flet ((%r () (random-from-interval upper-bound))) (loop for xr = (%r) for xc = (%r) for x = (complex xr xc) for yr = (%r) for yc = (%r) for y = (complex yr yc) for prod = (* x y) repeat 1000 unless (and (eql (realpart prod) (- (integer-times xr yr) (integer-times xc yc))) (eql (imagpart prod) (+ (integer-times xr yc) (integer-times xc yr)))) collect (list x y prod)))) nil) (deftest *.10 (let* ((upper-bound (* 1000 1000 1000 1000)) (lower-bound (- upper-bound)) (spread (1+ (- upper-bound lower-bound)))) (flet ((%r () (+ (rational (random (float spread 1.0f0))) lower-bound))) (loop for xr = (%r) for xc = (%r) for x = (complex xr xc) for yr = (%r) for yc = (%r) for y = (complex yr yc) for prod = (* x y) repeat 1000 unless (and (eql (realpart prod) (- (rat-times xr yr) (rat-times xc yc))) (eql (imagpart prod) (+ (rat-times xr yc) (rat-times xc yr)))) collect (list x y prod)))) nil) (deftest *.11 (let ((prod 1) (args nil)) (loop for i from 1 to (min 256 (1- call-arguments-limit)) do (push i args) do (setq prod (* prod i)) always (eql (apply #'* args) prod))) t) (deftest *.12 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for radix = (float-radix x) for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k for y = (+ x (expt radix (- i))) nconc (loop for j from 1 to (- k i) for z = (+ x (expt radix (- j))) unless (eql (* y z) (+ x (expt radix (- i)) (expt radix (- j)) (expt radix (- (+ i j))))) collect (list x i j)))) nil) (deftest *.13 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for radix = (float-radix x) for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k for y = (- x (expt radix (- i))) nconc (loop for j from 1 to (- k i) for z = (- x (expt radix (- j))) unless (eql (* y z) (+ x (- (expt radix (- i))) (- (expt radix (- j))) (expt radix (- (+ i j))))) collect (list x i j)))) nil) ;;; Float contagion (deftest *.14 (let ((bound (- (sqrt most-positive-short-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'short-float)) collect (list x y p))) nil) (deftest *.15 (let ((bound (- (sqrt most-positive-single-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'single-float)) collect (list x y p))) nil) (deftest *.16 (let ((bound (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest *.17 (let ((bound (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.18 (let ((bound (- (sqrt most-positive-short-float) 1)) (bound2 (- (sqrt most-positive-single-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'single-float)) collect (list x y p))) nil) (deftest *.19 (let ((bound (- (sqrt most-positive-short-float) 1)) (bound2 (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest *.20 (let ((bound (- (sqrt most-positive-short-float) 1)) (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.21 (let ((bound (- (sqrt most-positive-single-float) 1)) (bound2 (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest *.22 (let ((bound (- (sqrt most-positive-single-float) 1)) (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.23 (let ((bound (- (sqrt most-positive-double-float) 1)) (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound2) for p = (* x y) repeat 1000 unless (and (eql p (* y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest *.24 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (floor bits 2)) nconc (loop for i = (random bound) for x = (coerce i type) for j = (random bound) for y = (coerce j type) for prod = (* x y) repeat 1000 unless (and (eql prod (coerce (* i j) type)) (eql prod (* y x))) collect (list i j x y (* x y) (coerce (* i j) type)))) nil) (deftest *.25 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (- bits 2)) when (= (float-radix (coerce 1.0 type)) 2) nconc (loop for i = (random bound) for x = (coerce i type) for j = (* i 2) for y = (coerce j type) repeat 1000 unless (eql (* 2 x) y) collect (list i j x (* 2 x) y))) nil) ;;; Shows a compiler bug in sbcl/cmucl (deftest *.26 (eqlt (funcall (compile nil '(lambda (x y) (declare (type (single-float -10.0 10.0) x) (type (double-float -1.0d100 1.0d100) y)) (* x y))) 1.0f0 1.0d0) 1.0d0) t) (deftest *.27 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (floor bits 2)) nconc (loop for i = (random bound) for x = (coerce i type) for j = (random bound) for y = (coerce j type) for one = (coerce 1.0 type) for cx = (complex one x) for cy = (complex one y) for prod = (* cx cy) repeat 1000 unless (and (eql prod (complex (coerce (- 1 (* i j)) type) (coerce (+ i j) type))) (eql prod (* cy cx))) collect (list type i j x y (* cx cy)))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest *.28 (macrolet ((%m (z) z)) (values (* (expand-in-current-env (%m 2))) (* (expand-in-current-env (%m 3)) 4) (* 5 (expand-in-current-env (%m 3))))) 2 12 15) ;;; Order of evaluation tests (deftest times.order.1 (let ((i 0) x y) (values (* (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 3)) i x y)) 6 2 1 2) (deftest times.order.2 (let ((i 0) x y z) (values (* (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 3) (progn (setf z (incf i)) 5)) i x y z)) 30 3 1 2 3) gcl-2.7.1/ansi-tests/PaxHeaders/reverse.lsp0000644000000000000000000000013214542551763015645 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/reverse.lsp0000644000175000017500000001072414542551763015247 0ustar00cammcamm;-*- 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-vector.3 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (reverse x)) #()) (deftest reverse-vector.4 (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-vector.5 (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)) ;;; Other unusual vectors (deftest reverse-vector.6 (do-special-integer-vectors (v #(1 1 0 1 1 0) nil) (let ((nv (reverse v))) (assert (typep nv 'simple-array)) (assert (not (eql v nv))) (assert (equalp nv #(0 1 1 0 1 1))) (assert (equalp v #(1 1 0 1 1 0))))) nil) (deftest reverse-vector.7 (do-special-integer-vectors (v #(-1 -1 0 -1 -1 0) nil) (let ((nv (reverse v))) (assert (typep nv 'simple-array)) (assert (not (eql v nv))) (assert (equalp nv #(0 -1 -1 0 -1 -1))) (assert (equalp v #(-1 -1 0 -1 -1 0))))) nil) (deftest reverse-vector.8 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i from 1 to len collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (reverse vec) unless (and (eql (length nvec) len) (typep nvec 'simple-array) (not (eql vec nvec)) (every #'eql (reverse vals) nvec) (every #'eql vals vec)) collect (list etype vals vec nvec))) nil) (deftest reverse-vector.9 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float rational integer) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (reverse vec) unless (and (eql (length nvec) len) (typep nvec 'simple-array) (not (eql vec nvec)) (every #'eql (reverse vals) nvec) (every #'eql vals vec)) collect (list etype vals vec nvec))) nil) ;;; Bit vectors (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) ;;; Strings (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") ;;; Specialized string tests (deftest reverse-string.5 (do-special-strings (s (copy-seq "12345") nil) (let ((s2 (reverse s))) (assert (typep s2 'simple-array)) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= "12345" s)) (assert (string= "54321" s2)))) nil) ;;; Order, number of times of evaluation (deftest reverse.order.1 (let ((i 0)) (values (reverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) ;;; Constant folding tests (def-fold-test reverse.fold.1 (reverse '(a b c))) (def-fold-test reverse.fold.2 (reverse #(a b c))) (def-fold-test reverse.fold.3 (reverse #*00111101011011)) (def-fold-test reverse.fold.4 (reverse "abcdefgh")) ;;; Error cases (deftest reverse.error.1 (check-type-error #'reverse #'sequencep) nil) (deftest reverse.error.6 (signals-error (reverse) program-error) t) (deftest reverse.error.7 (signals-error (reverse nil nil) program-error) t) (deftest reverse.error.8 (signals-error (locally (reverse 'a) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/revappend.lsp0000644000000000000000000000013214542551763016156 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.409788819 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/revappend.lsp0000644000175000017500000000255414542551763015562 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:37:43 2003 ;;;; Contains: Tests of REVAPPEND (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test revappend.fold.1 (revappend '(x) nil)) (def-fold-test revappend.fold.2 (revappend '(x y z) nil)) ;;; Error tests (deftest revappend.error.1 (signals-error (revappend) program-error) t) (deftest revappend.error.2 (signals-error (revappend nil) program-error) t) (deftest revappend.error.3 (signals-error (revappend nil nil nil) program-error) t) (deftest revappend.error.4 (signals-error (revappend '(a . b) '(z)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/fill.lsp0000644000000000000000000000013214542551762015117 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.413788837 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fill.lsp0000644000175000017500000003404014542551762014516 0ustar00cammcamm;-*- 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 (signals-error (fill 'a 'b) type-error) t) (deftest fill.error.2 (signals-error (fill) program-error) t) (deftest fill.error.3 (signals-error (fill (list 'a 'b)) program-error) t) (deftest fill.error.4 (signals-error (fill (list 'a 'b) 'c :bad t) program-error) t) (deftest fill.error.5 (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil) program-error) t) (deftest fill.error.6 (signals-error (fill (list 'a 'b) 'c :start) program-error) t) (deftest fill.error.7 (signals-error (fill (list 'a 'b) 'c :end) program-error) t) (deftest fill.error.8 (signals-error (fill (list 'a 'b) 'c 1 2) program-error) t) (deftest fill.error.10 (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest fill.error.11 (signals-error (locally (fill 'a 'b) t) type-error) t) ;;; 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 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :start -1)) type-error) t) (deftest array-fill-8 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :start 'a)) type-error) t) (deftest array-fill-9 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :end -1)) type-error) t) (deftest array-fill-10 (signals-error (let* ((a (make-array '(5)))) (fill a 'x :end 'a)) type-error) t) ;;; 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 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 10 :start -1)) type-error) t) (deftest array-fixnum-fill-8 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 100 :start 'a)) type-error) t) (deftest array-fixnum-fill-9 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a -5 :end -1)) type-error) t) (deftest array-fixnum-fill-10 (signals-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 17 :end 'a)) type-error) t) ;;; 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 (signals-error (array-unsigned-byte-fill-test-fn 8 0 :start -1) type-error) t) (deftest array-unsigned-byte8-fill-8 (signals-error (array-unsigned-byte-fill-test-fn 8 100 :start 'a) type-error) t) (deftest array-unsigned-byte8-fill-9 (signals-error (array-unsigned-byte-fill-test-fn 8 19 :end -1) type-error) t) (deftest array-unsigned-byte8-fill-10 (signals-error (array-unsigned-byte-fill-test-fn 8 17 :end 'a) type-error) t) ;;; 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) ;;; Specialized strings (deftest fill.specialized-strings.1 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x))) (assert (string= s "xxxxx"))) nil) (deftest fill.specialized-strings.2 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x :start 2))) (assert (string= s "abxxx"))) nil) (deftest fill.specialized-strings.3 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x :end 3))) (assert (string= s "xxxde"))) nil) (deftest fill.specialized-strings.4 (do-special-strings (s (copy-seq "abcde") nil) (assert (string= s "abcde")) (assert (eq s (fill s #\x :start 1 :end 4))) (assert (string= s "axxxe"))) nil) ;;; Specialized vector tests (deftest fill.specialized-vectors.1 (do-special-integer-vectors (v #(0 1 1 0 1) nil) (let ((etype (array-element-type v))) (assert (eq v (fill v 0))) (assert (equal (array-element-type v) etype))) (assert (equalp v #(0 0 0 0 0)))) nil) (deftest fill.specialized-vectors.2 (do-special-integer-vectors (v #(0 -1 1 0 -1) nil) (let ((etype (array-element-type v))) (assert (eq v (fill v 1))) (assert (equal (array-element-type v) etype))) (assert (equalp v #(1 1 1 1 1)))) nil) (deftest fill.specialized-vectors.3 (do-special-integer-vectors (v #(1 1 1 1 0) nil) (let ((etype (array-element-type v))) (assert (eq v (fill v 0 :start 1 :end 3))) (assert (equal (array-element-type v) etype))) (assert (equalp v #(1 0 0 1 0)))) nil)gcl-2.7.1/ansi-tests/PaxHeaders/char-aux.lsp0000644000000000000000000000013014542551762015677 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.413788837 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/char-aux.lsp0000644000175000017500000002203214542551762015276 0ustar00cammcamm;-*- 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) (declare (type function 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) (declare (type function fn)) (and (is-ordered-by seq fn) (is-ordered-by (reverse seq) (complement fn)))) (defun is-case-insensitive (fn) (when (symbolp fn) (assert (fboundp fn)) (setf fn (symbol-function fn))) (assert (typep fn 'function)) (locally (declare (type function 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) (when (symbolp fn) (assert (fboundp fn)) (setf fn (symbol-function fn))) (assert (typep fn 'function)) (locally (declare (type function fn)) (loop for x in *universe* always (or (characterp x) ;; FIXME -- catch the type error and check that datum ;; is eql to x (and that datum is not in the expected type) (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 'base-char) (typep c 'extended-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 (my-aref 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.old () (loop for r from 2 to 36 always (loop for i from 0 to 36 always (let* ((c (digit-char i r)) (result (if (>= i r) (null c) (eqlt c (char +extended-digit-chars+ i))))) (unless result (format t "~A ~A ~A~%" r i c)) result)))) (defun digit-char.1.body () (loop for r from 2 to 36 nconc (loop for i from 0 to 36 for c = (digit-char i r) unless (if (>= i r) (null c) (eqlt c (char +extended-digit-chars+ i))) collect (list r i c)))) (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)))))) (or (loop for i from 0 below (min (ash 1 16) char-code-limit) unless (%insert (code-char i)) collect i) (loop for i = (random char-code-limit) repeat 1000 unless (%insert (code-char i)) collect i) (find-if-not #'%insert +standard-chars+) (find-if-not #'%insert *universe*))))) (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 (min (ash 1 16) 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) ;; FIXME The rest of this wasn't reachable #| (let ((name (char-name c))) (declare (type (or null string) name)) (and name (string-equal name s))) |# ))))) gcl-2.7.1/ansi-tests/PaxHeaders/times-aux.lsp0000644000000000000000000000013114542551763016105 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.413788837 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/times-aux.lsp0000644000175000017500000000125414542551763015506 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 28 11:23:40 2003 ;;;; Contains: Auxiliary functions for testing the multiplication operator * (in-package :cl-test) (defun integer-times (x y) (assert (integerp x)) (assert (integerp y)) (let (neg) (when (< x 0) (setq neg t x (- x))) (let ((result (nat-times x y))) (if neg (- result) result)))) (defun nat-times (x y) ;; Assumes x >= 0 (if (= x 0) 0 (let ((lo (if (oddp x) y 0)) (hi (nat-times (ash x -1) y))) (+ lo (+ hi hi))))) (defun rat-times (x y) (/ (integer-times (numerator x) (numerator y)) (integer-times (denominator x) (denominator y)))) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-function.lsp0000644000000000000000000000013114542551763017667 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.413788837 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-function.lsp0000644000175000017500000000105714542551763017271 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 15 21:57:44 2004 ;;;; Contains: Tests of SUBTYPEP on FUNCTION types (in-package :cl-test) (compile-and-load "types-aux.lsp") (deftest subtypep-function.1 (check-all-not-subtypep t '(function (t) t)) nil) (deftest subtypep-function.2 (check-all-subtypep nil '(function (t) t)) nil) (deftest subtypep-function.3 (check-all-subtypep '(function (t) t) 'function) nil) (deftest subtypep-function.4 (check-all-subtypep '(function (t) integer) '(function (t) real)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-02.lsp0000644000000000000000000000013214542551762016327 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.413788837 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-02.lsp0000644000175000017500000006376714542551762015750 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-01.lsp0000644000000000000000000000013114542551763020764 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.413788837 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-01.lsp0000644000175000017500000000664114542551763020372 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 20:36:56 2005 ;;;; Contains: Test that invoke the random type prop infrastructure, part 1 (in-package :cl-test) (def-type-prop-test special-operator-p 'special-operator-p '(symbol) 1) (def-type-prop-test type-of 'type-of '(t) 1) (def-type-prop-test typep.1 '(lambda (x y) (typep x (type-of y))) '(t t) 2) (def-type-prop-test typep.2 'typep (list t #'(lambda (x) (let ((type (make-random-type-containing x))) `(eql ,type)))) 2) (def-type-prop-test subtypep '(lambda (x y) (subtypep (type-of x) (type-of y))) '(t t) 2) (def-type-prop-test fboundp.1 'fboundp '(symbol) 1) (def-type-prop-test fboundp.2 'fboundp '((cons (eql setf) (cons symbol null))) 1) (def-type-prop-test functionp 'functionp '(t) 1) (def-type-prop-test compiled-function-p 'compiled-function-p '(t) 1) (def-type-prop-test not 'not '(t) 1) (def-type-prop-test eq 'eq (list '(and t (not number) (not character)) #'(lambda (x) (rcase (1 `(eql ,x)) (1 '(and t (not number) (not character)))))) 2) (def-type-prop-test eql.1 'eql '(t t) 2) (def-type-prop-test eql.2 'eql (list t #'(lambda (x) `(eql ,x))) 2) (def-type-prop-test equal.1 'equal '(t t) 2) (def-type-prop-test equal.2 'equal (list t #'(lambda (x) `(eql ,x))) 2) (def-type-prop-test equalp.1 'equalp '(t t) 2) (def-type-prop-test equalp.2 'equalp (list t #'(lambda (x) `(eql ,x))) 2) (def-type-prop-test identity 'identity '(t) 1) (def-type-prop-test complement '(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2) (def-type-prop-test constantly '(lambda (x) (funcall (constantly x))) '(t) 1) (def-type-prop-test and.1 'and '(t) 1) (def-type-prop-test and.2 'and '((or null t) t) 2) (def-type-prop-test and.3 'and '((or null t) (or null t) t) 3) (def-type-prop-test if.1 'if '(boolean t) 2) (def-type-prop-test if.2 'if '(boolean t t) 3) (def-type-prop-test if.3 '(lambda (p q x y z) (if p (if q x y) z)) '(boolean boolean t t t) 5) (def-type-prop-test if.4 '(lambda (p q x y z) (if p x (if q y z))) '(boolean boolean t t t) 5) (def-type-prop-test if.5 '(lambda (p q x y) (if (or p q) x y)) '(boolean boolean t t) 4) (def-type-prop-test if.6 '(lambda (p q x y) (if (and p q) x y)) '(boolean boolean t t) 4) (def-type-prop-test cond.1 '(lambda (p x y) (cond (p x) (t y))) '(boolean t t) 3) (def-type-prop-test cond.2 '(lambda (p x y) (cond (p x) (t y))) '((or null t) t t) 3) (def-type-prop-test or.1 'or '(t) 1) (def-type-prop-test or.2 'or '((or null t) t) 2) (def-type-prop-test or.3 'or '((or null null t) (or null t) t) 3) (def-type-prop-test when 'when '((or null t) t) 2) (def-type-prop-test unless 'unless '((or null t) t) 2) (def-type-prop-test slot-exists-p 'slot-exists-p '(t symbol) 2) (def-type-prop-test find-class 'find-class '(symbol null) 2) (def-type-prop-test class-of 'class-of '(t) 1) (def-type-prop-test find-restart 'find-restart '((and symbol (not null))) 1) (def-type-prop-test symbolp 'symbolp '(t) 1) (def-type-prop-test keywordp 'keywordp '(t) 1) (def-type-prop-test make-symbol 'make-symbol '(string) 1 :test #'(lambda (x y) (string= (symbol-name x) (symbol-name y)))) (def-type-prop-test symbol-name 'symbol-name '(symbol) 1) (def-type-prop-test symbol-package 'symbol-package '(symbol) 1) (def-type-prop-test boundp 'boundp '(symbol) 1) (def-type-prop-test find-symbol 'find-symbol '(string) 1) (def-type-prop-test find-package 'find-package '((or string symbol character)) 1) gcl-2.7.1/ansi-tests/PaxHeaders/subseq.lsp0000644000000000000000000000013214542551763015474 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.413788837 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subseq.lsp0000644000175000017500000001544214542551763015100 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:41:14 2002 ;;;; Contains: Tests on SUBSEQ (in-package :cl-test) (compile-and-load "subseq-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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) ;;; Specialized string tests (deftest subseq.specialized-string.1 (let* ((s0 "abcde") (len (length s0))) (do-special-strings (s "abcde" nil) (loop for i from 0 below len for s1 = (subseq s i) do (assert (typep s1 'simple-array)) do (assert (string= (subseq s i) (subseq s0 i))) do (loop for j from i to len for s2 = (subseq s i j) do (assert (typep s2 'simple-array)) (assert (string= s2 (subseq s0 i j))))))) nil) ;;; Other specialized vectors (deftest subseq.specialized-vector.1 (let* ((v0 #(1 0 1 1 0 1 1 0)) (len (length v0))) (do-special-integer-vectors (v (copy-seq v0) nil) (loop for i from 0 below len for v1 = (subseq v i) do (assert (typep v1 'simple-array)) do (assert (equalp (subseq v i) (subseq v0 i))) do (loop for j from i to len for v2 = (subseq v i j) do (assert (typep v2 'simple-array)) (assert (equalp v2 (subseq v0 i j))))))) nil) (deftest subseq.specialized-vector.2 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for vec = (make-array len :element-type type :initial-contents vals) for result = (subseq vec 1 9) unless (and (= (length result) 8) (equal (array-element-type vec) (array-element-type result)) (equalp result (apply #'vector (subseq vals 1 9)))) collect (list type vals result)) nil) (deftest subseq.specialized-vector.3 (loop for etype in '(short-float single-float long-float double-float integer rational) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for vec = (make-array len :element-type type :initial-contents vals) for result = (subseq vec 1 9) unless (and (= (length result) 8) (equal (array-element-type vec) (array-element-type result)) (equalp result (apply #'vector (subseq vals 1 9)))) collect (list type vals result)) nil) ;;; 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) ;;; Constant folding (def-fold-test subseq.fold.1 (subseq '(1 2 3) 0)) (def-fold-test subseq.fold.2 (subseq #(1 2 3) 0)) (def-fold-test subseq.fold.3 (subseq #*011101 0)) (def-fold-test subseq.fold.4 (subseq "abcdef" 0)) ;;; Error cases (deftest subseq.error.1 (signals-error (subseq) program-error) t) (deftest subseq.error.2 (signals-error (subseq nil) program-error) t) (deftest subseq.error.3 (signals-error (subseq nil 0 0 0) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/oneplus.lsp0000644000000000000000000000013114542551763015656 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.413788837 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/oneplus.lsp0000644000175000017500000000674414542551763015270 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 19:53:34 2003 ;;;; Contains: Tests of 1+ (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest 1+.error.1 (signals-error (1+) program-error) t) (deftest 1+.error.2 (signals-error (1+ 0 0) program-error) t) (deftest 1+.error.3 (signals-error (1+ 0 nil nil) program-error) t) (deftest 1+.1 (loop for x = (random-fixnum) for y = (1+ x) for z = (+ x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.2 (loop for x = (random-from-interval (ash 1 1000)) for y = (1+ x) for z = (+ x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.3 (loop for x = (random (1- most-positive-short-float)) for y = (1+ x) for z = (+ x 1.0s0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.4 (loop for x = (random (1- most-positive-single-float)) for y = (1+ x) for z = (+ x 1.0f0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.5 (loop for x = (random (1- most-positive-double-float)) for y = (1+ x) for z = (+ x 1.0d0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.6 (loop for x = (random (1- most-positive-long-float)) for y = (1+ x) for z = (+ x 1.0l0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1+.7 (loop for x = (random-fixnum) for y = (random-fixnum) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1+ r) for r2 = (+ r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2)) nil) (deftest 1+.8 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1+ r) for r2 = (+ r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2))) nil) ;;; Complex numbers (deftest 1+.9 (loop for xr = (random-fixnum) for xi = (random-fixnum) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1)) nil) (deftest 1+.10 (let ((bound (ash 1 100))) (loop for xr = (random-from-interval bound) for xi = (random-from-interval bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.11 (let ((bound (1- most-positive-short-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.12 (let ((bound (1- most-positive-single-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.13 (let ((bound (1- most-positive-double-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.14 (let ((bound (1- most-positive-long-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1+ xc) repeat 1000 unless (eql xc1 (complex (+ xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1+.15 (macrolet ((%m (z) z)) (1+ (expand-in-current-env (%m 1)))) 2) gcl-2.7.1/ansi-tests/PaxHeaders/format-paren.lsp0000644000000000000000000000013214542551762016564 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.413788837 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-paren.lsp0000644000175000017500000000765314542551762016175 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 17 20:28:24 2004 ;;;; Contains: Tests of the ~( format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.paren.1 "~(XXyy~AuuVV~)" ("ABc dEF ghI") "xxyyabc def ghiuuvv") ;;; Conversion of simple characters to downcase (deftest format.paren.2 (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (upper-case-p c) (let ((s1 (format nil "~(~c~)" c)) (s2 (string (char-downcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it) nil) (deftest formatter.paren.2 (let ((fn (formatter "~(~c~)"))) (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (upper-case-p c) (let ((s1 (formatter-call-to-string fn c)) (s2 (string (char-downcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it)) nil) (def-format-test format.paren.3 "~@(this is a TEST.~)" nil "This is a test.") (def-format-test format.paren.4 "~@(!@#$%^&*this is a TEST.~)" nil "!@#$%^&*This is a test.") (def-format-test format.paren.5 "~:(this is a TEST.~)" nil "This Is A Test.") (def-format-test format.paren.6 "~:(this is7a TEST.~)" nil "This Is7a Test.") (def-format-test format.paren.7 "~:@(this is AlSo A teSt~)" nil "THIS IS ALSO A TEST") (deftest format.paren.8 (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (lower-case-p c) (let ((s1 (format nil "~@:(~c~)" c)) (s2 (string (char-upcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it) nil) (deftest formatter.paren.8 (let ((fn (formatter "~@:(~c~)"))) (loop for i from 0 below (min char-code-limit (ash 1 16)) for c = (code-char i) when (and c (eql (char-code c) (char-int c)) (lower-case-p c) (let ((s1 (formatter-call-to-string fn c)) (s2 (string (char-upcase c)))) (if (or (not (eql (length s1) 1)) (not (eql (length s2) 1)) (not (eql (elt s1 0) (elt s2 0)))) (list i c s1 s2) nil))) collect it)) nil) ;;; Nested conversion (def-format-test format.paren.9 "~(aBc ~:(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.10 "~(aBc ~(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.11 "~@(aBc ~:(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.12 "~(aBc ~@(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.13 "~(aBc ~:(def~) GHi~)" nil "abc def ghi") (def-format-test format.paren.14 "~:(aBc ~(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.15 "~:(aBc ~:(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.16 "~:(aBc ~@(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.17 "~:(aBc ~@:(def~) GHi~)" nil "Abc Def Ghi") (def-format-test format.paren.18 "~@(aBc ~(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.19 "~@(aBc ~:(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.20 "~@(aBc ~@(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.21 "~@(aBc ~@:(def~) GHi~)" nil "Abc def ghi") (def-format-test format.paren.22 "~:@(aBc ~(def~) GHi~)" nil "ABC DEF GHI") (def-format-test format.paren.23 "~@:(aBc ~:(def~) GHi~)" nil "ABC DEF GHI") (def-format-test format.paren.24 "~:@(aBc ~@(def~) GHi~)" nil "ABC DEF GHI") (def-format-test format.paren.25 "~@:(aBc ~@:(def~) GHi~)" nil "ABC DEF GHI") gcl-2.7.1/ansi-tests/PaxHeaders/write-to-string.lsp0000644000000000000000000000013214542551763017250 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.421788872 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/write-to-string.lsp0000644000175000017500000000167614542551763016660 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 12:53:11 2004 ;;;; Contains: Tests of WRITE-TO-STRING (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is extensively used elsewhere (deftest write-to-string.1 (random-write-to-string-test 1000) nil) (deftest write-to-string.2 (with-standard-io-syntax (write-to-string 2 :allow-other-keys nil)) "2") (deftest write-to-string.3 (with-standard-io-syntax (write-to-string 3 :allow-other-keys t '#.(gensym) 0)) "3") (deftest write-to-string.4 (with-standard-io-syntax (write-to-string 4 :base 10 :base 2)) "4") ;;; Error tests (deftest write-to-string.error.1 (signals-error (write-to-string) program-error) t) (deftest write-to-string.error.2 (signals-error (write-to-string nil '#.(gensym) nil) program-error) t) (deftest write-to-string.error.3 (signals-error (write-to-string nil :radix) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/synonym-stream-symbol.lsp0000644000000000000000000000013114542551763020501 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.421788872 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/synonym-stream-symbol.lsp0000644000175000017500000000102714542551763020100 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/list-all-packages.lsp0000644000000000000000000000013114542551762017465 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.421788872 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/list-all-packages.lsp0000644000175000017500000000224214542551762017064 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 17:47:37 2004 ;;;; Contains: Tests of LIST-ALL-PACKAGES (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 (progn (set-up-packages) (notnot (subsetp (list (find-package "CL") (find-package "CL-USER") (find-package "KEYWORD") (find-package "A") (find-package "REGRESSION-TEST") (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 (signals-error (list-all-packages nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/sort.lsp0000644000000000000000000000013214542551763015161 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.421788872 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sort.lsp0000644000175000017500000001362214542551763014563 0ustar00cammcamm;-*- 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)) ;;; ;;; Confirm that sort only permutes the sequence, even when given ;;; a comparison function that does not define a total order. ;;; (deftest sort-list.4 (loop repeat 100 always (let ((a (list 1 2 3 4 5 6 7 8 9 0)) (cmp (make-array '(10 10)))) (loop for i from 0 to 9 do (loop for j from 0 to 9 do (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) (setq a (sort a #'(lambda (i j) (aref cmp i j)))) (and (eqlt (length a) 10) (equalt (sort a #'<) '(0 1 2 3 4 5 6 7 8 9))))) t) (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-vector.5 (loop repeat 100 always (let ((a (vector 1 2 3 4 5 6 7 8 9 0)) (cmp (make-array '(10 10)))) (loop for i from 0 to 9 do (loop for j from 0 to 9 do (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) (setq a (sort a #'(lambda (i j) (aref cmp i j)))) (and (eqlt (length a) 10) (equalpt (sort a #'<) #(0 1 2 3 4 5 6 7 8 9))))) t) (deftest sort-vector.6 (do-special-integer-vectors (v #(1 4 7 3 2 6 5) nil) (let ((sv (sort v #'<))) (assert (equalp sv #(1 2 3 4 5 6 7))))) nil) (deftest sort-vector.7 (do-special-integer-vectors (v #(0 1 1 0 1 1 0 1 0) nil) (let ((sv (sort v #'<))) (assert (equalp sv #(0 0 0 0 1 1 1 1 1))))) nil) (deftest sort-vector.8 (do-special-integer-vectors (v #(0 -1 -1 0 -1 -1 0 -1 0) nil) (let ((sv (sort v #'>))) (assert (equalp sv #(0 0 0 0 -1 -1 -1 -1 -1))))) nil) (deftest sort-vector.9 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i in ivals collect (coerce i etype)) for svals = (loop for i in sivals collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (sort vec #'<) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) (deftest sort-vector.10 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for cetype in '(short-float single-float double-float long-float rational) for etype = `(complex ,cetype) for vals = (loop for i in ivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for svals = (loop for i in sivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (sort vec #'(lambda (x y) (< (abs x) (abs y)))) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) ;;; Bit vectors (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") (deftest sort-string.4 (do-special-strings (s "aebdc" nil) (let ((s2 (sort s #'char<))) (assert (eq s s2)) (assert (string= s2 "abcde")))) nil) ;;; 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 (signals-error (sort) program-error) t) (deftest sort.error.2 (signals-error (sort nil) program-error) t) (deftest sort.error.3 (signals-error (sort nil #'< :key) program-error) t) (deftest sort.error.4 (signals-error (sort nil #'< 'bad t) program-error) t) (deftest sort.error.5 (signals-error (sort nil #'< 'bad t :allow-other-keys nil) program-error) t) (deftest sort.error.6 (signals-error (sort nil #'< 1 2) program-error) t) (deftest sort.error.7 (signals-error (sort (list 1 2 3 4) #'identity) program-error) t) (deftest sort.error.8 (signals-error (sort (list 1 2 3 4) #'< :key #'cons) program-error) t) (deftest sort.error.9 (signals-error (sort (list 1 2 3 4) #'< :key #'car) type-error) t) (deftest sort.error.10 (signals-error (sort (list 1 2 3 4) #'elt) type-error) t) (deftest sort.error.11 (check-type-error #'(lambda (x) (sort x #'<)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/doit1.lsp0000644000000000000000000000013214542551762015211 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.421788872 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/doit1.lsp0000644000175000017500000000123114542551762014604 0ustar00cammcamm;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (setq *enclose-printer-errors* nil) ;;; Remove compiled files (let* ((fn (compile-file-pathname "doit.lsp")) (type (pathname-type fn)) (dir-pathname (make-pathname :name :wild :type type)) (files (directory dir-pathname))) (assert type) (assert (not (string-equal type "lsp"))) (mapc #'delete-file files)) (load "gclload1.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/catch.lsp0000644000000000000000000000013014542551762015251 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.425788889 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/catch.lsp0000644000175000017500000000352714542551762014660 0ustar00cammcamm;-*- 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) ;;; No implicit tagbody (deftest catch.13 (block done (tagbody (catch 'foo (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest catch.14 (macrolet ((%m (z) z)) (catch 'foo (expand-in-current-env (%m :good)))) :good) (deftest catch.15 (macrolet ((%m (z) z)) (catch 'foo (throw (expand-in-current-env (%m 'foo)) :good) :bad)) :good) (deftest catch.16 (macrolet ((%m (z) z)) (catch 'foo (throw 'foo (expand-in-current-env (%m :good))) :bad)) :good) (deftest throw-error (signals-error (throw (gensym) nil) control-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-load-form-saving-slots.lsp0000644000000000000000000000013214542551763021414 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.425788889 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-load-form-saving-slots.lsp0000644000175000017500000001361114542551763021014 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 11:54:54 2003 ;;;; Contains: Tests of MAKE-LOAD-FORM-SAVING-SLOTS (in-package :cl-test) ;;; These are tests of MAKE-LOAD-FORM-SAVING-SLOTS proper; tests involving ;;; file compilation will be located elsewhere. (defstruct mlfss-01 a b c) (deftest make-load-form-saving-slots.1 (let* ((obj (make-mlfss-01)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (values (length forms) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (eqt (class-of obj) (class-of newobj))))) 2 t) (deftest make-load-form-saving-slots.2 (let* ((obj (make-mlfss-01)) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(a b))))) (values (length forms) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (eqt (class-of obj) (class-of newobj))))) 2 t) (defclass mlfss-02 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (deftest make-load-form-saving-slots.3 (let* ((obj (make-instance 'mlfss-02)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c))))) 2 t (nil nil nil)) (deftest make-load-form-saving-slots.4 (let* ((obj (make-instance 'mlfss-02 :a 1 :b 'a :c '(x y z))) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(a b c))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (map-slot-value newobj '(a b c))))) 2 t (t t t) (1 a (x y z))) (deftest make-load-form-saving-slots.5 (let* ((obj (make-instance 'mlfss-02 :a #(x y z))) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(a b))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (slot-value newobj 'a)))) 2 t (t nil nil) #(x y z)) (deftest make-load-form-saving-slots.6 (let* ((obj (make-instance 'mlfss-02)) (forms (multiple-value-list (make-load-form-saving-slots obj :allow-other-keys nil)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c))))) 2 t (nil nil nil)) ;;; If :slot-names is missing, all initialized slots are retained (deftest make-load-form-saving-slots.7 (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (map-slot-value newobj '(a c))))) 2 t (t nil t) ((x) 6/5)) ;;; If :slot-names is present, all initialized slots in the list are retained (deftest make-load-form-saving-slots.8 (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(c))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (slot-value newobj 'c)))) 2 t (nil nil t) 6/5) ;; It takes an :environment parameter (deftest make-load-form-saving-slots.9 (let* ((obj (make-instance 'mlfss-02 :a 7 :c 64 :b 100)) (forms (multiple-value-list (make-load-form-saving-slots obj :environment nil)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (length forms) (eqt (class-of obj) (class-of newobj)) (map-slot-boundp* newobj '(a b c)) (map-slot-value newobj '(a b c))))) 2 t (t t t) (7 100 64)) (defpackage "CL-TEST-MLFSS-PACKAGE" (:use) (:export #:a)) (defstruct mlfss-03 cl-test-mlfss-package:a) (deftest make-load-form-savings-slots.10 (let* ((obj (make-mlfss-03 :a 17)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (mlfss-03-a obj) (length forms) (eqt (class-of obj) (class-of newobj)) (mlfss-03-a newobj)))) 17 2 t 17) (deftest make-load-form-savings-slots.11 (let* ((obj (make-mlfss-03 :a 17)) (forms (multiple-value-list (make-load-form-saving-slots obj :slot-names '(cl-test-mlfss-package:a))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (mlfss-03-a obj) (length forms) (eqt (class-of obj) (class-of newobj)) (mlfss-03-a newobj)))) 17 2 t 17) (defstruct mlfss-04 (a 0 :read-only t)) (deftest make-load-form-savings-slots.12 (let* ((obj (make-mlfss-04 :a 123)) (forms (multiple-value-list (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values (mlfss-04-a obj) (length forms) (eqt (class-of obj) (class-of newobj)) (mlfss-04-a newobj)))) 123 2 t 123) ;;; General error tests (deftest make-load-form-saving-slots.error.1 (signals-error (make-load-form-saving-slots) program-error) t) (deftest make-load-form-saving-slots.error.2 (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) :slot-names) program-error) t) (deftest make-load-form-saving-slots.error.3 (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) (gensym) t) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/slot-value.lsp0000644000000000000000000000013214542551763016265 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.425788889 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/slot-value.lsp0000644000175000017500000000732214542551763015667 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 10 16:16:59 2003 ;;;; Contains: Tests of SLOT-VALUE (in-package :cl-test) ;;; SLOT-VALUE is used extensively elsewhere. (defclass slot-value-class-01 () (a (b :type t) (c :type fixnum) (d :type float) (e :type symbol) (f :type short-float) (g :type single-float) (h :type double-float) (i :type long-float) (j :type rational) (k :type ratio) (l :type cons) (m :type string) (n :type vector) (o :type bit) )) (defparameter *slot-value-test-slot-names* '(a b c d e f g h i j k l m n o)) (defparameter *slot-value-test-slot-values* '(t nil 10 4.0 a 1.0s0 2.0f0 3.0d0 4.0l0 5/4 2/3 (a . b) "abcd" #(1 2 3 4) 1)) (deftest slot-value.1 (let ((obj (make-instance 'slot-value-class-01)) (slot-names *slot-value-test-slot-names*) (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names for val in slot-values unless (and (equal (multiple-value-list (setf (slot-value obj name) val)) (list val)) (equal (multiple-value-list (slot-value obj name)) (list val))) collect name)) nil) (defclass slot-value-class-02 (slot-value-class-01) ((a :allocation :class) (b :allocation :class) (c :allocation :class) (d :allocation :class) (e :allocation :class) (f :allocation :class) (g :allocation :class) (h :allocation :class) (i :allocation :class) (j :allocation :class) (k :allocation :class) (l :allocation :class) (m :allocation :class) (n :allocation :class) (o :allocation :class))) (deftest slot-value.2 (let ((obj (make-instance 'slot-value-class-02)) (slot-names *slot-value-test-slot-names*) (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names for val in slot-values unless (and (equal (multiple-value-list (setf (slot-value obj name) val)) (list val)) (equal (multiple-value-list (slot-value obj name)) (list val))) collect name)) nil) ;;; Order of evaluation test(s) (deftest slot-value.order.1 (let ((obj (make-instance 'slot-value-class-01)) (i 0) x y) (values (setf (slot-value obj 'a) t) (slot-value (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) i x y)) t t 2 1 2) (deftest slot-value.order.2 (let ((obj (make-instance 'slot-value-class-01)) (i 0) x y) (values (setf (slot-value (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'b)) t) (slot-value obj 'b) i x y)) t t 2 1 2) ;;; Error tests (deftest slot-value.error.1 (signals-error (slot-value) program-error) t) (deftest slot-value.error.2 (signals-error (slot-value (make-instance 'slot-value-class-01)) program-error) t) (deftest slot-value.error.3 (signals-error (let ((obj (make-instance 'slot-value-class-01))) (setf (slot-value obj 'a) t) (slot-value obj 'a nil)) program-error) t) (deftest slot-value.error.4 (handler-case (progn (slot-value (make-instance 'slot-value-class-01) (gensym)) :bad) (error () :good)) :good) (deftest slot-value.error.5 (let ((built-in-class (find-class 'built-in-class)) (slot-name (gensym))) (check-predicate #'(lambda (e) (let ((class (class-of e))) (or (not (eq (class-of class) built-in-class)) (handler-case (progn (slot-value e slot-name) nil) (error () t))))))) nil) (deftest slot-value.error.6 (let ((built-in-class (find-class 'built-in-class)) (slot-name (gensym))) (check-predicate #'(lambda (e) (let ((class (class-of e))) (or (not (eq (class-of class) built-in-class)) (handler-case (setf (slot-value e slot-name) nil) (error () t))))))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/packages-18.lsp0000644000000000000000000000013114542551763016175 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.425788889 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-18.lsp0000644000175000017500000000447214542551763015603 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/format-underscore.lsp0000644000000000000000000000013214542551762017630 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.437788942 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-underscore.lsp0000644000175000017500000001460114542551762017230 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 4 03:36:50 2004 ;;;; Contains: Tests of the ~_ format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-ppblock-test format._.1 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) ;; (write "B ") (pprint-newline :linear) (format t "B ~_") (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B A A A " :margin 10) (def-ppblock-test format._.2 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) ;; (write "B ") (pprint-newline :linear) (format t "B ~_") (dotimes (i 2) (write "C ") (pprint-newline :fill)) (format t "D ~_") (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B C C D A A A " :margin 10) (def-ppblock-test format._.3 (format t "A ~_A ~_A ~_A ~_") "A A A A " :margin 10) (def-ppblock-test format._.4 (format t "A ~_A ~_A ~_A ~_") "A A A A " :margin 10 :miser 10) (def-ppblock-test format._.5 (format t "A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_") "A A A A A A A A A A " :margin 10 :pretty nil) (def-ppblock-test format._.6 (dotimes (i 4) (format t "A ~_")) "A A A A " :margin 10) (def-ppblock-test format._.7 (format t "A ~_A ~_A ~_A ~_~%A ~_A ~_A ~_A ~_") "A A A A A A A A " :margin 10) (def-ppblock-test format._.8 (progn (pprint-logical-block (*standard-output* nil) (format t "A ~_A ~_A ~_A ~_")) (format t "~_") (pprint-logical-block (*standard-output* nil) (format t "A ~_A ~_A ~_A ~_"))) "A A A A A A A A " :margin 10) (deftest format._.9 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (format s "A ~_A ~_A ~_A ~_A ~_")))) "A A A A A ") (deftest formatter._.9 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~_A ~_A ~_A ~_A ~_")))) "A A A A A ") ;;; miser (def-ppblock-test format.@_.1 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10) (def-ppblock-test format.@_.2 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 0) (def-ppblock-test format.@_.3 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test format.@_.4 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test format.@_.5 (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") "A A A A A A A A A A " :margin 10 :miser 10 :pretty nil) (def-ppblock-test format.@_.6 (format t "~%A~@_") " A " :margin 20 :miser 20) (def-ppblock-test format.@_.7 (format t "~@_A~%") " A " :margin 20 :miser 20) (def-ppblock-test format.@_.8 (progn (format t "AAAA ~_") (pprint-logical-block (*standard-output* nil) (format t "A ~@_A ~@_A ~@_A ~@_"))) "AAAA A A A A " :margin 10 :miser 8) (def-ppblock-test format.@_.9 (progn (format t "AAAA ~:@_") (pprint-logical-block (*standard-output* nil) (format t "A ~@_A ~@_A ~@_A ~@_"))) "AAAA A A A A " :margin 10 :miser 8) (deftest format.@_.10 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* 4)) (format s "A ~@_A ~@_A ~@_A ~@_A ~@_")))) "A A A A A ") (deftest formatter.@_.10 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* 4)) (formatter-call-to-string (formatter "A ~@_A ~@_A ~@_A ~@_A ~@_")))) "A A A A A ") ;;; fill (def-ppblock-test format.\:_.1 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 10) (def-ppblock-test format.\:_.2 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 6) (def-ppblock-test format.\:_.3 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 7) (def-ppblock-test format.\:_.4 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test format.\:_.5 (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test format.\:_.6 (format t "~W~W~:_~W~W~:_~W~W~:_~W~W~:_~W~W~:_" '(A B) #\Space '(A B) #\Space '(A B) #\Space '(A B) #\Space '(A B) #\Space) "(A B) (A B) (A B) (A B) (A B) " :margin 12) (deftest format.\:_.7 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* nil)) (format s "A ~:_A ~:_A ~:_A ~:_A ~:_")))) "A A A A A ") (deftest formatter.\:_.7 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~:_A ~:_A ~:_A ~:_A ~:_")))) "A A A A A ") ;;; mandatory (def-ppblock-test format.\:@_.1 (format t "A ~:@_A ~:@_A ~:@_A ~:@_") "A A A A ") (def-ppblock-test format.\:@_.2 (format t "A ~@:_A ~@:_A ~@:_A ~@:_") "A A A A " :margin 10) (def-ppblock-test format.\:@_.3 (format t "A ~@:_A ") "A A " :margin 1) (def-ppblock-test format.\:@_.4 (format t "A ~@:_A ~@:_A ~@:_A ~@:_") "A A A A " :pretty nil) (deftest format.\:@_.5 (with-output-to-string (s) (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (format s "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) "A A A A A ") (deftest formatter.\:@_.5 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) "A A A A A ") gcl-2.7.1/ansi-tests/PaxHeaders/sinh.lsp0000644000000000000000000000013214542551763015133 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.437788942 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sinh.lsp0000644000175000017500000000361114542551763014532 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 06:29:51 2004 ;;;; Contains: Tests for SINH (in-package :cl-test) (deftest sinh.1 (let ((result (sinh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest sinh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (sinh zero)) (list zero)) collect type) nil) (deftest sinh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (sinh zero)) (list zero)) collect type) nil) (deftest sinh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (sinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest sinh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (sinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest sinh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (sinh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest sinh.error.1 (signals-error (sinh) program-error) t) (deftest sinh.error.2 (signals-error (sinh 1.0 1.0) program-error) t) (deftest sinh.error.3 (check-type-error #'sinh #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/find-if-not.lsp0000644000000000000000000000013214542551762016303 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.437788942 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find-if-not.lsp0000644000175000017500000003470114542551762015706 0ustar00cammcamm;-*- 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))) (deftest find-if-not-string.19 (do-special-strings (s "abc1def" nil) (assert (eql (find-if-not #'alpha-char-p s) #\1))) nil) ;;; 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 (check-type-error #'(lambda (x) (find-if-not #'null x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest find-if-not.error.4 (signals-error (find-if-not 'identity '(a b c . d)) type-error) t) (deftest find-if-not.error.5 (signals-error (find-if-not) program-error) t) (deftest find-if-not.error.6 (signals-error (find-if-not #'null) program-error) t) (deftest find-if-not.error.7 (signals-error (find-if-not #'null nil :bad t) program-error) t) (deftest find-if-not.error.8 (signals-error (find-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest find-if-not.error.9 (signals-error (find-if-not #'null nil 1 1) program-error) t) (deftest find-if-not.error.10 (signals-error (find-if-not #'null nil :key) program-error) t) (deftest find-if-not.error.11 (signals-error (locally (find-if-not #'null 'b) t) type-error) t) (deftest find-if-not.error.12 (signals-error (find-if-not #'cons '(a b c)) program-error) t) (deftest find-if-not.error.13 (signals-error (find-if-not #'car '(a b c)) type-error) t) (deftest find-if-not.error.14 (signals-error (find-if-not #'identity '(a b c) :key #'cons) program-error) t) (deftest find-if-not.error.15 (signals-error (find-if-not #'identity '(a b c) :key #'car) type-error) t) ;;; 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) (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) (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.7.1/ansi-tests/PaxHeaders/nunion.lsp0000644000000000000000000000013114542551763015477 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.441788959 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nunion.lsp0000644000175000017500000002265414542551763015107 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:42:35 2003 ;;;; Contains: Tests of NUNION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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")) (defharmless nunion.test-and-test-not.1 (nunion (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql)) (defharmless nunion.test-and-test-not.2 (nunion (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql)) ;; 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 (signals-error (nunion) program-error) t) (deftest nunion.error.2 (signals-error (nunion nil) program-error) t) (deftest nunion.error.3 (signals-error (nunion nil nil :bad t) program-error) t) (deftest nunion.error.4 (signals-error (nunion nil nil :key) program-error) t) (deftest nunion.error.5 (signals-error (nunion nil nil 1 2) program-error) t) (deftest nunion.error.6 (signals-error (nunion nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nunion.error.7 (signals-error (nunion (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest nunion.error.8 (signals-error (nunion (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest nunion.error.9 (signals-error (nunion (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest nunion.error.10 (signals-error (nunion (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest nunion.error.11 (signals-error (nunion (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest nunion.error.12 (signals-error (nunion (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nunion.error.13 (check-type-error #'(lambda (x) (nunion x (list 1 2 3))) #'listp) nil) (deftest nunion.error.14 (check-type-error #'(lambda (x) (nunion (list 1 2 3) x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/shadowing-import.lsp0000644000000000000000000000013214542551763017465 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.441788959 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/shadowing-import.lsp0000644000175000017500000001050114542551763017060 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 07:42:18 2004 ;;;; Contains: Tests for SHADOWING-IMPORT (in-package :cl-test) (deftest shadowing-import.1 (let ((name1 "TEST1") (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 (let* ((p1 (make-package name1 :use nil)) (p2 (make-package name2)) (s1 (intern "X" p1)) (s2 (intern "X" p2))) (list (eqt s1 s2) (eqt (find-symbol "X" p2) s2) (shadowing-import s1 p2) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t t)) (deftest shadowing-import.2 (let ((name1 "TEST1") (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 (let* ((p1 (make-package name1 :use nil)) (p2 (make-package name2)) (s1 (intern "X" p1))) (list (find-symbol "X" p2) (shadowing-import s1 p2) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t)) (deftest shadowing-import.3 (let ((name1 "TEST1") (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 (let* ((p1 (make-package name1 :use nil)) (p2 (make-package name2 :use nil)) (s1 (intern "X" p1)) (s2 (intern "X" p2))) (list (eqt s1 s2) (eqt (find-symbol "X" p2) s2) (let ((*package* p2)) (shadowing-import s1)) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t t)) (deftest shadowing-import.4 (let ((name1 "TEST1") (name2 "TEST2") (name3 "TEST3")) (safely-delete-package name1) (safely-delete-package name2) (safely-delete-package name3) (prog1 (let* ((p1 (make-package name1 :use nil)) (p3 (make-package name2 :use nil)) (p2 (make-package name3 :use (list p3))) (s1 (intern "X" p1)) (s2 (intern "X" p3))) (export s2 p3) (list (eqt s1 s2) (eqt (find-symbol "X" p2) s2) (shadowing-import s1 p2) (equalt (package-shadowing-symbols p2) (list s1)) (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name3) (safely-delete-package name2))) (nil t t t t)) ;;; Specialized sequence tests (defmacro def-shadowing-import-test (test-name name-form) `(deftest ,test-name (let ((name1 ,name-form)) (safely-delete-package name1) (prog1 (let* ((p1 (make-package name1 :use nil))) (list (find-symbol "T" p1) (shadowing-import t name1) (package-shadowing-symbols p1) (find-symbol "T" p1))) (safely-delete-package name1))) (nil t (t) t))) (def-shadowing-import-test shadowing-import.5 (make-array '(5) :initial-contents "TEST1" :element-type 'base-char)) (def-shadowing-import-test shadowing-import.6 (make-array '(7) :initial-contents "TEST1XX" :fill-pointer 7 :element-type 'character)) (def-shadowing-import-test shadowing-import.7 (make-array '(7) :initial-contents "TEST1XX" :fill-pointer 7 :element-type 'base-char)) (def-shadowing-import-test shadowing-import.8 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-shadowing-import-test shadowing-import.9 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-shadowing-import-test shadowing-import.10 (let* ((etype 'character) (name2 (make-array '(10) :initial-contents "ABTEST1CDE" :element-type etype))) (make-array '(5) :element-type etype :displaced-to name2 :displaced-index-offset 2))) (def-shadowing-import-test shadowing-import.11 (let* ((etype 'base-char) (name2 (make-array '(10) :initial-contents "ABTEST1CDE" :element-type etype))) (make-array '(5) :element-type etype :displaced-to name2 :displaced-index-offset 2))) ;;; Error tests (deftest shadowing-import.error.1 (signals-error (shadowing-import) program-error) t) (deftest shadowing-import.error.2 (signals-error (shadowing-import nil *package* nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-array.lsp0000644000000000000000000000013114542551763017160 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.441788959 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-array.lsp0000644000175000017500000001725614542551763016572 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 1 16:23:57 2003 ;;;; Contains: Tests of SUBTYPEP on array types (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; *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.array.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.array.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) (deftest subtypep.array.8 (let ((limit (min 16 array-rank-limit))) (loop for i below limit for type1 = `(array t ,i) nconc (loop for j below limit for type2 = `(array t ,j) when (and (/= i j) (subtypep type1 type2)) collect (list type1 type2)))) nil) (deftest subtypep.array.9 (let ((limit (min 16 array-rank-limit))) (loop for i below limit for type1 = `(array t ,(make-list i :initial-element 1)) nconc (loop for j below limit for type2 = `(array t ,(make-list j :initial-element 1)) when (and (/= i j) (subtypep type1 type2)) collect (list type1 type2)))) nil) (deftest subtypep.array.10 (subtypep* '(array t nil) 'integer) nil t) (deftest subtypep.array.11 (subtypep* '(array t nil) '(array t (*))) nil t) (deftest subtypep.array.12 (subtypep* '(array t nil) '(array t 1)) nil t) (deftest subtypep.array.13 (subtypep* '(array bit nil) '(array bit 1)) nil t) ;;;; Tests on the definitions of various vector types (deftest string-is-not-vector-of-character.1 :notes (:nil-vectors-are-strings) (subtypep* 'string '(vector character)) nil t) (deftest vector-of-character-is-string.2 (subtypep* '(vector character) 'string) t t) (deftest string-is-not-vector-of-character.3 :notes (:nil-vectors-are-strings) (subtypep* '(string *) '(vector character)) nil t) (deftest vector-of-character-is-string.4 (subtypep* '(vector character) '(string *)) t t) (deftest string-is-not-vector-of-character.5 :notes (:nil-vectors-are-strings) (subtypep* '(string 17) '(vector character 17)) nil t) (deftest vector-of-character-is-string.6 (subtypep* '(vector character 17) '(string 17)) t t) (deftest base-string-is-vector-of-base-char.1 (subtypep* 'base-string '(vector base-char)) t t) (deftest base-string-is-vector-of-base-char.2 (subtypep* '(vector base-char) 'base-string) t t) (deftest base-string-is-vector-of-base-char.3 (subtypep* '(base-string *) '(vector base-char)) t t) (deftest base-string-is-vector-of-base-char.4 (subtypep* '(vector base-char) '(base-string *)) t t) (deftest base-string-is-vector-of-base-char.5 (subtypep* '(base-string 17) '(vector base-char 17)) t t) (deftest base-string-is-vector-of-base-char.6 (subtypep* '(vector base-char 17) '(base-string 17)) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.1 (subtypep* 'simple-base-string '(simple-array base-char (*))) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.2 (subtypep* '(simple-array base-char (*)) 'simple-base-string) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.3 (subtypep* '(simple-base-string *) '(simple-array base-char (*))) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.4 (subtypep* '(simple-array base-char (*)) '(simple-base-string *)) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.5 (subtypep* '(simple-base-string 17) '(simple-array base-char (17))) t t) (deftest simple-base-string-is-simple-1d-array-of-base-char.6 (subtypep* '(simple-array base-char (17)) '(simple-base-string 17)) t t) (deftest simple-string-is-not-simple-1d-array-of-character.1 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string '(simple-array character (*))) nil t) (deftest simple-1d-array-of-character-is-simple-string.2 (subtypep* '(simple-array character (*)) 'simple-string) t t) (deftest simple-string-is-not-simple-1d-array-of-character.3 :notes (:nil-vectors-are-strings) (subtypep* '(simple-string *) '(simple-array character (*))) nil t) (deftest simple-1d-array-of-character-is-simple-string.4 (subtypep* '(simple-array character (*)) '(simple-string *)) t t) (deftest simple-string-is-not-simple-1d-array-of-character.5 :notes (:nil-vectors-are-strings) (subtypep* '(simple-string 17) '(simple-array character (17))) nil t) (deftest simple-1d-array-of-character-is-simple-string.6 (subtypep* '(simple-array character (17)) '(simple-string 17)) t t) (deftest vector-is-1d-array.1 (subtypep* 'vector '(array * (*))) t t) (deftest vector-is-1d-array.2 (subtypep* '(array * (*)) 'vector) t t) (deftest vector-is-1d-array.3 (subtypep* '(vector *) '(array * (*))) t t) (deftest vector-is-1d-array.4 (subtypep* '(array * (*)) '(vector *)) t t) (deftest vector-is-1d-array.5 (subtypep* '(vector * 17) '(array * (17))) t t) (deftest vector-is-1d-array.6 (subtypep* '(array * (17)) '(vector * 17)) t t) (deftest simple-vector-is-simple-1d-array.1 (subtypep* 'simple-vector '(simple-array t (*))) t t) (deftest simple-vector-is-simple-1d-array.2 (subtypep* '(simple-array t (*)) 'simple-vector) t t) (deftest simple-vector-is-simple-1d-array.3 (subtypep* '(simple-vector *) '(simple-array t (*))) t t) (deftest simple-vector-is-simple-1d-array.4 (subtypep* '(simple-array t (*)) '(simple-vector *)) t t) (deftest simple-vector-is-simple-1d-array.5 (subtypep* '(simple-vector 17) '(simple-array t (17))) t t) (deftest simple-vector-is-simple-1d-array.6 (subtypep* '(simple-array t (17)) '(simple-vector 17)) t t) gcl-2.7.1/ansi-tests/PaxHeaders/gclload2.lsp0000644000000000000000000000013214772071545015661 xustar0030 mtime=1743287141.302897793 30 atime=1744294960.441788959 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/gclload2.lsp0000644000175000017500000000262514772071545015264 0ustar00cammcamm;;; 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 objects (load "load-objects.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 "load-hash-tables.lsp") ;;; Tests of packages (load "load-packages.lsp") ;;; Tests of numbers (section 12) (load "load-numbers.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 strings (load "load-strings.lsp") ;;; Tests for character functions (load "load-characters.lsp") ;;; Tests of pathnames (load "load-pathnames.lsp") ;;; Tests of file operations (load "load-files.lsp") ;;; Tests of streams (load "load-streams.lsp") ;;; Tests of the printer (load "load-printer.lsp") ;;; Tests of the reader (load "load-reader.lsp") ;;; Tests of system construction (load "load-system-construction.lsp") ;;; Tests of environment (load "load-environment.lsp") ;;; Miscellaneous tests, mostly tests that failed in random testing ;;; on various implementations (load "load-misc.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/package-nicknames.lsp0000644000000000000000000000013114542551763017532 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.441788959 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-nicknames.lsp0000644000175000017500000000717314542551763017141 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:51:26 1998 ;;;; Contains: Tests of PACKAGE-NICKNAMES (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-nicknames (deftest package-nicknames.1 (progn (set-up-packages) (package-nicknames "A")) ("Q")) (deftest package-nicknames.2 (progn (set-up-packages) (package-nicknames #\A)) ("Q")) (deftest package-nicknames.3 (progn (set-up-packages) (package-nicknames ':|A|)) ("Q")) (deftest package-nicknames.4 (progn (set-up-packages) (package-nicknames "B")) nil) (deftest package-nicknames.5 (progn (set-up-packages) (package-nicknames #\B)) nil) (deftest package-nicknames.6 (progn (set-up-packages) (package-nicknames '#:|B|)) nil) (deftest package-nicknames.7 (subsetp '(#.(string '#:cl)) (package-nicknames "COMMON-LISP") :test #'string=) t) (deftest package-nicknames.8 (notnot (subsetp '(#.(string '#:cl-user)) (package-nicknames "COMMON-LISP-USER") :test #'string=)) t) (deftest package-nicknames.9 (signals-error (package-nicknames 10) type-error) t) (deftest package-nicknames.9a (signals-error (locally (package-nicknames 10) t) type-error) t) (deftest package-nicknames.10 (progn (set-up-packages) (package-nicknames (find-package "A"))) ("Q")) (deftest package-nicknames.11 (handler-case (locally (declare (optimize safety)) (eval '(package-nicknames "NOT-A-PACKAGE-NAME")) nil) (type-error () t) (package-error () t)) 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) ;;; Specialized sequence names tests (defmacro def-package-nicknames-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-nicknames p))) nil)) (def-package-nicknames-test package-nicknames.16 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.17 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-nicknames-test package-nicknames.18 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-nicknames-test package-nicknames.19 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.20 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.21 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-nicknames-test package-nicknames.22 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-nicknames.error.1 (signals-error (package-nicknames) program-error) t) (deftest package-nicknames.error.2 (signals-error (package-nicknames "CL" nil) program-error) t) (deftest package-nicknames.error.3 (check-type-error #'package-nicknames #'package-designator-p) nil) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-float.lsp0000644000000000000000000000013114542551763017147 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.441788959 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-float.lsp0000644000175000017500000002577614542551763016567 0ustar00cammcamm;-*- 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) (compile-and-load "types-aux.lsp") ;;;;;;; (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) ;;; Signed zero tests (deftest subtypep.short-float.zero.1 (check-equivalence '(short-float 0.0s0 *) '(or (short-float (0.0s0) *) (member -0.0s0 0.0s0))) nil) (unless (eql 0.0s0 -0.0s0) (deftest subtypep.short-float.zero.2a (values (subtypep '(short-float 0.0s0) '(or (short-float (0.0s0)) (member 0.0s0)))) nil) (deftest subtypep.short-float.zero.2b (values (subtypep '(short-float 0.0s0) '(or (short-float (0.0s0)) (member -0.0s0)))) nil)) (deftest subtypep.short-float.zero.3 (subtypep* '(short-float -0.0s0 *) '(short-float 0.0s0 *)) t t) (deftest subtypep.short-float.zero.4 (subtypep* '(short-float * -0.0s0) '(short-float * 0.0s0)) t t) (deftest subtypep.short-float.zero.5 (subtypep* '(short-float (-0.0s0) *) '(short-float (0.0s0) *)) t t) (deftest subtypep.short-float.zero.6 (subtypep* '(short-float * (-0.0s0)) '(short-float * (0.0s0))) t t) (deftest subtypep.short-float.zero.7 (subtypep* '(short-float 0.0s0 *) '(short-float -0.0s0 *)) t t) (deftest subtypep.short-float.zero.8 (subtypep* '(short-float * 0.0s0) '(short-float * -0.0s0)) t t) (deftest subtypep.short-float.zero.9 (subtypep* '(short-float (0.0s0) *) '(short-float (-0.0s0) *)) t t) (deftest subtypep.short-float.zero.10 (subtypep* '(short-float * (0.0s0)) '(short-float * (-0.0s0))) t t) ;;; (deftest subtypep.float.zero.3 (subtypep* '(float -0.0 *) '(float 0.0 *)) t t) (deftest subtypep.float.zero.4 (subtypep* '(float * -0.0) '(float * 0.0)) t t) (deftest subtypep.float.zero.5 (subtypep* '(float (-0.0) *) '(float (0.0) *)) t t) (deftest subtypep.float.zero.6 (subtypep* '(float * (-0.0)) '(float * (0.0))) t t) (deftest subtypep.float.zero.7 (subtypep* '(float 0.0 *) '(float -0.0 *)) t t) (deftest subtypep.float.zero.8 (subtypep* '(float * 0.0) '(float * -0.0)) t t) (deftest subtypep.float.zero.9 (subtypep* '(float (0.0) *) '(float (-0.0) *)) t t) (deftest subtypep.float.zero.10 (subtypep* '(float * (0.0)) '(float * (-0.0))) t t) ;;; (deftest subtypep.single-float.zero.1 (check-equivalence '(single-float 0.0f0 *) '(or (single-float (0.0f0) *) (member -0.0f0 0.0f0))) nil) (unless (eql 0.0f0 -0.0f0) (deftest subtypep.single-float.zero.2a (values (subtypep '(single-float 0.0f0) '(or (single-float (0.0f0)) (member 0.0f0)))) nil) (deftest subtypep.single-float.zero.2b (values (subtypep '(single-float 0.0f0) '(or (single-float (0.0f0)) (member -0.0f0)))) nil)) (deftest subtypep.single-float.zero.3 (subtypep* '(single-float -0.0f0 *) '(single-float 0.0f0 *)) t t) (deftest subtypep.single-float.zero.4 (subtypep* '(single-float * -0.0f0) '(single-float * 0.0f0)) t t) (deftest subtypep.single-float.zero.5 (subtypep* '(single-float (-0.0f0) *) '(single-float (0.0f0) *)) t t) (deftest subtypep.single-float.zero.6 (subtypep* '(single-float * (-0.0f0)) '(single-float * (0.0f0))) t t) (deftest subtypep.single-float.zero.7 (subtypep* '(single-float 0.0f0 *) '(single-float -0.0f0 *)) t t) (deftest subtypep.single-float.zero.8 (subtypep* '(single-float * 0.0f0) '(single-float * -0.0f0)) t t) (deftest subtypep.single-float.zero.9 (subtypep* '(single-float (0.0f0) *) '(single-float (-0.0f0) *)) t t) (deftest subtypep.single-float.zero.10 (subtypep* '(single-float * (0.0f0)) '(single-float * (-0.0f0))) t t) ;;; (deftest subtypep.long-float.zero.1 (check-equivalence '(long-float 0.0l0 *) '(or (long-float (0.0l0) *) (member -0.0l0 0.0l0))) nil) (unless (eql 0.0l0 -0.0l0) (deftest subtypep.long-float.zero.2a (values (subtypep '(long-float 0.0l0) '(or (long-float (0.0l0)) (member 0.0l0)))) nil) (deftest subtypep.long-float.zero.2b (values (subtypep '(long-float 0.0l0) '(or (long-float (0.0l0)) (member -0.0l0)))) nil)) (deftest subtypep.long-float.zero.3 (subtypep* '(long-float -0.0l0 *) '(long-float 0.0l0 *)) t t) (deftest subtypep.long-float.zero.4 (subtypep* '(long-float * -0.0l0) '(long-float * 0.0l0)) t t) (deftest subtypep.long-float.zero.5 (subtypep* '(long-float (-0.0l0) *) '(long-float (0.0l0) *)) t t) (deftest subtypep.long-float.zero.6 (subtypep* '(long-float * (-0.0l0)) '(long-float * (0.0l0))) t t) (deftest subtypep.long-float.zero.7 (subtypep* '(long-float 0.0l0 *) '(long-float -0.0l0 *)) t t) (deftest subtypep.long-float.zero.8 (subtypep* '(long-float * 0.0l0) '(long-float * -0.0l0)) t t) (deftest subtypep.long-float.zero.9 (subtypep* '(long-float (0.0l0) *) '(long-float (-0.0l0) *)) t t) (deftest subtypep.long-float.zero.10 (subtypep* '(long-float * (0.0l0)) '(long-float * (-0.0l0))) t t) ;;; (deftest subtypep.double-float.zero.1 (check-equivalence '(double-float 0.0d0 *) '(or (double-float (0.0d0) *) (member -0.0d0 0.0d0))) nil) (unless (eql 0.0d0 -0.0d0) (deftest subtypep.double-float.zero.2a (values (subtypep '(double-float 0.0d0) '(or (double-float (0.0d0)) (member 0.0d0)))) nil) (deftest subtypep.double-float.zero.2b (values (subtypep '(double-float 0.0d0) '(or (double-float (0.0d0)) (member -0.0d0)))) nil)) (deftest subtypep.double-float.zero.3 (subtypep* '(double-float -0.0d0 *) '(double-float 0.0d0 *)) t t) (deftest subtypep.double-float.zero.4 (subtypep* '(double-float * -0.0d0) '(double-float * 0.0d0)) t t) (deftest subtypep.double-float.zero.5 (subtypep* '(double-float (-0.0d0) *) '(double-float (0.0d0) *)) t t) (deftest subtypep.double-float.zero.6 (subtypep* '(double-float * (-0.0d0)) '(double-float * (0.0d0))) t t) (deftest subtypep.double-float.zero.7 (subtypep* '(double-float 0.0d0 *) '(double-float -0.0d0 *)) t t) (deftest subtypep.double-float.zero.8 (subtypep* '(double-float * 0.0d0) '(double-float * -0.0d0)) t t) (deftest subtypep.double-float.zero.9 (subtypep* '(double-float (0.0d0) *) '(double-float (-0.0d0) *)) t t) (deftest subtypep.double-float.zero.10 (subtypep* '(double-float * (0.0d0)) '(double-float * (-0.0d0))) t t) gcl-2.7.1/ansi-tests/PaxHeaders/case.lsp0000644000000000000000000000013014542551762015102 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.441788959 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/case.lsp0000644000175000017500000000706114542551762014506 0ustar00cammcamm;-*- 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) ;;; No implicit tagbody (deftest case.35 (block done (tagbody (case 'a (a (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) (deftest case.36 (block done (tagbody (case 'b (a 'bad) (otherwise (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest case.37 (macrolet ((%m (z) z)) (case (expand-in-current-env (%m :b)) (:a :bad1) (:b :good) (:c :bad2) (t :bad3))) :good) ;;; (deftest case.error.1 ;;; (signals-error (case) program-error) ;;; t) (deftest case.error.1 (signals-error (funcall (macro-function 'case)) program-error) t) (deftest case.error.2 (signals-error (funcall (macro-function 'case) '(case t)) program-error) t) (deftest case.error.3 (signals-error (funcall (macro-function 'case) '(case t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/character.lsp0000644000000000000000000000013014542551762016123 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.441788959 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/character.lsp0000644000175000017500000002704714542551762015535 0ustar00cammcamm;-*- 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 (signals-error (character) program-error) t) (deftest character.error.2 (signals-error (character #\a #\a) program-error) t) ;;; (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 (signals-error (characterp) program-error) t) (deftest characterp.error.2 (signals-error (characterp #\a #\b) program-error) t) (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.4 (macrolet ((%m (z) z)) (alpha-char-p (expand-in-current-env (%m #\?)))) nil) (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 (signals-error (alpha-char-p) program-error) t) (deftest alpha-char-p.error.2 (signals-error (alpha-char-p #\a #\b) program-error) t) ;;; (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 alphanumbericp.6 (macrolet ((%m (z) z)) (alphanumericp (expand-in-current-env (%m #\=)))) nil) (deftest alphanumericp.order.1 (let ((i 0)) (values (alphanumericp (progn (incf i) #\?)) i)) nil 1) (deftest alphanumericp.error.1 (signals-error (alphanumericp) program-error) t) (deftest alphanumericp.error.2 (signals-error (alphanumericp #\a #\b) program-error) t) ;;; (deftest digit-char.1 (digit-char.1.body) nil) (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 (signals-error (digit-char) program-error) t) (deftest digit-char.error.2 (signals-error (digit-char 0 10 'foo) program-error) t) ;;; (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 (signals-error (digit-char-p) program-error) t) (deftest digit-char-p.error.2 (signals-error (digit-char-p #\1 10 'foo) program-error) t) ;;; (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 (signals-error (graphic-char-p) program-error) t) (deftest graphic-char-p.error.2 (signals-error (graphic-char-p #\a #\a) program-error) t) ;;; (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 (signals-error (standard-char-p) program-error) t) (deftest standard-char-p.error.2 (signals-error (standard-char-p #\a #\a) program-error) t) ;;; (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 (signals-error (char-upcase) program-error) t) (deftest char-upcase.error.2 (signals-error (char-upcase #\a #\a) program-error) t) ;;; (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 (signals-error (char-downcase) program-error) t) (deftest char-downcase.error.2 (signals-error (char-downcase #\A #\A) program-error) t) ;;; (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 (signals-error (upper-case-p) program-error) t) (deftest upper-case-p.error.2 (signals-error (upper-case-p #\a #\A) program-error) t) ;;; (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 (signals-error (lower-case-p) program-error) t) (deftest lower-case-p.error.2 (signals-error (lower-case-p #\a #\a) program-error) t) ;;; (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.4 (notnot (macrolet ((%m (z) z)) (both-case-p (expand-in-current-env (%m #\a))))) 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 (signals-error (both-case-p) program-error) t) (deftest both-case-p.error.2 (signals-error (both-case-p #\a #\a) program-error) t) ;;; (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 (signals-error (char-code) program-error) t) (deftest char-code.error.2 (signals-error (char-code #\a #\a) program-error) t) ;;; (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 (signals-error (code-char) program-error) t) (deftest code-char.error.2 (signals-error (code-char 1 1) program-error) t) ;;; (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) nil) (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 (signals-error (char-int) program-error) t) (deftest char-int.error.2 (signals-error (char-int #\a #\a) program-error) t) ;;; (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 (signals-error (char-name) program-error) t) (deftest char-name.error.2 (signals-error (char-name #\a #\a) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/lambda-parameters-limit.lsp0000644000000000000000000000013114542551762020665 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.441788959 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/lambda-parameters-limit.lsp0000644000175000017500000000056714542551762020274 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/time.lsp0000644000000000000000000000013114542551763015127 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.441788959 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/time.lsp0000644000175000017500000000354614542551763014536 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 09:43:47 2004 ;;;; Contains: Tests of TIME (in-package :cl-test) (deftest time.1 (let ((s (with-output-to-string (*trace-output*) (assert (null (time nil)))))) (= (length s) 0)) nil) (deftest time.2 (let ((s (with-output-to-string (*trace-output*) (let ((x (cons 'a 'b))) (assert (eq (time x) x)))))) (= (length s) 0)) nil) (deftest time.3 (let ((s (with-output-to-string (*trace-output*) (let ((x (cons 'a 'b))) (flet ((%f () x)) (assert (eq (time (%f)) x))))))) (= (length s) 0)) nil) (deftest time.4 (let ((s (with-output-to-string (*trace-output*) (assert (null (multiple-value-list (time (values)))))))) (= (length s) 0)) nil) (deftest time.5 (let ((s (with-output-to-string (*trace-output*) (assert (equal '(a b c d) (multiple-value-list (time (values 'a 'b 'c 'd)))))))) (= (length s) 0)) nil) (deftest time.6 (let ((fn (compile nil '(lambda () (time nil))))) (let ((s (with-output-to-string (*trace-output*) (assert (null (funcall fn)))))) (= (length s) 0))) nil) (deftest time.7 (flet ((%f () (time nil))) (let ((s (with-output-to-string (*trace-output*) (assert (null (%f)))))) (= (length s) 0))) nil) (deftest time.8 (let ((s (with-output-to-string (*trace-output*) (macrolet ((%m () 1)) (assert (eql (time (%m)) 1)))))) (= (length s) 0)) nil) ;;; The TIME definition is weasely, so strenuous complaints from ;;; implementors about specific tests lead me to remove them. ;;; Someone didn't like this one at all. #| (deftest time.9 (let ((s (with-output-to-string (*trace-output*) (block done (time (return-from done nil)))))) (= (length s) 0)) nil) |# gcl-2.7.1/ansi-tests/PaxHeaders/loop15.lsp0000644000000000000000000000013214542551763015311 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.441788959 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop15.lsp0000644000175000017500000001176714542551763014723 0ustar00cammcamm;-*- 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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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.7.1/ansi-tests/PaxHeaders/format-c.lsp0000644000000000000000000000013214542551762015701 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.441788959 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-c.lsp0000644000175000017500000000604514542551762015304 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 23:07:16 2004 ;;;; Contains: Tests of formatted output, ~C directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Test of the ~C directive (deftest format.c.1 (loop for c across +standard-chars+ for s = (format nil "~C" c) unless (string= s (string c)) collect (list c s)) nil) (deftest format.c.1a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~c" c)) unless (or (not c) (not (eql (char-code c) (char-int c))) (string= s (string c))) do (incf count) and collect (list i c s) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.2 (loop for c across +standard-chars+ for s = (format nil "~:c" c) unless (or (not (graphic-char-p c)) (eql c #\Space) (string= s (string c))) collect (list c s)) nil) (deftest format.c.2a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~:C" c)) unless (or (not c) (not (eql (char-code c) (char-int c))) (not (graphic-char-p c)) (eql c #\Space) (string= s (string c))) do (incf count) and collect (list i c s) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (def-format-test format.c.3 "~:C" (#\Space) #.(char-name #\Space)) (deftest format.c.4 (loop for c across +standard-chars+ for s = (format nil "~:C" c) unless (or (graphic-char-p c) (string= s (char-name c))) collect (list c (char-name c) s)) nil) (deftest format.c.4a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~:c" c)) unless (or (not c) (not (eql (char-code c) (char-int c))) (graphic-char-p c) (string= s (char-name c))) do (incf count) and collect (print (list i c s)) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.5 (loop for c across +standard-chars+ for s = (format nil "~@c" c) for c2 = (read-from-string s) unless (eql c c2) collect (list c s c2)) nil) (deftest format.c.5a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (format nil "~@C" c)) for c2 = (and c (read-from-string s)) unless (eql c c2) do (incf count) and collect (list c s c2) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.6 (loop for c across +standard-chars+ for s1 = (format nil "~:C" c) for s2 = (format nil "~:@C" c) unless (eql (search s1 s2) 0) collect (list c s1 s2)) nil) (deftest format.c.6a (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s1 = (and c (format nil "~:C" c)) for s2 = (and c (format nil "~@:C" c)) unless (or (not c) (eql (search s1 s2) 0)) do (incf count) and collect (list c s1 s2) when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/peek-char.lsp0000644000000000000000000000013114542551763016030 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.449788995 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/peek-char.lsp0000644000175000017500000001511214542551763015427 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/nsubstitute-if.lsp0000644000000000000000000000013114542551763017156 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.453789012 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nsubstitute-if.lsp0000644000175000017500000005760014542551763016565 0ustar00cammcamm;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-list.8 (nsubstitute-if 'b (is-eql-p 'a) nil :from-end t) nil) (deftest nsubstitute-if-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x)) #()) (deftest nsubstitute-if-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x)) #(b b b c)) (deftest nsubstitute-if-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-vector.8 (let ((x #())) (nsubstitute-if 'b (is-eql-p 'a) x :from-end t)) #()) (deftest nsubstitute-if-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest nsubstitute-if-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b x d a b c d a b c d)) (deftest nsubstitute-if-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b x d a b c d)) ;;; Tests on strings (deftest nsubstitute-if-string.1 (let ((x "")) (nsubstitute-if #\b (is-eql-p #\a) x)) "") (deftest nsubstitute-if-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x)) "bbbc") (deftest nsubstitute-if-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-string.8 (let ((x "")) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t)) "") (deftest nsubstitute-if-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t :count nil)) "bbbc") (deftest nsubstitute-if-string.11 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-if-string.12 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 1 :from-end t)) "abbc") (deftest nsubstitute-if-string.13 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 0 :from-end t)) "abac") (deftest nsubstitute-if-string.14 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-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-eql-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-eql-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-eql-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-eql-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") (deftest nsubstitute-if-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s) "xyz!bcxyz!bc")) (assert (string= s "xyz!bcxyz!bc"))) nil) (deftest nsubstitute-if-string.33 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s :count 1) "xyz!bcxyzabc")) (assert (string= s "xyz!bcxyzabc"))) nil) (deftest nsubstitute-if-string.34 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyz!bc"))) nil) ;;; Tests on bit-vectors (deftest nsubstitute-if-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eql-p 1) x))) result) #*) (deftest nsubstitute-if-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eql-p 0) x))) result) #*) (deftest nsubstitute-if-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eql-p 1) x))) result) #*000000) (deftest nsubstitute-if-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eql-p 0) x))) result) #*111111) (deftest nsubstitute-if-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p #\1) x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-if-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if #\a (is-eql-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-eql-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-eql-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 (signals-error (nsubstitute-if) program-error) t) (deftest nsubstitute-if.error.2 (signals-error (nsubstitute-if 'a) program-error) t) (deftest nsubstitute-if.error.3 (signals-error (nsubstitute-if 'a #'null) program-error) t) (deftest nsubstitute-if.error.4 (signals-error (nsubstitute-if 'a #'null nil 'bad t) program-error) t) (deftest nsubstitute-if.error.5 (signals-error (nsubstitute-if 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest nsubstitute-if.error.6 (signals-error (nsubstitute-if 'a #'null nil :key) program-error) t) (deftest nsubstitute-if.error.7 (signals-error (nsubstitute-if 'a #'null nil 1 2) program-error) t) (deftest nsubstitute-if.error.8 (signals-error (nsubstitute-if 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest nsubstitute-if.error.9 (signals-error (nsubstitute-if 'a #'car (list 'a 'b 'c)) type-error) t) (deftest nsubstitute-if.error.10 (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest nsubstitute-if.error.11 (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest nsubstitute-if.error.12 (check-type-error #'(lambda (x) (nsubstitute-if 0 #'identity x)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/two-way-stream-output-stream.lsp0000644000000000000000000000013114542551763021720 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.453789012 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/two-way-stream-output-stream.lsp0000644000175000017500000000141014542551763021313 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/isqrt.lsp0000644000000000000000000000013114542551762015332 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.453789012 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/isqrt.lsp0000644000175000017500000000235714542551762014740 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 15:40:09 2003 ;;;; Contains: Tests of ISQRT (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest isqrt.error.1 (signals-error (isqrt) program-error) t) (deftest isqrt.error.2 (signals-error (isqrt 0 0) program-error) t) (deftest isqrt.error.3 (signals-error (isqrt 0 nil) program-error) t) (deftest isqrt.error.4 (signals-error (isqrt 0 0 0) program-error) t) (deftest isqrt.error.5 (loop for x in *mini-universe* unless (or (and (integerp x) (>= x 0)) (eval `(signals-type-error x ',x (isqrt x)))) collect x) nil) ;;; Non-error tests (deftest isqrt.1 (loop for i from 0 to 10000 for i2 = (* i i) for s = (isqrt i2) unless (eql s i) collect i) nil) (deftest isqrt.2 (loop for i = (random-from-interval most-positive-fixnum 0) for s = (isqrt i) repeat 1000 unless (and (integerp s) (>= s 0) (<= (* s s) i) (> (* (1+ s) (1+ s)) i)) collect (list i s)) nil) (deftest isqrt.3 (loop for i = (random-from-interval 1000000000000000 0) for s = (isqrt i) repeat 1000 unless (and (integerp s) (>= s 0) (<= (* s s) i) (> (* (1+ s) (1+ s)) i)) collect (list i s)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-append.lsp0000644000000000000000000000013214542551762023307 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.453789012 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-append.lsp0000644000175000017500000001607414542551762022715 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination APPEND (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.append.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.append.1 (x) (:method-combination append) (:method append ((x integer)) (car (push '(d) *x*))) (:method append ((x rational)) (car (push '(c) *x*))) (:method append ((x number)) (car (push '(b) *x*))) (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.append.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.append.2 (x) (:method-combination append :most-specific-first) (:method append ((x integer)) (car (push '(d) *x*))) (:method append ((x rational)) (car (push '(c) *x*))) (:method append ((x number)) (car (push '(b) *x*))) (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.append.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.append.3 (x) (:method-combination append :most-specific-last) (:method append ((x integer)) (car (push '(d) *x*))) (:method append ((x rational)) (car (push '(c) *x*))) (:method append ((x number)) (car (push '(b) *x*))) (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) ((d) (c) (b) (a))) ((a b c) ((c) (b) (a))) ((a b) ((b) (a))) ((a) ((a)))) (deftest defgeneric-method-combination.append.4 (let ((fn (eval '(defgeneric dg-mc.fun.append.4 (x) (:method-combination append) (:method append ((x integer)) '(a b)) (:method :around ((x rational)) 'foo) (:method append ((x number)) '(c d)) (:method append ((x symbol)) '(e f)) (:method append ((x t)) '(g h)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo (c d g h) (e f g h) (g h)) (deftest defgeneric-method-combination.append.5 (let ((fn (eval '(defgeneric dg-mc.fun.append.5 (x) (:method-combination append) (:method append ((x integer)) '(a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method append ((x number)) '(b)) (:method append ((x symbol)) '(c)) (:method append ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo (a b . d)) (foo (b . d)) (b . d) (c . d) d) (deftest defgeneric-method-combination.append.6 (let ((fn (eval '(defgeneric dg-mc.fun.append.6 (x) (:method-combination append) (:method append ((x integer)) '(a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method append ((x number)) '(b)) (:method append ((x symbol)) '(c)) (:method append ((x t)) '(d)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.append.7 (let ((fn (eval '(defgeneric dg-mc.fun.append.7 (x) (:method-combination append) (:method append ((x dgmc-class-04)) '(a)) (:method append ((x dgmc-class-03)) '(b)) (:method append ((x dgmc-class-02)) '(c)) (:method append ((x dgmc-class-01)) '(d)))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) (d) (c d) (b d) (a c b d)) (deftest defgeneric-method-combination.append.8 (let ((fn (eval '(defgeneric dg-mc.append.8 (x) (:method-combination append) (:method append ((x (eql 1000))) '(a)) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method append ((x t)) '(b)))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) ((b))) (deftest defgeneric-method-combination.append.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.append.9 (x) (:method-combination append))))) (declare (type generic-function fn)) (funcall fn '(a))) (error () :error)) :error) (deftest defgeneric-method-combination.append.10 (progn (eval '(defgeneric dg-mc.append.10 (x) (:method-combination append) (:method ((x t)) '(a)))) (handler-case (dg-mc.append.10 'x) (error () :error))) :error) (deftest defgeneric-method-combination.append.11 (progn (eval '(defgeneric dg-mc.append.11 (x) (:method-combination append) (:method nonsense ((x t)) '(a)))) (handler-case (dg-mc.append.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.append.12 (let ((fn (eval '(defgeneric dg-mc.append.12 (x) (:method-combination append) (:method :around ((x t)) '(a)) (:method append ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn '(b)) (error () :error))) :error) (deftest defgeneric-method-combination.append.13 (progn (eval '(defgeneric dg-mc.append.13 (x) (:method-combination append) (:method append ((x dgmc-class-01)) (list 'foo)) (:method append ((x dgmc-class-02)) (list 'bar)) (:method nonsense ((x dgmc-class-03)) (list 'bad)))) (values (dg-mc.append.13 (make-instance 'dgmc-class-01)) (dg-mc.append.13 (make-instance 'dgmc-class-02)) (handler-case (dg-mc.append.13 (make-instance 'dgmc-class-03)) (error () :caught)) (handler-case (dg-mc.append.13 (make-instance 'dgmc-class-04)) (error () :caught)) (handler-case (dg-mc.append.13 (make-instance 'dgmc-class-07)) (error () :caught)))) (foo) (bar foo) :caught :caught :caught) gcl-2.7.1/ansi-tests/PaxHeaders/cell-error-name.lsp0000644000000000000000000000013014542551762017153 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.453789012 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cell-error-name.lsp0000644000175000017500000000227414542551762016560 0ustar00cammcamm;-*- 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 (signals-error (cell-error-name) program-error) t) (deftest cell-error-name.error.2 (signals-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/byte.lsp0000644000000000000000000000013014542551762015132 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.453789012 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/byte.lsp0000644000175000017500000000305414542551762014534 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:13:22 2003 ;;;; Contains: Tests of BYTE, BYTE-SIZE, and BYTE-POSITION (in-package :cl-test) (deftest byte.error.1 (signals-error (byte) program-error) t) (deftest byte.error.2 (signals-error (byte 1) program-error) t) (deftest byte.error.3 (signals-error (byte 1 1 nil) program-error) t) (deftest byte.1 (progn (byte 0 0) :good) :good) (deftest byte.2 (progn (byte 1 1) :good) :good) (deftest byte.3 (loop for i from 0 to 100 always (loop for j from 0 to 100 always (let ((bspec (byte i j))) (and (eql i (byte-size bspec)) (eql j (byte-position bspec)))))) t) (deftest byte.4 (macrolet ((%m (z) z)) (let ((b (byte (expand-in-current-env (%m 2)) 5))) (values (byte-size b) (byte-position b)))) 2 5) (deftest byte.5 (macrolet ((%m (z) z)) (let ((b (byte 31 (expand-in-current-env (%m 7))))) (values (byte-size b) (byte-position b)))) 31 7) (deftest byte-size.1 (macrolet ((%m (z) z)) (byte-size (expand-in-current-env (%m (byte 3 7))))) 3) (deftest byte-position.1 (macrolet ((%m (z) z)) (byte-position (expand-in-current-env (%m (byte 3 7))))) 7) (deftest byte-position.error.1 (signals-error (byte-position) program-error) t) (deftest byte-position.error.2 (signals-error (byte-position (byte 1 1) nil) program-error) t) (deftest byte-size.error.1 (signals-error (byte-size) program-error) t) (deftest byte-size.error.2 (signals-error (byte-size (byte 1 1) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-percent.lsp0000644000000000000000000000013214542551762017117 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.453789012 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-percent.lsp0000644000175000017500000000327014542551762016517 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 23:47:44 2004 ;;;; Contains: Tests of format with ~% directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.%.1 "~%" nil #.(string #\Newline)) (deftest format.%.2 (loop for i from 0 to 100 for s1 = (make-string i :initial-element #\Newline) for format-string = (format nil "~~~D%" i) for s2 = (format nil format-string) for fn = (eval `(formatter ,s2)) for s3 = (formatter-call-to-string fn) unless (and (string= s1 s2) (string= s1 s3)) collect i) nil) (def-format-test format.%.3 "~v%" (nil) #.(string #\Newline)) (def-format-test format.%.4 "~V%" (1) #.(string #\Newline)) (deftest format.%.5 (loop for i from 0 to 100 for s1 = (make-string i :initial-element #\Newline) for s2 = (format nil "~v%" i) unless (string= s1 s2) collect i) nil) (deftest formatter.%.5 (let ((fn (formatter "~v%"))) (loop for i from 0 to 100 for s1 = (make-string i :initial-element #\Newline) for s2 = (formatter-call-to-string fn i) unless (string= s1 s2) collect i)) nil) (deftest format.%.6 (loop for i from 0 to (min (- call-arguments-limit 3) 100) for args = (make-list i) for s1 = (make-string i :initial-element #\Newline) for s2 = (apply #'format nil "~#%" args) unless (string= s1 s2) collect i) nil) (deftest formatter.%.6 (let ((fn (formatter "~#%"))) (loop for i from 0 to (min (- call-arguments-limit 3) 100) for args = (make-list i) for s1 = (make-string i :initial-element #\Newline) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream args) args))) unless (string= s1 s2) collect i)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/return-from.lsp0000644000000000000000000000013114542551763016451 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.453789012 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/return-from.lsp0000644000175000017500000000102514542551763016046 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 24 20:22:23 2004 ;;;; Contains: Tests of RETURN-FROM (in-package :cl-test) ;;; RETURN-FROM is tested extensively in other files (deftest return-from.1 (block xyz (return-from xyz) :bad) nil) (deftest return-from.2 (block nil (return-from nil :good) :bad) :good) ;;; Macros are expanded in the appropriate environment (deftest return-from.3 (macrolet ((%m (z) z)) (block foo (return-from foo (expand-in-current-env (%m :good))))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/abs.lsp0000644000000000000000000000013214542551762014736 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.453789012 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/abs.lsp0000644000175000017500000000663714542551762014350 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 20:16:42 2003 ;;;; Contains: Tests of ABS (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest abs.error.1 (signals-error (abs) program-error) t) (deftest abs.error.2 (signals-error (abs 0 0) program-error) t) (deftest abs.error.3 (signals-error (abs 0 nil nil) program-error) t) (deftest abs.1 (loop for x in *numbers* for a = (abs x) always (and (realp a) (not (minusp a)))) t) (deftest abs.2 (loop for x = (random-fixnum) for a = (abs x) repeat 10000 unless (if (plusp x) (eql x a) (eql (- x) a)) collect (list x a)) nil) (deftest abs.3 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (plusp x) (eql x a) (eql (- x) a)) collect (list x a))) nil) (deftest abs.4 (loop for num = (random-fixnum) for den = (random-fixnum) for den2 = (if (zerop den) 1 den) for r = (/ num den) for a = (abs r) repeat 10000 unless (if (>= r 0) (eql r a) (eql (- r) a)) collect (list num den2 r a)) nil) (deftest abs.5 (let ((bound (ash 1 210))) (loop for num = (random-from-interval bound) for den = (random-from-interval bound) for den2 = (if (zerop den) 1 den) for r = (/ num den) for a = (abs r) repeat 10000 unless (if (>= r 0) (eql r a) (eql (- r) a)) collect (list num den2 r a))) nil) (deftest abs.6 (let ((bound (float (ash 1 11) 1.0s0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) (deftest abs.7 (let ((bound (float (ash 1 22) 1.0f0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) (deftest abs.8 (let ((bound (float (ash 1 48) 1.0d0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) (deftest abs.9 (let ((bound (float (ash 1 48) 1.0l0))) (loop for x = (random-from-interval bound) for a = (abs x) repeat 10000 unless (if (minusp x) (eql (- x) a) (eql x a)) collect (list x a))) nil) ;;; The example on the abs page says that (abs -0.0) should be -0,0. ;;; However, FABS on the x86 returns 0.0 for that. Since the examples ;;; in the hyperspec are not normative, the following four tests ;;; have been commented out. ;;; (deftest abs.10 ;;; (abs -0.0s0) ;;; -0.0s0) ;;; ;;; (deftest abs.11 ;;; (abs -0.0f0) ;;; -0.0f0) ;;; ;;; (deftest abs.12 ;;; (abs -0.0d0) ;;; -0.0d0) ;;; ;;; (deftest abs.13 ;;; (abs -0.0l0) ;;; -0.0l0) ;;; Complex numbers (deftest abs.14 (let ((result (abs #c(3 4)))) (=t result 5)) t) (deftest abs.15 (let ((result (abs #c(-3 4)))) (=t result 5)) t) (deftest abs.16 (let ((result (abs #c(3 -4)))) (=t result 5)) t) (deftest abs.17 (let ((result (abs #c(-3 -4)))) (=t result 5)) t) (deftest abs.18 (abs #c(3.0s0 4.0s0)) 5.0s0) (deftest abs.19 (abs #c(3.0f0 -4.0f0)) 5.0f0) (deftest abs.20 (abs #c(-3.0d0 4.0d0)) 5.0d0) (deftest abs.21 (abs #c(-3.0l0 4.0l0)) 5.0l0) (deftest abs.22 (macrolet ((%m (z) z)) (abs (expand-in-current-env (%m -4)))) 4) gcl-2.7.1/ansi-tests/PaxHeaders/misc-cmucl-type-prop.lsp0000644000000000000000000000013014542551763020161 xustar0030 mtime=1703597043.004022432 29 atime=1744294960.45778903 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/misc-cmucl-type-prop.lsp0000644000175000017500000002447014542551763017570 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 4 06:21:51 2005 ;;;; Contains: CMUCL type prop failures (moved from misc.lsp) (in-package :cl-test) ;;; All these are 'strange template failures' ;;; The comment before each is the NAME of the template in the backtrace ;;; These tests seem to all have (space 2) (speed 3) ; X86::FAST-LOGAND-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.1 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) (type (member 2 -4 -211907662 -27215198) p1)) (logand (the (integer * 161212781) p1) 10600829))) -27215198) 2129952) ; X86::FAST-LOGAND/SIGNED-UNSIGNED=>UNSIGNED (deftest cmucl-type-prop.2 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type (integer 1619851121 1619868587) p1) (type (integer * 303689) p2)) (logandc2 (the (integer -5359291650 1619851136) p1) (the unsigned-byte p2)))) 1619851124 300065) 1619551060) ; X86::FAST-LOGIOR-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.3 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) (type (integer 59087 63964) p1)) (logior p1 -65887623))) 59967) -65869185) ; X86::FAST-LOGIOR/FIXNUM=>FIXNUM (deftest cmucl-type-prop.4 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 2) (debug 0) (space 3)) (type (integer 3585942 72924743) p1) (type (integer -70689 *) p2)) (logorc2 (the (integer * 8514860) p1) (the (integer 1 411) p2)))) 3586455 4) -1) ; X86::FAST-LOGAND-C/SIGNED=>SIGNED (deftest cmucl-type-prop.5 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 1) (debug 2) (space 3)) (type (integer -257 *) p2)) (lognand 1020158769 (the (integer -5275217 2381998) p2)))) 2) -1) ; X86::FAST-LOGAND-C/SIGNED-UNSIGNED=>UNSIGNED (deftest cmucl-type-prop.6 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -96413017 -96297711) p1)) (lognand p1 3472289945))) -96413016) -3393245321) ; X86::FAST-LOGAND/UNSIGNED-SIGNED=>UNSIGNED (deftest cmucl-type-prop.7 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) (type (integer 438294 891242) p1) (type (member 16317 -15 -541332155 33554427) p2)) (logand (the (integer -33116139 1759877902) p1) p2))) 438295 16317) 12309) ; X86::FAST-LOGIOR-C/SIGNED=>SIGNED (deftest cmucl-type-prop.8 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) (type (integer -728025757 -727856169) p1)) (logorc1 (the (integer -734005577 -727855553) p1) -3311))) -727856176) -2241) ; X86::FAST-LOGXOR/FIXNUM=>FIXNUM (deftest cmucl-type-prop.9 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) (type (integer * 1489068) p1) (type (integer -7455 *) p2)) (logeqv (the (member 9543 -15 32766 -264472) p1) (the (integer -524303 11182721) p2)))) 9543 -8) 9536) ; X86::FAST-LOGXOR/SIGNED=>SIGNED (deftest cmucl-type-prop.10 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type (integer -616605365 -616598658) p1) (type (eql 499113) p2)) (logeqv (the real p1) p2))) -616604953 499113) 617035953) ; X86::FAST-LOGXOR-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.11 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -112225610 *) p1)) (logeqv (the (integer -2822315666 3) p1) 1679389))) 1) -1679389) ; X86::FAST-LOGXOR-C/SIGNED=>SIGNED (deftest cmucl-type-prop.12 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) (type (integer -67 268435455) p2)) (logeqv 1038360149 (the (integer -3605943309) p2)))) -1) 1038360149) ; X86::-/SINGLE-FLOAT (deftest cmucl-type-prop.13 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) (type (eql 64848.973) p1)) (- (the (eql 64848.973f0) p1) -2808/1031))) 64848.973f0) 'single-float)) t) ; X86::-/DOUBLE-FLOAT (deftest cmucl-type-prop.14 (notnot (typep (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) (type (integer 9297 *) p2)) (- 54090.82691488265d0 (the (integer * 1263530808) p2)))) 9590) 'double-float)) t) ; X86::-/SINGLE-FLOAT (deftest cmucl-type-prop.15 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) (type (eql 328536/53893) p1)) (- p1 59218.633f0))) 328536/53893) 'single-float)) t) ; X86::FAST--/FIXNUM=>FIXNUM (deftest cmucl-type-prop.16 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) (type (integer -605782 -28141) p2)) (- -61118 p2))) -28225) -32893) ; X86::FAST---C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.17 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) (type (integer 5535202) p1)) (- (the (integer * 27858177) p1) 405))) 5535436) 5535031) ; X86::FAST--/SIGNED=>SIGNED (deftest cmucl-type-prop.18 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) (type (integer -1175231414 -3471291) p2)) (- -440 p2))) -3536832) 3536392) ; X86::FAST-+-C/FIXNUM=>FIXNUM (deftest cmucl-type-prop.19 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) (type (integer -1015240116 5) p2)) (+ 491841 (the unsigned-byte p2)))) 0) 491841) ; X86::+/DOUBLE-FLOAT (deftest cmucl-type-prop.20 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) (type (rational -1255531/68466 4) p1)) (+ p1 41888.98682005542d0))) -1255531/68466) 'double-float)) t) ; X86::+/SINGLE-FLOAT (deftest cmucl-type-prop.21 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) (type (integer -284887911 *) p1)) (+ (the (integer -50006902 19512639861) p1) 68648.28f0))) -16452463) 'single-float)) t) ; X86::=0/DOUBLE-FLOAT (deftest cmucl-type-prop.22 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 1) (space 3)) (type (complex double-float) p1)) (= p1 -1590311/896933))) #c(1.0d0 1.0d0)) nil) ; X86::=/SINGLE-FLOAT (deftest cmucl-type-prop.23 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) (type (complex single-float) p2)) (= -976855 (the (eql #c(-57420.04 806984.0)) p2)))) #c(-57420.04f0 806984.0f0)) nil) ; X86::FAST-EQL/FIXNUM (deftest cmucl-type-prop.24 (notnot (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type (integer -3705845 488458) p1) (type (integer * 869076010) p2)) (/= p1 (the (integer -69832764 470) p2)))) 488456 465)) t) ; X86::FAST-EQL-C/FIXNUM (deftest cmucl-type-prop.25 (notnot (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) (type (integer -69741922) p1)) (/= (the (integer * 216) p1) 182))) 103)) t) ; X86::FAST-IF->-C/FIXNUM (deftest cmucl-type-prop.26 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) (type (integer -451 204073899) p2)) (< 134799 (the (integer -56 8589934581) p2)))) -2) nil) ; X86::FAST-IF-<-C/FIXNUM (deftest cmucl-type-prop.27 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) (type (integer -93662 *) p2)) (<= -1 (the (integer -2975848 16770677) p2)))) -6548) nil) ; X86::FAST-+-C/FIXNUM=>FIXNUM ; (simple example) (deftest cmucl-type-prop.28 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -65545 80818) p1)) (1+ p1))) -1) 0) ; X86::FAST-NEGATE/FIXNUM (deftest cmucl-type-prop.29 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) (type (integer -4194320 11531) p1)) (- (the (integer -6253866924 34530147) p1)))) -20) 20) ;;; Bug in COPY-SEQ (deftest cmucl-type-prop.30 (let ((a (funcall (compile nil `(lambda () (declare (optimize (speed 2) (safety 2) (debug 0) (space 2))) (copy-seq ,(make-array '(0) :adjustable t))))))) (and (not (adjustable-array-p a)) (= (length a) 0) t)) t) ; Bug for PACKAGEP (deftest cmucl-type-prop.31 (funcall (compile nil '(lambda (x) (declare (optimize (speed 2) (space 3))) (packagep x))) t) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; There were many failures in string comparison functions ;;; Some are that C::WIN strange template problem, but others ;;; are not. ;;; 0 is not of type (INTEGER 0 (0)) (deftest cmucl-type-prop.32 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 1) (safety 1) (debug 1) (space 0)) (type (integer -2040 9) p4)) (string< "bbaa" "" :start1 p4))) 2) nil) ;;; 2 is not of type (INTEGER 0 (2)) (deftest cmucl-type-prop.33 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 0) (safety 0) (debug 2) (space 0)) (type (integer -52340 *) p4)) (string< "baabbb" "bb" :start2 p4))) 1) nil) ;;; Incorrect return value (deftest cmucl-type-prop.34 (funcall (compile nil '(lambda (p1 p4) (declare (optimize (speed 2) (safety 0) (debug 3) (space 0)) (type (simple-string) p1) (type real p4)) (string< (the array p1) "bbbba" :start1 (the (integer -16382 *) p4) :end1 7))) "J4sPI71C3Xn" 5) 5) gcl-2.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-nconc.lsp0000644000000000000000000000013114542551762023137 xustar0030 mtime=1703597042.976022388 29 atime=1744294960.45778903 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-nconc.lsp0000644000175000017500000001510414542551762022537 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination NCONC (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.nconc.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.nconc.1 (x) (:method-combination nconc) (:method nconc ((x integer)) (copy-list (car (push '(d) *x*)))) (:method nconc ((x rational)) (copy-list (car (push '(c) *x*)))) (:method nconc ((x number)) (copy-list (car (push '(b) *x*)))) (:method nconc ((x t)) (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.nconc.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.nconc.2 (x) (:method-combination nconc :most-specific-first) (:method nconc ((x integer)) (copy-list (car (push '(d) *x*)))) (:method nconc ((x rational)) (copy-list (car (push '(c) *x*)))) (:method nconc ((x number)) (copy-list (car (push '(b) *x*)))) (:method nconc ((x t)) (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) ((b a) ((a) (b))) ((a) ((a)))) (deftest defgeneric-method-combination.nconc.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.nconc.3 (x) (:method-combination nconc :most-specific-last) (:method nconc ((x integer)) (copy-list (car (push '(d) *x*)))) (:method nconc ((x rational)) (copy-list (car (push '(c) *x*)))) (:method nconc ((x number)) (copy-list (car (push '(b) *x*)))) (:method nconc ((x t)) (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) ((d) (c) (b) (a))) ((a b c) ((c) (b) (a))) ((a b) ((b) (a))) ((a) ((a)))) (deftest defgeneric-method-combination.nconc.4 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.4 (x) (:method-combination nconc) (:method nconc ((x integer)) (list 'a 'b)) (:method :around ((x rational)) 'foo) (:method nconc ((x number)) (list 'c 'd)) (:method nconc ((x symbol)) (list 'e 'f)) (:method nconc ((x t)) (list 'g 'h)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo (c d g h) (e f g h) (g h)) (deftest defgeneric-method-combination.nconc.5 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.5 (x) (:method-combination nconc) (:method nconc ((x integer)) (list 'a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method nconc ((x number)) (list 'b)) (:method nconc ((x symbol)) (list 'c)) (:method nconc ((x t)) (cons 'd 'e)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo (a b d . e)) (foo (b d . e)) (b d . e) (c d . e) (d . e)) (deftest defgeneric-method-combination.nconc.6 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.6 (x) (:method-combination nconc) (:method nconc ((x integer)) (list 'a)) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method nconc ((x number)) (list 'b)) (:method nconc ((x symbol)) (list 'c)) (:method nconc ((x t)) (list 'd)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.nconc.7 (let ((fn (eval '(defgeneric dg-mc.fun.nconc.7 (x) (:method-combination nconc) (:method nconc ((x dgmc-class-04)) (list 'a)) (:method nconc ((x dgmc-class-03)) (list 'b)) (:method nconc ((x dgmc-class-02)) (list 'c)) (:method nconc ((x dgmc-class-01)) (list 'd)))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) (d) (c d) (b d) (a c b d)) (deftest defgeneric-method-combination.nconc.8 (let ((fn (eval '(defgeneric dg-mc.nconc.8 (x) (:method-combination nconc) (:method nconc ((x (eql 1000))) (list 'a)) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method nconc ((x t)) (list 'b)))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) ((b))) (deftest defgeneric-method-combination.nconc.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.nconc.9 (x) (:method-combination nconc))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.nconc.10 (progn (eval '(defgeneric dg-mc.nconc.10 (x) (:method-combination nconc) (:method ((x t)) (list 'a)))) (handler-case (dg-mc.nconc.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.nconc.11 (progn (eval '(defgeneric dg-mc.nconc.11 (x) (:method-combination nconc) (:method nonsense ((x t)) (list 'a)))) (handler-case (dg-mc.nconc.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.nconc.12 (let ((fn (eval '(defgeneric dg-mc.nconc.12 (x) (:method-combination nconc) (:method :around ((x t)) (list 'a)) (:method nconc ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn (list 'b)) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/echo-stream-input-stream.lsp0000644000000000000000000000013114542551762021025 xustar0030 mtime=1703597042.988022407 29 atime=1744294960.45778903 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/echo-stream-input-stream.lsp0000644000175000017500000000134614542551762020430 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/load-characters.lsp0000644000000000000000000000013114772071546017226 xustar0030 mtime=1743287142.918899237 29 atime=1744294960.45778903 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-characters.lsp0000644000175000017500000000040014772071546016617 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 23 20:12:44 2005 ;;;; Contains: Load character tests (in-package :cl-test) (compile-and-load "char-aux.lsp") (load "character.lsp") (load "char-compare.lsp") (load "name-char.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/values.lsp0000644000000000000000000000013114542551763015470 xustar0030 mtime=1703597043.032022476 29 atime=1744294960.45778903 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/values.lsp0000644000175000017500000000300714542551763015067 0ustar00cammcamm;-*- 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.20 (let ((a t) (b t) (c t) (d t) (e t) (f t)) (setf (values a (values b c) (values d) (values e f)) (values 0 1 2 3 4 5 6)) (list a b c d e f)) (0 1 nil 2 3 nil)) (deftest values.21 (let (a b c d e f) (setf (values a (values b c) (values d) (values e f)) (values 0 1 2 3 4 5 6))) 0 1 2 3) (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.7.1/ansi-tests/PaxHeaders/translate-pathname.lsp0000644000000000000000000000013014542551763017760 xustar0029 mtime=1703597043.02802247 29 atime=1744294960.45778903 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/translate-pathname.lsp0000644000175000017500000000715414542551763017367 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/return.lsp0000644000000000000000000000013114542551763015510 xustar0030 mtime=1703597043.020022457 29 atime=1744294960.45778903 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/return.lsp0000644000175000017500000000155014542551763015110 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 16:00:32 2003 ;;;; Contains: Tests of RETURN (in-package :cl-test) ;;; RETURN is tested extensively in other files (deftest return.error.1 (signals-error (funcall (macro-function 'return)) program-error) t) (deftest return.error.2 (signals-error (funcall (macro-function 'return) '(return nil)) program-error) t) (deftest return.error.3 (signals-error (funcall (macro-function 'return) '(return nil) nil nil) program-error) t) ;;; (deftest return.1 (block nil (return) :bad) nil) (deftest return.2 (block nil (return :good) :bad) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest return.3 (macrolet ((%m (z) z)) (block nil (return (expand-in-current-env (%m :good))) :bad)) :good) gcl-2.7.1/ansi-tests/PaxHeaders/position.lsp0000644000000000000000000000013014542551763016034 xustar0030 mtime=1703597043.012022445 29 atime=1744294960.45778903 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/position.lsp0000644000175000017500000004712514542551763015445 0ustar00cammcamm;-*- 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) (deftest position-list.29 (position 10 '(1 4 8 10 15 20) :test #'<) 4) (deftest position-list.30 (position 10 '(1 4 8 10 15 20) :test-not #'>=) 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) (deftest position-vector.32 (position 10 #(1 4 8 10 15 20) :test #'<) 4) (deftest position-vector.33 (position 10 #(1 4 8 10 15 20) :test-not #'>=) 4) (deftest position-vector.34 (let* ((v1 #(x x x a b c d a b c d y y y y y)) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (position 'c v2) (position 'c v2 :from-end t))) 2 6) ;;; 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) (deftest position-bit-vector.33 (position 0 #*1111000 :test #'>=) 4) (deftest position-bit-vector.34 (position 0 #*1111000 :test-not #'<) 4) ;;; 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-string.29 (position #\m "adfmpz" :test #'char<) 4) (deftest position-string.30 (position #\m "adfmpz" :test-not #'char>=) 4) (deftest position-string.31 (let* ((s1 (copy-seq "xxxabcdyyyyy")) (s2 (make-array '(4) :displaced-to s1 :displaced-index-offset 3 :element-type (array-element-type s1)))) (position #\c s2)) 2) (deftest position-string.32 (let* ((s1 (copy-seq "xxxabcdabcdyyyyyyyy")) (s2 (make-array '(8) :displaced-to s1 :displaced-index-offset 3 :element-type (array-element-type s1)))) (position #\c s2 :from-end t)) 6) (deftest position-string.33 (do-special-strings (s "abcdabcdabcd" nil) (let* ((c #\c) (pos (position c s))) (assert (eql pos 2) () "First position of ~A in ~A is ~A" c s pos))) nil) (deftest position-string.34 (do-special-strings (s "abcdabcdabcd" nil) (let* ((c #\c) (pos (position c s :from-end t))) (assert (eql pos 10) () "Last position of ~A in ~A is ~A" c s pos))) nil) (defharmless position.test-and-test-not.1 (position 'b '(a b c d) :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.2 (position 'b '(a b c d) :test-not #'eql :test #'eql)) (defharmless position.test-and-test-not.3 (position 'b #(a b c d) :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.4 (position 'b #(a b c d) :test-not #'eql :test #'eql)) (defharmless position.test-and-test-not.5 (position #\b "abcd" :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.6 (position #\b "abcd" :test-not #'eql :test #'eql)) (defharmless position.test-and-test-not.7 (position 1 #*001010010 :test #'eql :test-not #'eql)) (defharmless position.test-and-test-not.8 (position 0 #*1110010110111 :test-not #'eql :test #'eql)) (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 (check-type-error #'(lambda (x) (position 'a x)) #'sequencep) nil) (deftest position.error.4 (signals-error (position 'e '(a b c . d)) type-error) t) (deftest position.error.5 (signals-error (position) program-error) t) (deftest position.error.6 (signals-error (position 'a) program-error) t) (deftest position.error.7 (signals-error (position 'a nil :key) program-error) t) (deftest position.error.8 (signals-error (position 'a nil 'bad t) program-error) t) (deftest position.error.9 (signals-error (position 'a nil 'bad t :allow-other-keys nil) program-error) t) (deftest position.error.10 (signals-error (position 'a nil 1 2) program-error) t) (deftest position.error.11 (signals-error (locally (position 'a 'b) t) type-error) t) (deftest position.error.12 (signals-error (position 'b '(a b c d) :test #'identity) program-error) t) (deftest position.error.13 (signals-error (position 'b '(a b c d) :test-not #'not) program-error) t) (deftest position.error.14 (signals-error (position 'b '(a b c d) :key #'cdr) type-error) t) (deftest position.error.15 (signals-error (position 'b '(a b c d) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cl-symbols-aux.lsp0000644000000000000000000000012714542551762017054 xustar0028 mtime=1703597042.9200223 29 atime=1744294960.45778903 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cl-symbols-aux.lsp0000644000175000017500000000253014542551762016446 0ustar00cammcamm;-*- 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 as an external symbol (not (eqt status :external)) ;; Check if it has any properties whose indicators are ;; external in any of the standard packages or are accessible ;; in CL-USER (let ((plist (symbol-plist sym))) (loop for e = plist then (cddr e) for indicator = (car e) while 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.7.1/ansi-tests/PaxHeaders/hash-table-rehash-size.lsp0000644000000000000000000000013014542551762020417 xustar0029 mtime=1703597042.99602242 29 atime=1744294960.45778903 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table-rehash-size.lsp0000644000175000017500000000211114542551762020012 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:47:24 2003 ;;;; Contains: Tests for HASH-TABLE-REHASH-SIZE (in-package :cl-test) (deftest hash-table-rehash-size.1 (typep* (hash-table-rehash-size (make-hash-table)) '(or (integer 1 *) (float (1.0) *))) t) (deftest hash-table-rehash-size.2 (loop for test in '(eq eql equal equalp) unless (typep* (hash-table-rehash-size (make-hash-table :test test)) '(or (integer 1 *) (float (1.0) *))) collect test) nil) (deftest hash-table-rehash-size.3 (loop for test in '(eq eql equal equalp) for fn = (symbol-function test) unless (typep* (hash-table-rehash-size (make-hash-table :test fn)) '(or (integer 1 *) (float (1.0) *))) collect test) nil) (deftest hash-table-rehash-size.error.1 (signals-error (hash-table-rehash-size) program-error) t) (deftest hash-table-rehash-size.error.2 (signals-error (hash-table-rehash-size (make-hash-table) nil) program-error) t) (deftest hash-table-rehash-size.error.3 (check-type-error #'hash-table-rehash-size #'hash-table-p) nil) gcl-2.7.1/ansi-tests/PaxHeaders/make-broadcast-stream.lsp0000644000000000000000000000013114542551763020337 xustar0030 mtime=1703597043.000022426 29 atime=1744294960.45778903 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-broadcast-stream.lsp0000644000175000017500000000533014542551763017737 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/getf.lsp0000644000000000000000000000013114542551762015115 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.461789047 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/getf.lsp0000644000175000017500000001077114542551762014522 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:37:41 2003 ;;;; Contains: Tests of GETF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (values cnt1 ; (eqlt cnt1 1) cnt2 ; (eqlt cnt2 1) cnt3 ; (eqlt cnt3 1) (getf (car p) 'a) (getf (car p) 'b) (getf (car p) 'c) (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))))) 1 1 1 1 2 3 0) (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 (values i x y z w (getf (car p) 'a) (getf (car p) 'b) (getf (car p) 'c) (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))))) 4 1 2 3 4 1 2 3 0) (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))) ;;; Error tests (deftest getf.error.1 (signals-error (getf) program-error) t) (deftest getf.error.2 (signals-error (getf nil) program-error) t) (deftest getf.error.3 (signals-error (getf nil nil nil nil) program-error) t) (deftest getf.error.4 (signals-error (getf '(a . b) 'c) type-error) t) (deftest getf.error.5 (signals-error (getf '(a 10 . b) 'c) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/array-dimension.lsp0000644000000000000000000000013214542551762017272 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.461789047 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-dimension.lsp0000644000175000017500000000304214542551762016667 0ustar00cammcamm;-*- 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.7 (macrolet ((%m (z) z)) (array-dimension (expand-in-current-env (%m "abc")) 0)) 3) (deftest array-dimension.8 (macrolet ((%m (z) z)) (array-dimension #2a((a b)(c d)(e f)) (expand-in-current-env (%m 0)))) 3) (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 (signals-error (array-dimension) program-error) t) (deftest array-dimension.error.2 (signals-error (array-dimension #(a b c)) program-error) t) (deftest array-dimension.error.3 (signals-error (array-dimension #(a b c) 0 nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-array.lsp0000644000000000000000000000013214542551763016223 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.461789047 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-array.lsp0000644000175000017500000005136614542551763015634 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Sep 20 06:47:37 2002 ;;;; Contains: Tests for MAKE-ARRAY (in-package :cl-test) (compile-and-load "array-aux.lsp") (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))))) ;; Should return a symbol only in error situations (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)) (deftest make-array.8c (loop for i from 1 to 32 for tp = `(unsigned-byte ,i) for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) when (symbolp a) collect (list i tp a)) nil) (deftest make-array.8d (loop for i from 2 to 32 for tp = `(signed-byte ,i) for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) when (symbolp a) collect (list i tp a)) nil) (deftest make-array.8e (loop for tp in '(short-float single-float double-float long-float) for v in '(1.0s0 1.0f0 1.0d0 1.0l0) for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-element v) when (symbolp a) collect (list tp v a)) nil) (deftest make-array.8f (loop for tp in '(short-float single-float double-float long-float) for v in '(1.0s0 1.0f0 1.0d0 1.0l0) for a = (make-array 5 :fill-pointer 3 :element-type `(complex ,tp) :initial-element (complex v)) when (symbolp a) collect (list tp v a)) nil) ;;; 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.12a (make-array-with-checks 10 :element-type 'bit :initial-contents '(1 0 0 1 1 0 0 1 0 0) :fill-pointer 6) #*100110) (deftest make-array.12b (make-array-with-checks 10 :element-type 'character :initial-contents "abcdefghij" :fill-pointer 8) "abcdefgh") (deftest make-array.12c (make-array-with-checks 10 :element-type 'base-char :initial-contents "abcdefghij" :fill-pointer 8) "abcdefgh") (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.7a (make-array-with-checks '(4) :adjustable t :element-type 'bit :fill-pointer t :initial-contents '(1 0 0 1)) #(1 0 0 1)) (deftest make-array.adjustable.7b (make-array-with-checks '(4) :adjustable t :element-type 'base-char :fill-pointer t :initial-contents "abcd") "abcd") (deftest make-array.adjustable.7c (make-array-with-checks '(4) :adjustable t :element-type 'character :fill-pointer t :initial-contents "abcd") "abcd") (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 (signals-error (make-array) program-error) t) (deftest make-array.error.2 (signals-error (make-array '(10) :bad t) program-error) t) (deftest make-array.error.3 (signals-error (make-array '(10) :allow-other-keys nil :bad t) program-error) t) (deftest make-array.error.4 (signals-error (make-array '(10) :allow-other-keys nil :allow-other-keys t :bad t) program-error) t) (deftest make-array.error.5 (signals-error (make-array '(10) :bad) program-error) t) (deftest make-array.error.6 (signals-error (make-array '(10) 1 2) program-error) t) ;;; Order of evaluation tests (deftest make-array.order.1 (let ((i 0) a b c 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 e)) #(a a a a a) 4 1 2 3 4) (deftest make-array.order.2 (let ((i 0) a b 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 d e)) #(a a a a a) 4 1 2 3 4) ;; Must add back order tests for :displaced-to and :displaced-index-offset gcl-2.7.1/ansi-tests/PaxHeaders/merge.lsp0000644000000000000000000000013114542551763015270 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.461789047 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/merge.lsp0000644000175000017500000003707314542551763014701 0ustar00cammcamm;-*- 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)) (deftest merge-vector.18 (merge '(vector) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.19 (merge '(vector *) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.20 (merge '(vector t) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.21 (merge '(vector * 6) (list 1 3 10) (list 2 4 6) #'<) #(1 2 3 4 6 10)) (deftest merge-vector.22 (merge '(simple-vector) (list 2 4 6) (list 1 3 5) #'<) #(1 2 3 4 5 6)) (deftest merge-vector.23 (merge '(simple-vector *) (list 2 4 6) (list 1 3 5) #'<) #(1 2 3 4 5 6)) (deftest merge-vector.24 (merge '(simple-vector 6) (list 2 4 6) (list 1 3 5) #'<) #(1 2 3 4 5 6)) ;;; 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 (copy-seq "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 (copy-seq "2459"))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1c (let ((x (copy-seq "1378")) (y (copy-seq "2459"))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1d (let ((x (copy-seq "1378")) (y (copy-seq "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") (deftest merge-string.19 (do-special-strings (s "ace" nil) (assert (string= (merge 'string s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.20 (do-special-strings (s "ace" nil) (assert (string= (merge 'base-string (copy-seq "bdf") s #'char<) "abcdef"))) nil) (deftest merge-string.21 (do-special-strings (s "ace" nil) (assert (string= (merge 'simple-string s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.22 (do-special-strings (s "ace" nil) (assert (string= (merge 'simple-base-string s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.23 (do-special-strings (s "ace" nil) (assert (string= (merge '(vector character) s (copy-seq "bdf") #'char<) "abcdef"))) nil) (deftest merge-string.24 (merge '(string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.25 (merge '(string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.26 (merge '(string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.27 (merge '(simple-string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.28 (merge '(simple-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.29 (merge '(simple-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.30 (merge '(base-string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.31 (merge '(base-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.32 (merge '(base-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.33 (merge '(simple-base-string) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.34 (merge '(simple-base-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") (deftest merge-string.35 (merge '(simple-base-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) "abcdef") ;;; 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)) (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) (error () :caught)) :caught) (deftest merge.error.2 (signals-error (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) type-error) t) (deftest merge.error.3 (signals-error (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<) type-error) t) (deftest merge.error.4 (signals-error (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<) type-error) t) (deftest merge.error.5 (signals-error (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<) type-error) t) (deftest merge.error.6 (signals-error (merge 'null (list 1 2 3) (list 4 5 6) #'<) type-error) t) (deftest merge.error.7 (signals-error (merge) program-error) t) (deftest merge.error.8 (signals-error (merge 'list) program-error) t) (deftest merge.error.9 (signals-error (merge 'list (list 2 4 6)) program-error) t) (deftest merge.error.10 (signals-error (merge 'list (list 2 4 6) (list 1 3 5)) program-error) t) (deftest merge.error.11 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t) program-error) t) (deftest merge.error.12 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :key) program-error) t) (deftest merge.error.13 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t :allow-other-keys nil) program-error) t) (deftest merge.error.14 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< 1 2) program-error) t) (deftest merge.error.15 (signals-error (locally (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) t) type-error) t) (deftest merge.error.16 (signals-error (merge 'list (list 1 2) (list 3 4) #'car) program-error) t) (deftest merge.error.17 (signals-error (merge 'list (list 'a 'b) (list 3 4) #'max) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/pathnames-aux.lsp0000644000000000000000000000013114542551763016744 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.461789047 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathnames-aux.lsp0000644000175000017500000000117714542551763016351 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/print-characters.lsp0000644000000000000000000000013114542551763017442 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.461789047 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-characters.lsp0000644000175000017500000000573614542551763017054 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 5 07:12:20 2004 ;;;; Contains: Tests for printing of characters (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; See CLtS section 22.1.3.2, "Printing Characters" (deftest print.char.1 (with-standard-io-syntax (loop for c across +standard-chars+ unless (equal (string c) (with-output-to-string (s) (princ c s))) collect c)) nil) (deftest print.char.2 (with-standard-io-syntax (loop for c across +code-chars+ unless (equal (string c) (with-output-to-string (s) (princ c s))) collect c)) nil) (deftest print.char.3 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +base-chars+ unless (or (eql c #\Space) (equal (format nil "#\\~C" c) (with-output-to-string (s) (prin1 c s)))) collect c))) nil) (deftest print.char.4 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 #\Space s)))) "#\\ ") (deftest print.char.5 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 #\Newline s)))) "#\\Newline") (deftest print.char.6 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (princ #\Newline s)))) #.(string #\Newline)) (deftest print.char.7 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +code-chars+ for str = (with-output-to-string (s) (prin1 c s)) for len = (length str) unless (and (>= len 3) (equal (subseq str 0 2) "#\\") (or (= len 3) (let ((name (subseq str 2))) (eql c (name-char name))))) collect c))) nil) (deftest print.char.8 (loop for i = (random (min char-code-limit (ash 1 16))) for c = (code-char i) repeat 1000 unless (null c) nconc (let ((result (randomly-check-readability c))) (and result (list (cons i (first result)))))) nil) (deftest print.char.9 (loop for i = (random (min char-code-limit (ash 1 32))) for c = (code-char i) repeat 1000 unless (null c) nconc (let ((result (randomly-check-readability c))) (and result (list (cons i (first result)))))) nil) (deftest print.char.10 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +standard-chars+ for str = (with-output-to-string (s) (prin1 c s)) unless (or (eql c #\Newline) (equal str (concatenate 'string "#\\" (string c)))) collect (list c str)))) nil) (deftest print.char.11 (with-standard-io-syntax (let ((*print-readably* nil)) (let ((names '("Newline" "Tab" "Rubout" "Linefeed" "Page" "Backspace" "Return"))) (loop for name in names for c = (name-char name) for str = (with-output-to-string (s) (prin1 c s)) unless (or (null c) (and (>= (length str) 3) (equal (subseq str 0 2) "#\\") (member (subseq str 2) names :test #'equal))) collect (list c str))))) nil)gcl-2.7.1/ansi-tests/PaxHeaders/compile-file-test-file-2.lsp0000644000000000000000000000013014542551762020565 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.465789065 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-file-test-file-2.lsp0000644000175000017500000000043514542551762020167 0ustar00cammcamm(in-package "CL-TEST") (defun compile-file-test-fun.2 () nil) (eval-when (:compile-toplevel) (unless (find-class 'compile-file-test-condition.2 nil) (define-condition compile-file-test-condition.2 (style-warning) nil)) (warn (make-condition 'compile-file-test-condition.2))) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-09.lsp0000644000000000000000000000013214542551762016336 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.465789065 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-09.lsp0000644000175000017500000000733114542551762015740 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cons-test-05.lsp0000644000000000000000000000013214542551762016332 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.465789065 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-05.lsp0000644000175000017500000000677514542551762015747 0ustar00cammcamm;-*- 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) (compile-and-load "cons-aux.lsp") (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) (signals-error (,name) program-error) t)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name name) ".ERROR.EXCESS-ARGS") :cl-test) (signals-error (,name nil nil) program-error) t))) gcl-2.7.1/ansi-tests/PaxHeaders/documentation.lsp0000644000000000000000000000013214542551762017042 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.465789065 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/documentation.lsp0000644000175000017500000004626014542551762016450 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 14 07:30:01 2004 ;;;; Contains: Tests of DOCUMENTATION (in-package :cl-test) ;;; documentation (x function) (doc-type (eql 't)) (deftest documentation.function.t.1 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (documentation (symbol-function sym) t)) nil) (deftest documentation.function.t.2 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((fn (symbol-function sym)) (doc "FOO1")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t))))))) "FOO1") (deftest documentation.function.t.3 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (documentation (macro-function sym) t)) nil) (deftest documentation.function.t.4 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((fn (macro-function sym)) (doc "FOO2")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t))))))) "FOO2") (deftest documentation.function.t.6 (let* ((sym (gensym)) (fn (eval `#'(lambda () ',sym))) (doc "FOO3")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t)))))) "FOO3") (deftest documentation.function.t.6a (let* ((sym (gensym)) (fn (compile nil `(lambda () ',sym))) (doc "FOO3A")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t)))))) "FOO3A") ;; Reorder 5, 5a and 6, 6a to expose possible interaction bug (deftest documentation.function.t.5 (let* ((sym (gensym)) (fn (eval `#'(lambda () ',sym)))) (documentation fn t)) nil) (deftest documentation.function.t.5a (let* ((sym (gensym)) (fn (compile nil `(lambda () ',sym)))) (documentation fn t)) nil) (deftest documentation.function.t.7 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x))))) (documentation fn t)) nil) (deftest documentation.function.t.8 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x)))) (doc "FOO4")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) (equal doc (documentation fn t)))))) "FOO4") (deftest documentation.function.t.9 (loop for s in *cl-function-symbols* for fn = (symbol-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) (deftest documentation.function.t.10 (loop for s in *cl-accessor-symbols* for fn = (symbol-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) (deftest documentation.function.t.11 (loop for s in *cl-macro-symbols* for fn = (macro-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) (deftest documentation.function.t.12 (loop for s in *cl-standard-generic-function-symbols* for fn = (symbol-function s) for doc = (documentation fn t) unless (or (null doc) (string doc)) collect (list s doc)) nil) ;;; documentation (x function) (doc-type (eql 'function)) (deftest documentation.function.function.1 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (documentation (symbol-function sym) 'function)) nil) (deftest documentation.function.function.2 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((fn (symbol-function sym)) (doc "FOO5")) (multiple-value-prog1 (setf (documentation fn 'function) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function))))))) "FOO5") (deftest documentation.function.function.3 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (documentation (macro-function sym) 'function)) nil) (deftest documentation.function.function.4 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((fn (macro-function sym)) (doc "FOO6")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function))))))) "FOO6") (deftest documentation.function.function.5 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x))))) (documentation fn 'function)) nil) (deftest documentation.function.function.8 (let* ((sym (gensym)) (fn (eval `(defgeneric ,sym (x)))) (doc "FOO4A")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function)))))) "FOO4A") ;;; documentation (x list) (doc-type (eql 'function)) (deftest documentation.list.function.1 (let* ((sym (gensym))) (eval `(defun (setf ,sym) (&rest args) (declare (ignore args)) nil)) (documentation `(setf ,sym) 'function)) nil) (deftest documentation.list.function.2 (let* ((sym (gensym))) (eval `(defun (setf ,sym) (&rest args) (declare (ignore args)) nil)) (let ((fn `(setf ,sym)) (doc "FOO7")) (multiple-value-prog1 (setf (documentation fn 'function) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'function))))))) "FOO7") ;;; documentation (x list) (doc-type (eql 'compiler-macro)) (deftest documentation.list.compiler-macro.1 (let* ((sym (gensym))) (eval `(define-compiler-macro (setf ,sym) (&rest args) (declare (ignore args)) nil)) (documentation `(setf ,sym) 'compiler-macro)) nil) (deftest documentation.list.compiler-macro.2 (let* ((sym (gensym))) (eval `(define-compiler-macro (setf ,sym) (&rest args) (declare (ignore args)) nil)) (let ((fn `(setf ,sym)) (doc "FOO8")) (multiple-value-prog1 (setf (documentation fn 'compiler-macro) (copy-seq doc)) (assert (or (null (documentation fn 'function)) (equal doc (documentation fn 'compiler-macro))))))) "FOO8") ;;; documentation (x symbol) (doc-type (eql 'function)) (deftest documentation.symbol.function.1 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (documentation sym 'function)) nil) (deftest documentation.symbol.function.2 (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((doc "FOO9")) (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) (equal doc (documentation sym 'function))))))) "FOO9") (deftest documentation.symbol.function.3 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (documentation sym 'function)) nil) (deftest documentation.symbol.function.4 (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((doc "FOO9A")) (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) (equal doc (documentation sym 'function))))))) "FOO9A") (deftest documentation.symbol.function.5 (let* ((sym (gensym))) (eval `(defgeneric ,sym (x))) (documentation sym 'function)) nil) (deftest documentation.symbol.function.6 (let* ((sym (gensym))) (eval `(defgeneric ,sym (x))) (let ((doc "FOO9B")) (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) (equal doc (documentation sym 'function))))))) "FOO9B") (deftest documentation.symbol.function.7 (loop for s in *cl-special-operator-symbols* for doc = (documentation s 'function) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) (deftest documentation.symbol.function.8 (loop for s in *cl-function-or-accessor-symbols* for doc = (documentation s 'function) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) (deftest documentation.symbol.function.9 (loop for s in *cl-macro-symbols* for doc = (documentation s 'function) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) ;;; documentation (x symbol) (doc-type (eql 'compiler-macro)) (deftest documentation.symbol.compiler-macro.1 (let* ((sym (gensym))) (eval `(define-compiler-macro ,sym (&rest args) (declare (ignore args)) nil)) (documentation sym 'compiler-macro)) nil) (deftest documentation.symbol.compiler-macro.2 (let* ((sym (gensym))) (eval `(define-compiler-macro ,sym (&rest args) (declare (ignore args)) nil)) (let ((doc "FOO10")) (multiple-value-prog1 (setf (documentation sym 'compiler-macro) (copy-seq doc)) (assert (or (null (documentation sym 'compiler-macro)) (equal doc (documentation sym 'compiler-macro))))))) "FOO10") ;;; documentation (x symbol) (doc-type (eql 'setf)) (deftest documentation.symbol.setf.1 (let* ((sym (gensym)) (doc "FOO11")) (eval `(defun ,sym () (declare (special *x*)) *x*)) (eval `(define-setf-expander ,sym () (let ((g (gemsym))) (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) '(locally (declare (special *x*)) *x*))))) (multiple-value-prog1 (values (documentation sym 'setf) (setf (documentation sym 'setf) (copy-seq doc))) (assert (or (null (documentation sym 'setf)) (equal doc (documentation sym 'setf)))))) nil "FOO11") (deftest documentation.symbol.setf.2 (let* ((sym (gensym)) (doc "FOO12")) (eval `(defmacro ,sym () `(locally (declare (special *x*)) *x*))) (eval `(define-setf-expander ,sym () (let ((g (gemsym))) (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) '(locally (declare (special *x*)) *x*))))) (multiple-value-prog1 (values (documentation sym 'setf) (setf (documentation sym 'setf) (copy-seq doc))) (assert (or (null (documentation sym 'setf)) (equal doc (documentation sym 'setf)))))) nil "FOO12") ;;; documentation (x method-combination) (doc-type (eql 't)) ;;; documentation (x method-combination) (doc-type (eql 'method-combination)) ;;; There's no portable way to test those, since there's no portable way to ;;; get a method combination object ;;; documentation (x symbol) (doc-type (eql 'method-combination)) (deftest documentation.symbol.method-combination.1 (let* ((sym (gensym)) (doc "FOO13")) (eval `(define-method-combination ,sym :identity-with-one-argument t)) (multiple-value-prog1 (values (documentation sym 'method-combination) (setf (documentation sym 'method-combination) (copy-seq doc))) (assert (or (null (documentation sym 'method-combination)) (equal doc (documentation sym 'method-combination)))))) nil "FOO13") ;;; documentation (x standard-method) (doc-type (eql 't)) (deftest documentation.standard-method.t.1 (let* ((sym (gensym)) (doc "FOO14")) (eval `(defgeneric ,sym (x))) (let ((method (eval `(defmethod ,sym ((x t)) nil)))) (multiple-value-prog1 (values (documentation method t) (setf (documentation method t) (copy-seq doc))) (assert (or (null (documentation method 't)) (equal doc (documentation method 't))))))) nil "FOO14") ;;; documentation (x package) (doc-type (eql 't)) (deftest documentation.package.t.1 (let ((package-name "PACKAGE-NAME-FOR-DOCUMENATION-TESTS-1")) (unwind-protect (progn (eval `(defpackage ,package-name (:use))) (let ((pkg (find-package package-name)) (doc "FOO15")) (assert pkg) (multiple-value-prog1 (values (documentation pkg t) (setf (documentation pkg t) (copy-seq doc))) (assert (or (null (documentation pkg t)) (equal doc (documentation pkg t))))))) (delete-package package-name))) nil "FOO15") ;;; documentation (x standard-class) (doc-type (eql 't)) (deftest documentation.standard-class.t.1 (let* ((sym (gensym)) (class-form `(defclass ,sym () ()))) (eval class-form) (let ((class (find-class sym)) (doc "FOO16")) (multiple-value-prog1 (values (documentation class t) (setf (documentation class t) (copy-seq doc))) (assert (or (null (documentation class t)) (equal doc (documentation class t))))))) nil "FOO16") ;;; documentation (x standard-class) (doc-type (eql 'type)) (deftest documentation.standard-class.type.1 (let* ((sym (gensym)) (class-form `(defclass ,sym () ()))) (eval class-form) (let ((class (find-class sym)) (doc "FOO17")) (multiple-value-prog1 (values (documentation class 'type) (setf (documentation class 'type) (copy-seq doc))) (assert (or (null (documentation class 'type)) (equal doc (documentation class 'type))))))) nil "FOO17") ;;; documentation (x structure-class) (doc-type (eql 't)) (deftest documentation.struct-class.t.1 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c))) (eval class-form) (let ((class (find-class sym)) (doc "FOO18")) (multiple-value-prog1 (values (documentation class t) (setf (documentation class t) (copy-seq doc))) (assert (or (null (documentation class t)) (equal doc (documentation class t))))))) nil "FOO18") ;;; documentation (x structure-class) (doc-type (eql 'type)) (deftest documentation.struct-class.type.1 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c))) (eval class-form) (let ((class (find-class sym)) (doc "FOO19")) (multiple-value-prog1 (values (documentation class 'type) (setf (documentation class 'type) (copy-seq doc))) (assert (or (null (documentation class 'type)) (equal doc (documentation class 'type))))))) nil "FOO19") ;;; documentation (x symbol) (doc-type (eql 'type)) (deftest documentation.symbol.type.1 (let* ((sym (gensym)) (class-form `(defclass ,sym () ())) (doc "FOO20")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) (equal doc (documentation sym 'type)))))) nil "FOO20") (deftest documentation.symbol.type.2 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c)) (doc "FOO21")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) (equal doc (documentation sym 'type)))))) nil "FOO21") (deftest documentation.symbol.type.3 (let* ((sym (gensym)) (type-form `(deftype ,sym () t)) (doc "FOO21A")) (eval type-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) (equal doc (documentation sym 'type)))))) nil "FOO21A") (deftest documentation.symbol.type.4 (loop for s in *cl-all-type-symbols* for doc = (documentation s 'type) unless (or (null doc) (stringp doc)) collect (list doc)) nil) ;;; documentation (x symbol) (doc-type (eql 'structure)) (deftest documentation.symbol.structure.1 (let* ((sym (gensym)) (class-form `(defstruct ,sym a b c)) (doc "FOO22")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) (equal doc (documentation sym 'structure)))))) nil "FOO22") (deftest documentation.symbol.structure.2 (let* ((sym (gensym)) (class-form `(defstruct (,sym (:type list)) a b c)) (doc "FOO23")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) (equal doc (documentation sym 'structure)))))) nil "FOO23") (deftest documentation.symbol.structure.3 (let* ((sym (gensym)) (class-form `(defstruct (,sym (:type vector)) a b c)) (doc "FOO24")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) (equal doc (documentation sym 'structure)))))) nil "FOO24") ;;; documentation (x symbol) (doc-type (eql 'variable)) (deftest documentation.symbol.variable.1 (let* ((sym (gensym)) (form `(defvar ,sym)) (doc "FOO25")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO25") (deftest documentation.symbol.variable.2 (let* ((sym (gensym)) (form `(defvar ,sym t)) (doc "FOO26")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO26") (deftest documentation.symbol.variable.3 (let* ((sym (gensym)) (form `(defparameter ,sym t)) (doc "FOO27")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO27") (deftest documentation.symbol.variable.4 (let* ((sym (gensym)) (form `(defconstant ,sym t)) (doc "FOO27")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) (equal doc (documentation sym 'variable)))))) nil "FOO27") (deftest documentation.symbol.variable.5 (loop for s in *cl-variable-symbols* for doc = (documentation s 'variable) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) (deftest documentation.symbol.variable.6 (loop for s in *cl-constant-symbols* for doc = (documentation s 'variable) unless (or (null doc) (stringp doc)) collect (list s doc)) nil) ;;; Defining new methods for DOCUMENTATION (ignore-errors (defgeneric documentation-test-class-1-doc-accessor (obj)) (defgeneric (setf documentation-test-class-1-doc-accessor) (newdoc obj)) (defclass documentation-test-class-1 () ((my-doc :accessor documentation-test-class-1-doc-accessor :type (or null string) :initform nil))) (defmethod documentation-test-class-1-doc-accessor ((obj documentation-test-class-1) ) (slot-value obj 'my-doc)) (defmethod (setf documentation-test-class-1-doc-accessor) ((newdoc string) (obj documentation-test-class-1)) (setf (slot-value obj 'my-doc) newdoc)) (defmethod documentation ((obj documentation-test-class-1) (doctype (eql t))) (documentation-test-class-1-doc-accessor obj)) (defmethod (setf documentation) ((newdoc string) (obj documentation-test-class-1) (doctype (eql t))) (setf (documentation-test-class-1-doc-accessor obj) newdoc))) (deftest documentation.new-method.1 (let ((obj (make-instance 'documentation-test-class-1))) (values (documentation obj t) (setf (documentation obj t) "FOO28") (documentation obj t))) nil "FOO28" "FOO28") gcl-2.7.1/ansi-tests/PaxHeaders/packages-10.lsp0000644000000000000000000000013114542551763016165 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.465789065 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-10.lsp0000644000175000017500000000572414542551763015574 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/array-dimensions.lsp0000644000000000000000000000013214542551762017455 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.465789065 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-dimensions.lsp0000644000175000017500000000273414542551762017061 0ustar00cammcamm;-*- 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) (deftest array-dimensions.8 (macrolet ((%m (z) z)) (array-dimensions (expand-in-current-env (%m #2a((a b)(c d)(e f)))))) (3 2)) ;;; Error tests (deftest array-dimensions.error.1 (signals-error (array-dimensions) program-error) t) (deftest array-dimensions.error.2 (signals-error (array-dimensions #(a b c) nil) program-error) t) (deftest array-dimensions.error.3 (check-type-error #'array-dimensions #'arrayp) nil) (deftest array-dimensions.error.4 (signals-type-error x nil (array-dimensions x)) t) (deftest array-dimensions.error.5 (signals-error (locally (array-dimensions nil)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/makefile.old0000644000000000000000000000013214776006046015725 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/makefile.old0000644000175000017500000001334714776006046015333 0ustar00cammcamm# LISP=gcl # LISP=../unixport/saved_ansi_gcl # LISP=sbcl --noinform # LISP=~/sbcl/src/runtime/sbcl --core ~/sbcl/output/sbcl.core --noinform # LISP=clisp -ansi -q # LISP=abcl # LISP=ecl # LISP=/usr/local/lib/LispWorks/nongraphic-lispworks-4450 # LISP=acl MAKE=make test: @rm -rf scratch cat doit.lsp | $(LISP) | tee test.out test_results: ../unixport/saved_ansi_gcl echo '(load "gclload")' | $< |tee $@ test-symbols: (cat doit1.lsp ; echo "(load \"load-symbols.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-symbols.out test-eval-and-compile: (cat doit1.lsp ; echo "(load \"load-eval-and-compile.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-eval-and-compile.out test-data-and-control-flow: (cat doit1.lsp ; echo "(load \"load-data-and-control-flow.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-data-and-control-flow.out test-iteration: (cat doit1.lsp ; echo "(load \"load-iteration.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-iteration.out test-objects: (cat doit1.lsp ; echo "(load \"load-objects.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-objects.out test-conditions: (cat doit1.lsp ; echo "(load \"load-conditions.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-conditions.out test-cons: (cat doit1.lsp ; echo "(load \"load-cons.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-cons.out test-arrays: (cat doit1.lsp ; echo "(load \"load-arrays.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-arrays.out test-hash-tables: (cat doit1.lsp ; echo "(load \"load-hash-tables.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-hash-tables.out test-packages: (cat doit1.lsp ; echo "(load \"load-packages.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-packages.out test-numbers: (cat doit1.lsp ; echo "(load \"load-numbers.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-numbers.out test-sequences: (cat doit1.lsp ; echo "(load \"load-sequences.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-sequences.out test-structures: (cat doit1.lsp ; echo "(load \"load-structures.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-structures.out test-types-and-class: (cat doit1.lsp ; echo "(load \"load-types-and-class.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-types-and-class.out test-strings: (cat doit1.lsp ; echo "(load \"load-strings.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-strings.out test-characters: (cat doit1.lsp ; echo "(load \"load-characters.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-characters.out test-pathnames: (cat doit1.lsp ; echo "(load \"load-pathnames.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-pathnames.out test-files: (cat doit1.lsp ; echo "(load \"load-files.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-files.out test-streams: (cat doit1.lsp ; echo "(load \"load-streams.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-streams.out test-printer: (cat doit1.lsp ; echo "(load \"load-printer.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-printer.out test-reader: (cat doit1.lsp ; echo "(load \"load-reader.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-reader.out test-system-construction: (cat doit1.lsp ; echo "(load \"load-system-construction.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-system-construction.out test-environment: (cat doit1.lsp ; echo "(load \"load-environment.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-environment.out test-misc: (cat doit1.lsp ; echo "(load \"load-misc.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-misc.out test-all: test-symbols test-eval-and-compile test-data-and-control-flow test-iteration test-objects \ test-conditions test-cons test-arrays test-hash-tables test-packages test-numbers \ test-sequences test-structures test-types-and-class test-strings test-characters test-pathnames \ test-files test-streams test-printer test-reader test-system-construction test-environment \ test-misc test-compiled: @rm -rf scratch echo "(load \"compileit.lsp\")" | $(LISP) | tee test.out test-unixport: echo "(load \"doit.lsp\")" | ../unixport/saved_ansi_gcl | tee test.out ##+gcl (setq compiler::*cc* \"gcc -c -DVOL=volatile -fsigned-char -pipe \") random-test: (echo "(progn \ (setq *load-verbose* nil) \ (let* ((*standard-output* (make-broadcast-stream)) \ (*error-output* *standard-output*)) \ (load \"gclload1.lsp\") \ (funcall (symbol-function 'compile-and-load) \"random-int-form.lsp\"))) \ (in-package :cl-test) (declaim (optimize (safety 0)))\ (let ((x (cl-test::test-random-integer-forms 1000 3 1000 :random-size t :random-nvars t))) \ (setq x (cl-test::prune-results x)) \ (with-open-file (*standard-output* \"failures.lsp\" \ :direction :output \ :if-exists :append \ :if-does-not-exist :create) \ (mapc #'print x))) \ #+allegro (excl::exit) \ ; extra quits added to avoid being trapped in debugger in some lisps \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit) \ (cl-user::quit)") | $(LISP) rm -f gazonk* rt_1000_8: echo "(load \"gclload1.lsp\") \ (compile-and-load \"random-int-form.lsp\") \ (in-package :cl-test) (loop-random-int-forms 1000 8)" | $(LISP) clean: @rm -f test*.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\# @rm -f *.dfsl *.d64fsl @(cd beyond-ansi; $(MAKE) clean) @rm -rf scratch/ scratch.txt @rm -f foo.txt foo.lsp foo.dat failures.lsp @rm -f tmp.txt tmp.dat tmp2.dat temp.dat @rm -f gazonk* out.class @rm -rf TMP/ @rm -f "CLTEST:file-that-was-renamed.txt" file-that-was-renamed.txt COMPILE-FILE-TEST-LP.OUT @rm -f compile-file-test-lp.lsp compile-file-test-lp.out ldtest.lsp test_results gcl-2.7.1/ansi-tests/PaxHeaders/or.lsp0000644000000000000000000000013114542551763014611 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.465789065 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/or.lsp0000644000175000017500000000237514542551763014217 0ustar00cammcamm;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest or.10 (macrolet ((%m (z) z)) (or (expand-in-current-env (%m 'x)) (expand-in-current-env (%m nil)) (expand-in-current-env (%m 'y)) t)) x) (deftest or.11 (macrolet ((%m (z) z)) (or (expand-in-current-env (%m nil)) (expand-in-current-env (%m 'a)) nil)) a) ;;; Error tests (deftest or.error.1 (signals-error (funcall (macro-function 'or)) program-error) t) (deftest or.error.2 (signals-error (funcall (macro-function 'or) '(or)) program-error) t) (deftest or.error.3 (signals-error (funcall (macro-function 'or) '(or) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-06.lsp0000644000000000000000000000013114542551763020771 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.465789065 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-06.lsp0000644000175000017500000001626014542551763020375 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 13 15:33:55 2005 ;;;; Contains: Random type prop tests, part 6 (arrays) (in-package :cl-test) (def-type-prop-test adjustable-array-p 'adjustable-array-p '(array) 1) (def-type-prop-test aref.0 'aref '((array * nil)) 1) (def-type-prop-test aref.1 'aref (list '(array * (*)) (index-type-for-dim 0)) 2) (def-type-prop-test aref.2 'aref (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test aref.3 'aref (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test array-dimension 'array-dimension (list 'array #'(lambda (x) (let ((r (array-rank x))) (and (> r 0) `(integer 0 (,r)))))) 2) (def-type-prop-test array-dimensions 'array-dimensions '(array) 1) (def-type-prop-test array-element-type 'array-element-type '(array) 1) (def-type-prop-test array-has-fill-pointer-p.1 'array-has-fill-pointer-p '(array) 1) (def-type-prop-test array-has-fill-pointer-p.2 'array-has-fill-pointer-p '(vector) 1) (def-type-prop-test array-displacement.1 'array-displacement '(array) 1) (def-type-prop-test array-displacement.2 'array-displacement '(vector) 1) (def-type-prop-test array-in-bounds-p.0 'array-in-bounds-p '((array * nil)) 1) (def-type-prop-test array-in-bounds-p.1 'array-in-bounds-p (list '(array * (*)) (index-type-for-dim 0)) 2) (def-type-prop-test array-in-bounds-p.2 'array-in-bounds-p (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test array-in-bounds-p.3 'array-in-bounds-p (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test array-in-bounds-p.4 'array-in-bounds-p '((array * (*)) integer) 2) (def-type-prop-test array-in-bounds-p.5 'array-in-bounds-p '((array * (* *)) integer integer) 3) (def-type-prop-test array-in-bounds-p.6 'array-in-bounds-p '((array * (* * *)) integer integer integer) 4) (def-type-prop-test array-rank 'array-rank '(array) 1) (def-type-prop-test array-row-major-index.0 'array-row-major-index '((array * nil)) 1) (def-type-prop-test array-row-major-index.1 'array-row-major-index (list '(array * (*)) (index-type-for-dim 0)) 2) (def-type-prop-test array-row-major-index.2 'array-row-major-index (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test array-row-major-index.3 'array-row-major-index (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test array-total-size 'array-total-size '(array) 1) (def-type-prop-test arrayp 'arrayp '(t) 1) (def-type-prop-test fill-pointer '(lambda (x) (and (array-has-fill-pointer-p x) (fill-pointer x))) '(vector) 1) (def-type-prop-test row-major-aref 'row-major-aref (list 'array #'(lambda (a) (let ((s (array-total-size a))) (and (> s 0) `(integer 0 (,s)))))) 2) (def-type-prop-test upgraded-array-element-type 'upgraded-array-element-type (list #'(lambda () (let ((x (make-random-element-of-type t))) `(eql ,(make-random-type-containing x))))) 1) (def-type-prop-test simple-vector-p.1 'simple-vector-p '(t) 1) (def-type-prop-test simple-vector-p.2 'simple-vector-p '(vector) 1) (def-type-prop-test svref 'svref (list 'simple-vector (index-type-for-dim 0)) 2) (def-type-prop-test vector 'vector nil 1 :rest-type t :maxargs 10) (def-type-prop-test vectorp.1 'vectorp '(t) 1) (def-type-prop-test vectorp.2 'vectorp '(array) 1) (def-type-prop-test bit.1 'bit (list '(array bit (*)) (index-type-for-dim 0)) 2) (def-type-prop-test bit.2 'bit (list '(array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test bit.3 'bit (list '(array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test sbit.1 'sbit (list '(simple-array bit (*)) (index-type-for-dim 0)) 2) (def-type-prop-test sbit.2 'sbit (list '(simple-array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test sbit.3 'sbit (list '(simple-array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test bit-and.1 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-and.2 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-andc1.1 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-andc1.2 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-andc2.1 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-andc2.2 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-ior.1 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-ior.2 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-orc1.1 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-orc1.2 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-orc2.1 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-orc2.2 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-eqv.1 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-eqv.2 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-xor.1 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-xor.2 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-nand.1 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-nand.2 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-nor.1 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims)))) 2) (def-type-prop-test bit-nor.2 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-not.1 'bit-not '((array bit)) 1) (def-type-prop-test bit-not.2 'bit-not '((array bit) null) 2) (def-type-prop-test bit-vector-p 'bit-vector-p '(t) 1) (def-type-prop-test simple-bit-vector-p 'simple-bit-vector-p '(t) 1) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-integer.lsp0000644000000000000000000000013114542551763017477 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.465789065 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-integer.lsp0000644000175000017500000002406514542551763017105 0ustar00cammcamm;-*- 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) (compile-and-load "types-aux.lsp") (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.7.1/ansi-tests/PaxHeaders/logeqv.lsp0000644000000000000000000000013214542551763015467 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.469789083 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logeqv.lsp0000644000175000017500000000362314542551763015071 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 05:55:23 2003 ;;;; Contains: Tests of LOGEQV (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logeqv.error.1 (check-type-error #'logeqv #'integerp) nil) (deftest logeqv.error.2 (check-type-error #'(lambda (x) (logeqv 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logeqv.1 (logeqv) -1) (deftest logeqv.2 (logeqv 1231) 1231) (deftest logeqv.3 (logeqv -198) -198) (deftest logeqv.4 (loop for x in *integers* always (eql x (logeqv x))) t) (deftest logeqv.5 (loop for x in *integers* always (eql 0 (logeqv x (lognot x)))) t) (deftest logeqv.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql 0 (logeqv x xc)) collect x) nil) (deftest logeqv.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logeqv x y) repeat 1000 unless (and (if (or (and (< x 0) (< y 0)) (and (>= x 0) (>= y 0))) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (and (logbitp i x) (logbitp i y)) (and (not (logbitp i x)) (not (logbitp i y)))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logeqv.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element -1) (list 7131)) always (eql (apply #'logeqv args) 7131)) t) (deftest logeqv.order.1 (let ((i 0) a b) (values (logeqv (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) (lognot #b10110))) i a b)) #b1101 2 1 2) (deftest logeqv.order.2 (let ((i 0) a b c) (values (logeqv (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b111000 3 1 2 3) gcl-2.7.1/ansi-tests/PaxHeaders/class-name.lsp0000644000000000000000000000013014542551762016212 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.469789083 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/class-name.lsp0000644000175000017500000000220114542551762015605 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 12:05:47 2003 ;;;; Contains: Tests of CLASS-NAME (in-package :cl-test) ;;; This is mostly tested elsewhere. (deftest class-name.1 (class-name (find-class 'symbol)) symbol) (defclass class-name-class-01 () (a b c)) (report-and-ignore-errors (eval '(defmethod class-name ((x class-name-class-01)) 'silly))) (deftest class-name.2 (class-name (make-instance 'class-name-class-01)) silly) ;; Tests of (setf class-name) (deftest setf-class-name.1 (typep* #'(setf class-name) 'standard-generic-function) t) (deftest setf-class-name.2 (let ((sym (gensym)) (newsym (gensym))) (eval `(defclass ,sym () (a b c))) (let ((class (find-class sym))) (values (eqlt (class-name class) sym) (equalt (multiple-value-list (setf (class-name (find-class sym)) newsym)) (list newsym)) (eqlt newsym (class-name class))))) t t t) ;;; Error tests (deftest class-name.error.1 (signals-error (class-name) program-error) t) (deftest class-name.error.2 (signals-error (class-name (find-class 'symbol) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/print-cons.lsp0000644000000000000000000000013114542551763016265 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.469789083 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-cons.lsp0000644000175000017500000001055014542551763015665 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 19 07:28:40 2004 ;;;; Contains: Tests of printing of conses (compile-and-load "printer-aux.lsp") (in-package :cl-test) (deftest print.cons.1 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(|A|) :case :upcase :pretty nil :escape nil))) "(A)") (deftest print.cons.2 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(|A| |B|) :case :upcase :pretty nil :escape nil))) "(A B)") (deftest print.cons.3 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (cons '|A| '|B|) :case :upcase :pretty nil :escape nil))) "(A . B)") (deftest print.cons.4 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((s '#:|X|)) (cons s s)) :case :upcase :pretty nil :escape t))) "(#:X . #:X)") (deftest print.cons.5 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((s '#:|X|)) (cons s s)) :case :upcase :pretty nil :escape t :circle t))) "(#1=#:X . #1#)") (deftest print.cons.6 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((s1 (make-symbol "X")) (s2 (make-symbol "X"))) (list s1 s2 s1 s2)) :case :upcase :pretty nil :escape t :circle t))) "(#1=#:X #2=#:X #1# #2#)") (deftest print.cons.7 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((a (list 17 nil))) (setf (cdr a) a) a) :circle t :pretty nil :escape nil))) "#1=(17 . #1#)") ;;; Random printing (deftest print.cons.random.1 (trim-list (loop for x = (make-random-cons-tree (random 100)) repeat 50 nconc (randomly-check-readability x)) 10) nil) ;; random circular cons graphs #-lispworks (deftest print.cons.random.2 (loop repeat 50 nconc (let* ((n 20) (conses (apply #'vector (loop repeat n collect (cons nil nil))))) (loop for x across conses for j = (random n) for k = (random n) do (setf (car x) (elt conses j) (cdr x) (elt conses k))) (randomly-check-readability (elt conses 0) :test #'is-similar :circle t))) nil) ;;; Printing with *print-length* (deftest print.cons.length.1 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :length 0 :pretty nil :escape nil))) "(...)") (deftest print.cons.length.2 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(81) :length 1 :pretty nil :escape nil))) "(81)") (deftest print.cons.length.3 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(4 . 8) :length 1 :pretty nil :escape nil))) "(4 . 8)") (deftest print.cons.length.4 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(4 8) :length 1 :pretty nil :escape nil))) "(4 ...)") (deftest print.cons.length.5 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a b c d e f g h i j k l m n o p) :case :downcase :length 10 :pretty nil :escape nil))) "(a b c d e f g h i j ...)") (deftest print.cons.length.6 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(((((((0))))))) :case :downcase :length 3 :pretty nil :escape nil))) "(((((((0)))))))") ;;; Printing with *print-level* (deftest print.cons.level.1 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :case :downcase :level 0 :escape nil :pretty nil))) "#") (deftest print.cons.level.2 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :case :downcase :level 1 :escape nil :pretty nil))) "(a)") (deftest print.cons.level.3 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '((a)) :case :downcase :level 1 :escape nil :pretty nil))) "(#)") (deftest print.cons.level.4 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) :case :downcase :level 2 :escape nil :pretty nil))) "(a)") (deftest print.cons.level.5 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(#(a) #*1101 "abc") :case :downcase :level 1 :pretty nil))) "(# #*1101 \"abc\")") gcl-2.7.1/ansi-tests/PaxHeaders/load-cons.lsp0000644000000000000000000000013214772071550016045 xustar0030 mtime=1743287144.410900592 30 atime=1744294960.469789083 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-cons.lsp0000644000175000017500000000316214772071550015445 0ustar00cammcamm;;; Tests of conses ;;; (compile-and-load "cons-aux.lsp") (load "cons.lsp") (load "consp.lsp") (load "atom.lsp") (load "cxr.lsp") (load "rplaca.lsp") (load "rplacd.lsp") (load "copy-tree.lsp") (load "sublis.lsp") (load "nsublis.lsp") (load "subst.lsp") (load "subst-if.lsp") (load "subst-if-not.lsp") (load "nsubst.lsp") (load "nsubst-if.lsp") (load "nsubst-if-not.lsp") (load "tree-equal.lsp") (load "copy-list.lsp") (load "list.lsp") (load "list-length.lsp") (load "listp.lsp") (load "make-list.lsp") (load "push.lsp") (load "pop.lsp") (load "pushnew.lsp") (load "adjoin.lsp") (load "nth.lsp") (load "endp.lsp") (load "nconc.lsp") (load "append.lsp") (load "revappend.lsp") (load "nreconc.lsp") (load "butlast.lsp") (load "nbutlast.lsp") (load "last.lsp") (load "ldiff.lsp") (load "tailp.lsp") (load "nthcdr.lsp") (load "rest.lsp") (load "member.lsp") (load "member-if.lsp") (load "member-if-not.lsp") (load "mapc.lsp") (load "mapcar.lsp") (load "mapcan.lsp") (load "mapl.lsp") (load "maplist.lsp") (load "mapcon.lsp") (load "acons.lsp") (load "assoc.lsp") (load "assoc-if.lsp") (load "assoc-if-not.lsp") (load "rassoc.lsp") (load "rassoc-if.lsp") (load "rassoc-if-not.lsp") (load "copy-alist.lsp") (load "pairlis.lsp") (load "get-properties.lsp") (load "getf.lsp") (load "remf.lsp") (load "intersection.lsp") (load "nintersection.lsp") (load "union.lsp") (load "nunion.lsp") (load "set-difference.lsp") (load "nset-difference.lsp") (load "set-exclusive-or.lsp") (load "nset-exclusive-or.lsp") (load "subsetp.lsp") ;;; Misc. stuff that should be moved elsewhere (load "cons-test-01.lsp") (load "cons-test-03.lsp") (load "cons-test-05.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/packages-00.lsp0000644000000000000000000000013114542551763016164 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.469789083 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-00.lsp0000644000175000017500000000254014542551763015564 0ustar00cammcamm;-*- 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))) (report-and-ignore-errors (defpackage "A" (:use) (:nicknames "Q") (:export "FOO"))) (report-and-ignore-errors (defpackage "B" (:use "A") (:export "BAR"))) (defun set-up-packages () (safely-delete-package "A") (safely-delete-package "B") (safely-delete-package "Q") (defpackage "A" (:use) (:nicknames "Q") (:export "FOO")) (defpackage "B" (:use "A") (:export "BAR"))) (report-and-ignore-errors (defpackage "FS-A" (:use) (:nicknames "FS-Q") (:export "FOO"))) (report-and-ignore-errors (defpackage "FS-B" (:use "FS-A") (:export "BAR"))) (report-and-ignore-errors (defpackage "DS1" (:use) (:intern "C" "D") (:export "A" "B"))) (report-and-ignore-errors (defpackage "DS2" (:use) (:intern "E" "F") (:export "G" "H" "A"))) (report-and-ignore-errors (defpackage "DS3" (:shadow "B") (:shadowing-import-from "DS1" "A") (:use "DS1" "DS2") (:export "A" "B" "G" "I" "J" "K") (:intern "L" "M"))) (report-and-ignore-errors (defpackage "DS4" (:shadowing-import-from "DS1" "B") (:use "DS1" "DS3") (:intern "X" "Y" "Z") (:import-from "DS2" "F"))) gcl-2.7.1/ansi-tests/PaxHeaders/define-compiler-macro.lsp0000644000000000000000000000013214542551762020332 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.469789083 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-compiler-macro.lsp0000644000175000017500000001214514542551762017733 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:33:02 2003 ;;;; Contains: Tests of DEFINE-COMPILER-MACRO (in-package :cl-test) ;;; Need to add non-error tests (deftest define-compiler-macro.error.1 (signals-error (funcall (macro-function 'define-compiler-macro)) program-error) t) (deftest define-compiler-macro.error.2 (signals-error (funcall (macro-function 'define-compiler-macro) '(definee-compiler-macro nonexistent-function ())) program-error) t) (deftest define-compiler-macro.error.3 (signals-error (funcall (macro-function 'define-compiler-macro) '(definee-compiler-macro nonexistent-function ()) nil nil) program-error) t) ;;; Non-error tests (deftest define-compiler-macro.1 (let* ((sym (gensym)) (macro-def-form `(define-compiler-macro ,sym (x y) (declare (special *x*)) (setf *x* t) `(+ ,x ,y 1))) (fun-def-form `(defun ,sym (x y) (+ x y 1)))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) (notnot (typep (compiler-macro-function sym) 'function)) (eval `(,sym 6 19)) (let ((fn (compile nil `(lambda (a b) (,sym a b))))) (let ((*x* nil)) (declare (special *x*)) (list (funcall fn 12 123) *x*))))) t t t 26 (136 nil)) (deftest define-compiler-macro.2 (let* ((sym (gensym)) (macro-def-form `(define-compiler-macro ,sym (&whole form &rest args) (declare (special *x*) (ignore args)) (setf *x* t) (return-from ,sym form))) (fun-def-form `(defun ,sym (x) x))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) (notnot (typep (compiler-macro-function sym) 'function)) (eval `(,sym 'a)) (let ((fn (compile nil `(lambda (a) (,sym a))))) (let ((*x* nil)) (declare (special *x*)) (list (funcall fn 'b) *x*))))) t t t a (b nil)) (deftest define-compiler-macro.3 (let* ((sym (gensym)) (macro-def-form `(define-compiler-macro ,sym (&whole form &rest args) (declare (special *x*) (ignore args)) (setf *x* t) (return-from ,sym form))) (ordinary-macro-def-form `(defmacro ,sym (x) x))) (values (equalt (list sym) (multiple-value-list (eval ordinary-macro-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) (notnot (typep (compiler-macro-function sym) 'function)) (eval `(,sym 'a)) (let ((fn (compile nil `(lambda (a) (,sym a))))) (let ((*x* nil)) (declare (special *x*)) (list (funcall fn 'b) *x*))))) t t t a (b nil)) ;;; Compiler macros on setf functions (deftest define-compiler-macro.4 (let* ((sym (gensym)) (fun-def-form `(defun ,sym (x) (car x))) (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval))) (setf-compiler-macro-def-form `(define-compiler-macro (setf ,sym) (newval x) (declare (special *x*)) (setf *x* t) (return-from ,sym `(setf (car ,x) ,newval))))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt `((setf ,sym)) (multiple-value-list (eval setf-fun-def-form))) (equalt `((setf ,sym)) (multiple-value-list (eval setf-compiler-macro-def-form))) (notnot (typep (compiler-macro-function `(setf ,sym)) 'function)) (eval `(,sym (list 'a 'b))) (eval `(let ((arg (list 1 2))) (list (setf (,sym arg) 'z) arg))) (let ((fn (compile nil `(lambda (u v) (setf (,sym u) v))))) (let ((*x* nil) (arg (list 1 2))) (declare (special *x*)) (list (funcall fn arg 'y) arg))))) t t t t a (z (z 2)) (y (y 2))) ;;; Test of documentation (deftest define-compiler-macro.5 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x) "DCM.5" x)) (form2 `(defun ,sym (x) "DCM.5-WRONG" x))) (eval form) (eval form2) (or (documentation sym 'compiler-macro) "DCM.5")) "DCM.5") (deftest define-compiler-macro.6 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x) "DCM.6" x)) (form2 `(defun ,sym (x) "DCM.6-WRONG" x))) (eval form2) (eval form) (or (documentation sym 'compiler-macro) "DCM.6")) "DCM.6") ;;; NOTINLINE turns off a compiler macro (deftest define-compiler-macro.7 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x y) (declare (special *x*)) (setf *x* :bad) `(list ,x ,y))) (form2 `(defun ,sym (x y) (list x y)))) (eval form) (eval form2) (compile sym) (let ((*x* :good)) (declare (special *x*)) (values (funcall (compile nil `(lambda (a b) (declare (notinline ,sym)) (,sym a b))) 5 11) *x*))) (5 11) :good) (deftest define-compiler-macro.8 (let* ((sym (gensym)) (form `(define-compiler-macro ,sym (x y) (declare (special *x*)) (setf *x* :bad) `(list ,x ,y))) (form2 `(defmacro ,sym (x y) `(list ,x ,y)))) (eval form) (eval form2) (let ((*x* :good)) (declare (special *x*)) (values (funcall (compile nil `(lambda (a b) (declare (notinline ,sym)) (,sym a b))) 7 23) *x*))) (7 23) :good) gcl-2.7.1/ansi-tests/PaxHeaders/file-author.lsp0000644000000000000000000000013214542551762016410 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.469789083 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/file-author.lsp0000644000175000017500000000374114542551762016013 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/min.lsp0000644000000000000000000000013114542551763014754 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.469789083 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/min.lsp0000644000175000017500000001016414542551763014355 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:24:45 2003 ;;;; Contains: Tests of MIN (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest min.error.1 (signals-error (min) program-error) t) (deftest min.error.2 (check-type-error #'min #'realp) nil) (deftest min.error.3 (check-type-error #'(lambda (x) (min 0 x)) #'realp) nil) (deftest min.1 (loop for n in *reals* when (or (not (eql (min n) n)) (not (eql (min n n) n)) (not (eql (min n n n) n)) (not (eql (apply #'min (make-list (min 256 (1- call-arguments-limit)) :initial-element n)) n))) collect n) nil) (deftest min.2 (min.2-fn) nil) (deftest min.3 (loop for x = (- (random 60000) 30000) for y = (- (random 60000) 30000) for m = (min x y) for m2 = (if (<= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest min.4 (loop for x = (- (random 6000000) 3000000) for y = (- (random 6000000) 3000000) for m = (min x y) for m2 = (if (<= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest min.5 (loop for x = (- (random 1000000000000) 500000000000) for y = (- (random 1000000000000) 500000000000) for m = (min x y) for m2 = (if (<= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest min.6 (let ((m (min 0 1.0s0))) (or (eqlt m 0) (eqlt m 0.0s0))) t) (deftest min.7 (min 2 1.0s0) 1.0s0) (deftest min.8 (let ((m (min 2 3.0f0))) (or (eqlt m 2) (eqlt m 2.0f0))) t) (deftest min.9 (min 2 1.0f0) 1.0f0) (deftest min.10 (let ((m (min 2 10.0d0))) (or (eqlt m 2) (eqlt m 2.0d0))) t) (deftest min.11 (min 100 1.0d0) 1.0d0) (deftest min.12 (let ((m (min 2 17.25l0))) (or (eqlt m 2) (eqlt m 2.0l0))) t) (deftest min.13 (min 2 1.0l0) 1.0l0) (deftest min.15 (let ((m (min 1.0s0 2.0f0))) (or (eqlt m 1.0s0) (eqlt m 1.0f0))) t) (deftest min.16 (min 3.0s0 1.0f0) 1.0f0) (deftest min.17 (let ((m (min 1.0s0 2.0d0))) (or (eqlt m 1.0s0) (eqlt m 1.0d0))) t) (deftest min.18 (min 5.0s0 1.0d0) 1.0d0) (deftest min.19 (let ((m (min 1.0s0 2.0l0))) (or (eqlt m 1.0s0) (eqlt m 1.0l0))) t) (deftest min.20 (min 2.0s0 1.0l0) 1.0l0) (deftest min.21 (let ((m (min 1.0f0 2.0d0))) (or (eqlt m 1.0f0) (eqlt m 1.0d0))) t) (deftest min.22 (min 18.0f0 1.0d0) 1.0d0) (deftest min.23 (let ((m (min 1.0f0 100.0l0))) (or (eqlt m 1.0f0) (eqlt m 1.0l0))) t) (deftest min.24 (min 19.0f0 1.0l0) 1.0l0) (deftest min.25 (let ((m (min 1.0d0 12.0l0))) (or (eqlt m 1.0d0) (eqlt m 1.0l0))) t) (deftest min.26 (min 15.0d0 1.0l0) 1.0l0) (deftest min.27 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for x = (make-list i :initial-element 1) do (setf (elt x (random i)) 0) unless (eql (apply #'min x) 0) collect x) nil) (deftest min.28 (let ((m (min 1/3 0.8s0))) (or (eqlt m 1/3) (eqlt m (float 1/3 0.8s0)))) t) (deftest min.29 (let ((m (min 1.0s0 -3 2.0f0))) (or (eqlt m -3) (eqlt m -3.0f0))) t) (deftest min.30 (let ((m (min 1.0d0 -3 2.0f0))) (or (eqlt m -3) (eqlt m -3.0d0))) t) (deftest min.31 (let ((m (min 1.0s0 -3 2.0l0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.32 (let ((m (min 1.0l0 -3 2.0s0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.33 (let ((m (min 1.0d0 -3 2.0l0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.34 (let ((m (min 1.0l0 -3 2.0d0))) (or (eqlt m -3) (eqlt m -3.0l0))) t) (deftest min.order.1 (let ((i 0) x y) (values (min (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20)) i x y)) 10 2 1 2) (deftest min.order.2 (let ((i 0) x y z) (values (min (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i x y z)) 10 3 1 2 3) (deftest min.order.3 (let ((i 0) u v w x y z) (values (min (progn (setf u (incf i)) 10) (progn (setf v (incf i)) 20) (progn (setf w (incf i)) 30) (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i u v w x y z)) 10 6 1 2 3 4 5 6) gcl-2.7.1/ansi-tests/PaxHeaders/structures-02.lsp0000644000000000000000000000013214542551763016634 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.469789083 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/structures-02.lsp0000644000175000017500000003230314542551763016233 0ustar00cammcamm;-*- 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 (my-aref s 5) (my-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 (my-aref s 5) (my-aref s 6) (my-aref s 9) (my-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-toplevel :execute) (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))) (assert (typep f 'function)) (values (struct-test-62-a s) (funcall (the function 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))) (assert (typep f 'function)) (assert (typep g 'function)) (locally (declare (type function f g)) (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) (defstruct-with-tests struct-test-65 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) (defstruct-with-tests struct-test-65A 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 pi short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon t) (defstruct-with-tests struct-test-66 nil) (defstruct-with-tests struct-test-67 (a 0 :type (integer 0 (#.(ash 1 32)))) (b nil)) (defstruct-with-tests (struct-test-68 (:include struct-test-67)) c d) ;;; Error tests (deftest copy-structure.error.1 (signals-error (copy-structure) program-error) t) (deftest copy-structure.error.2 (signals-error (copy-structure (make-s-2) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/file-namestring.lsp0000644000000000000000000000013214542551762017255 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.469789083 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/file-namestring.lsp0000644000175000017500000000210214542551762016646 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/name-char.lsp0000644000000000000000000000013114542551763016024 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.469789083 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/name-char.lsp0000644000175000017500000000511314542551763015423 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:14:03 2004 ;;;; Contains: Tests of NAME-CHAR (in-package :cl-test) (compile-and-load "char-aux.lsp") (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) ;;; Specialized sequence tests (deftest name-char.specialized.1 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s2 = (make-array (length s) :element-type 'base-char :initial-contents s) unless (eql (name-char s) (name-char s2)) collect (list s s2))) nil) (deftest name-char.specialized.2 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s2 = (make-array (length s) :element-type etype :adjustable t :initial-contents s) unless (eql (name-char s) (name-char s2)) collect (list etype s s2))) nil) (deftest name-char.specialized.3 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s2 = (make-array (+ 3 (length s)) :element-type etype :fill-pointer (length s) :initial-contents (concatenate 'string s " ")) unless (eql (name-char s) (name-char s2)) collect (list etype s s2))) nil) (deftest name-char.specialized.4 (loop for etype in '(standard-char base-char character) append (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" "Space" "Newline") for s1 = (make-array (+ 4 (length s)) :element-type etype :initial-contents (concatenate 'string " " s " ")) for s2 = (make-array (length s) :element-type etype :displaced-to s1 :displaced-index-offset 2) unless (eql (name-char s) (name-char s2)) collect (list etype s s2))) nil) ;;; Error tests (deftest name-char.error.1 (signals-error (name-char) program-error) t) (deftest name-char.error.2 (signals-error (name-char "space" "space") program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-brace.lsp0000644000000000000000000000013214542551762016533 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.469789083 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-brace.lsp0000644000175000017500000002137514542551762016141 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 25 22:08:51 2004 ;;;; Contains: Tests of the ~"{ ... ~} format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.{.1 (concatenate 'string "~{~" (string #\Newline) "~}") (nil) "") (def-format-test format.{.1a "~{~}" ("" nil) "") (def-format-test format.{.1b "~0{~}" ("" '(1 2 3)) "") (def-format-test format.{.2 "~{ ~}" (nil) "") (def-format-test format.{.3 "~{X Y Z~}" (nil) "") (def-format-test format.{.4 "~{~A~}" ('(1 2 3 4)) "1234") (def-format-test format.{.5 "~{~{~A~}~}" ('((1 2 3)(4 5)(6 7 8))) "12345678") (def-format-test format.{.6 "~{~1{~A~}~}" ('((1 2 3)(4 5)(6 7 8))) "146") (def-format-test format.{.7 (concatenate 'string "~1{~" (string #\Newline) "~}") (nil) "") (deftest format.{.8 (loop for i from 0 to 10 for s = (format nil "~v{~A~}" i '(1 2 3 4 5 6 7 8 9 0)) unless (string= s (subseq "1234567890" 0 i)) collect (list i s)) nil) (deftest formatter.{.8 (let ((fn (formatter "~V{~A~}"))) (loop for i from 0 to 10 for s = (formatter-call-to-string fn i '(1 2 3 4 5 6 7 8 9 0)) unless (string= s (subseq "1234567890" 0 i)) collect (list i s))) nil) (def-format-test format.{.9 "~#{~A~}" ('(1 2 3 4 5 6 7) nil nil nil) "1234" 3) ;;; (missing tests involved ~^ and have been moved to format-circumflex.lsp ;;; and renamed.) (def-format-test format.{.15 "~0{~}" ("~A" '(1 2 3)) "") (def-format-test format.{.16 "~1{~}" ("~A" '(4 5 6)) "4") (deftest format.{.17 (format nil "~{~}" (formatter "") nil) "") (deftest format.{.18 (format nil "~1{~}" (formatter "") '(1 2 3 4)) "") (deftest format.{.19 (format nil "~{~}" (formatter "~A") '(1 2 3 4)) "1234") (deftest format.{.20 (format nil "~3{~}" (formatter "~A") '(1 2 3 4)) "123") (def-format-test format.{.21 "~V{~}" (2 "~A" '(1 2 3 4 5)) "12") (def-format-test format.{.22 "~#{~}" ("~A" '(1 2 3 4 5)) "12") (def-format-test format.{.23 "~{FOO~:}" (nil) "FOO") (def-format-test format.{.24 "~{~A~:}" ('(1)) "1") (def-format-test format.{.25 "~{~A~:}" ('(1 2)) "12") (def-format-test format.{.26 "~{~A~:}" ('(1 2 3)) "123") (def-format-test format.{.27 "~0{FOO~:}" (nil) "") (def-format-test format.{.28 "~V{FOO~:}" (0 nil) "") (def-format-test format.{.29 "~1{FOO~:}" (nil) "FOO") (def-format-test format.{.30 "~2{FOO~:}" (nil) "FOO") (def-format-test format.{.31 (concatenate 'string "~2{~" (string #\Newline) "~:}") (nil) "") (def-format-test format.{.32 "~2{FOO~}" (nil) "") (def-format-test format.{.33 "~v{~a~}" (nil '(1 2 3 4 5 6 7)) "1234567") ;;; ~:{ ... ~} (def-format-test format.\:{.1 "~:{(~A ~A)~}" ('((1 2 3)(4 5)(6 7 8))) "(1 2)(4 5)(6 7)") (def-format-test format.\:{.2 (concatenate 'string "~:{~" (string #\Newline) "~}") (nil) "") (def-format-test format.\:{.3 "~:{~}" ("" nil) "") (def-format-test format.\:{.4 "~:{~}" ("~A" nil) "") (def-format-test format.\:{.5 "~:{~}" ("X" '(nil (1 2) (3))) "XXX") (deftest format.\:{.6 (format nil "~:{~}" (formatter "~A") '((1 2) (3) (4 5 6))) "134") (def-format-test format.\:{.7 "~0:{XYZ~}" ('((1))) "") (def-format-test format.\:{.8 "~2:{XYZ~}" ('((1))) "XYZ") (def-format-test format.\:{.9 "~2:{~A~}" ('((1) (2))) "12") (def-format-test format.\:{.10 "~2:{~A~}" ('((1 X) (2 Y) (3 Z))) "12") (deftest format.\:{.11 (loop for i from 0 to 10 collect (format nil "~v:{~A~}" i '((1) (2) (3 X) (4 Y Z) (5) (6)))) ("" "1" "12" "123" "1234" "12345" "123456" "123456" "123456" "123456" "123456")) (deftest formatter.\:{.11 (let ((fn (formatter "~v:{~A~}"))) (loop for i from 0 to 10 collect (formatter-call-to-string fn i '((1) (2) (3 X) (4 Y Z) (5) (6))))) ("" "1" "12" "123" "1234" "12345" "123456" "123456" "123456" "123456" "123456")) (def-format-test format.\:{.12 "~V:{X~}" (nil '((1) (2) (3) nil (5))) "XXXXX") (def-format-test format.\:{.13 "~#:{~A~}" ('((1) (2) (3) (4) (5)) 'foo 'bar) "123" 2) (def-format-test format.\:{.14 "~:{~A~:}" ('((1 X) (2 Y) (3) (4 A B))) "1234") (deftest format.\:{.15 (loop for i from 0 to 10 collect (format nil "~v:{~A~:}" i '((1 X) (2 Y) (3) (4 A B)))) ("" "1" "12" "123" "1234" "1234" "1234" "1234" "1234" "1234" "1234")) (deftest formatter.\:{.15 (let ((fn (formatter "~v:{~A~:}"))) (loop for i from 0 to 10 collect (formatter-call-to-string fn i '((1 X) (2 Y) (3) (4 A B))))) ("" "1" "12" "123" "1234" "1234" "1234" "1234" "1234" "1234" "1234")) (def-format-test format.\:{.16 "~:{ABC~:}" ('(nil)) "ABC") (def-format-test format.\:{.17 "~v:{ABC~:}" (nil '(nil)) "ABC") ;;; Tests of ~@{ ... ~} (def-format-test format.@{.1 (concatenate 'string "~@{~" (string #\Newline) "~}") nil "") (def-format-test format.@{.1A "~@{~}" ("") "") (def-format-test format.@{.2 "~@{ ~}" nil "") (def-format-test format.@{.3 "~@{X ~A Y Z~}" (nil) "X NIL Y Z") (def-format-test format.@{.4 "~@{~A~}" (1 2 3 4) "1234") (def-format-test format.@{.5 "~@{~{~A~}~}" ('(1 2 3) '(4 5) '(6 7 8)) "12345678") (def-format-test format.@{.6 "~@{~1{~A~}~}" ('(1 2 3) '(4 5) '(6 7 8)) "146") (def-format-test format.@{.7 "~1@{FOO~}" nil "") (def-format-test format.@{.8 "~v@{~A~}" (nil 1 4 7) "147") (def-format-test format.@{.9 "~#@{~A~}" (1 2 3) "123") (deftest format.@{.10 (loop for i from 0 to 10 for x = nil then (cons i x) collect (apply #'format nil "~v@{~A~}" i (reverse x))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (deftest formatter.@{.10 (let ((fn (formatter "~v@{~A~}"))) (loop for i from 0 to 10 for x = nil then (cons i x) for rest = (list 'a 'b 'c) collect (with-output-to-string (s) (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (def-format-test format.@{.11 "~@{X~:}" nil "X") (def-format-test format.@{.12 "~@{~}" ((formatter "X~AY") 1) "X1Y") (def-format-test format.@{.13 "~v@{~}" (1 (formatter "X") 'foo) "X" 1) ;;; ~:@{ (def-format-test format.\:@{.1 (concatenate 'string "~:@{~" (string #\Newline) "~}") nil "") (def-format-test format.\:@{.2 "~:@{~A~}" ('(1 2) '(3) '(4 5 6)) "134") (def-format-test format.\:@{.3 "~:@{(~A ~A)~}" ('(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") (def-format-test format.\:@{.4 "~:@{~}" ("(~A ~A)" '(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") (def-format-test format.\:@{.5 "~:@{~}" ((formatter "(~A ~A)") '(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") (def-format-test format.\:@.6 "~:@{~A~:}" ('(1 A) '(2 B) '(3) '(4 C D)) "1234") (def-format-test format.\:@.7 "~0:@{~A~:}" ('(1 A) '(2 B) '(3) '(4 C D)) "" 4) (def-format-test format.\:@.8 "~#:@{A~:}" (nil nil nil) "AAA") (def-format-test format.\:@.9 "~v:@{~A~}" (nil '(1) '(2) '(3)) "123") (deftest format.\:@.10 (loop for i from 0 to 10 for x = nil then (cons (list i) x) collect (apply #'format nil "~V:@{~A~}" i (reverse x))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (deftest formatter.\:@.10 (let ((fn (formatter "~V@:{~A~}"))) (loop for i from 0 to 10 for x = nil then (cons (list i) x) for rest = (list 'a 'b) collect (with-output-to-string (s) (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) ;;; Error tests (deftest format.{.error.1 (signals-type-error x 'A (format nil "~{~A~}" x)) t) (deftest format.{.error.2 (signals-type-error x 1 (format nil "~{~A~}" x)) t) (deftest format.{.error.3 (signals-type-error x "foo" (format nil "~{~A~}" x)) t) (deftest format.{.error.4 (signals-type-error x #*01101 (format nil "~{~A~}" x)) t) (deftest format.{.error.5 (signals-error (format nil "~{~A~}" '(x y . z)) type-error) t) (deftest format.\:{.error.1 (signals-error (format nil "~:{~A~}" '(x)) type-error) t) (deftest format.\:{.error.2 (signals-type-error x 'x (format nil "~:{~A~}" x)) t) (deftest format.\:{.error.3 (signals-error (format nil "~:{~A~}" '((x) . y)) type-error) t) (deftest format.\:{.error.4 (signals-error (format nil "~:{~A~}" '("X")) type-error) t) (deftest format.\:{.error.5 (signals-error (format nil "~:{~A~}" '(#(X Y Z))) type-error) t) (deftest format.\:@{.error.1 (signals-type-error x 'x (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.2 (signals-type-error x 0 (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.3 (signals-type-error x #*01101 (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.4 (signals-type-error x "abc" (format nil "~:@{~A~}" x)) t) (deftest format.\:@{.error.5 (signals-error (format nil "~:@{~A ~A~}" '(x . y)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/copy-tree.lsp0000644000000000000000000000013014542551762016076 xustar0030 mtime=1703597042.924022307 28 atime=1744294960.4737891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/copy-tree.lsp0000644000175000017500000000210514542551762015474 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:31:33 2003 ;;;; Contains: Tests of COPY-TREE (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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)))) (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) (def-fold-test copy-tree.fold.1 (copy-tree '(a . b))) (def-fold-test copy-tree.fold.2 (copy-tree '(a))) (def-fold-test copy-tree.fold.3 (copy-tree '(a b c d e))) ;;; Error tests (deftest copy-tree.error.1 (signals-error (copy-tree) program-error) t) (deftest copy-tree.error.2 (signals-error (copy-tree 'a 'b) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/universe.lsp0000644000000000000000000000012714542551763016036 xustar0029 mtime=1703597043.02802247 28 atime=1744294960.4737891 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/universe.lsp0000644000175000017500000003456014542551763015440 0ustar00cammcamm;-*- 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) (defparameter *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)) (defparameter *condition-objects* (locally (declare (optimize safety)) (loop for tp in *condition-types* append (handler-case (list (make-condition tp)) (error () nil))))) (defparameter *standard-package-names* '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) (defparameter *package-objects* (locally (declare (optimize safety)) (loop for pname in *standard-package-names* append (handler-case (let ((pkg (find-package pname))) (and pkg (list pkg))) (error () nil))))) (defparameter *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))) (defparameter *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))) (defparameter *ratios* '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 189729874978126783786123/1234678123487612347896123467851234671234)) (defparameter *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) #C(10.0s0 20.0s0) #C(100.0l0 200.0l0) #C(1.0s0 2.0f0) #C(1.0s0 3.0d0) #C(1.0s0 4.0l0) #C(1.0f0 5.0d0) #C(1.0f0 6.0l0) #C(1.0d0 7.0l0) #C(1.0f0 2.0s0) #C(1.0d0 3.0s0) #C(1.0l0 4.0s0) #C(1.0d0 5.0f0) #C(1.0l0 6.0f0) #C(1.0l0 7.0d0) #C(1/2 1/3) )) (defparameter *numbers* (append *integers* *floats* *ratios* *complexes*)) (defparameter *reals* (append *integers* *floats* *ratios*)) (defparameter *rationals* (append *integers* *ratios*)) (defun try-to-read-chars (&rest namelist) (declare (optimize safety)) (loop for name in namelist append (handler-case (list (read-from-string (concatenate 'string "\#\\" name))) (error () nil)))) (defparameter *characters* (remove-duplicates `(#\Newline #\Space ,@(try-to-read-chars "Rubout" "Page" "Tab" "Backspace" "Return" "Linefeed" "Null") #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] ))) (defparameter *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) ;; Specialized strings (make-array 3 :element-type 'character :displaced-to (make-array 5 :element-type 'character :initial-contents "abcde") :displaced-index-offset 1) (make-array 10 :initial-element #\x :fill-pointer 5 :element-type 'character) (make-array 10 :initial-element #\x :element-type 'base-char) (make-array 3 :initial-element #\y :adjustable t :element-type 'base-char) ))) (defparameter *conses* (list (list 'a 'b) (list nil) (list 1 2 3 4 5 6))) (defparameter *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)))) (defparameter *booleans* '(nil t)) (defparameter *keywords* '(:a :b :|| :|a| :|1234|)) (defparameter *uninterned-symbols* (list '#:nil '#:t '#:foo '#:||)) (defparameter *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)))) )) (defparameter *cl-user-symbols* '(cl-user::foo cl-user::x cl-user::cons cl-user::lambda cl-user::*print-readably* cl-user::push)) (defparameter *symbols* (append *booleans* *keywords* *uninterned-symbols* *cl-test-symbols* *cl-user-symbols*)) (defparameter *array-dimensions* (loop for i from 0 to 8 collect (loop for j from 1 to i collect 2))) (defparameter *default-array-target* (make-array '(300))) (defparameter *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)) for element in '(18 16.0f0 0 #\x #\y 127 200) append (loop for d in *array-dimensions* collect (make-array d :element-type tp :initial-element element))) ;; More typed arrays (loop for i from 1 to 64 append (list (make-array 10 :element-type `(unsigned-byte ,i) :initial-element 1) (make-array 10 :element-type `(signed-byte ,i) :initial-element 0))) ;; 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 (make-array 10 :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 1 0 1) :fill-pointer 8) (make-array 5 :element-type 'bit :displaced-to #*0111000110 :displaced-index-offset 3) (make-array 10 :element-type 'bit :initial-contents '(1 1 0 0 1 1 1 0 1 1) :adjustable t) ) ;; 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)) ) ;; The ever-popular NIL array (locally (declare (optimize safety)) (handler-case (list (make-array '(0) :element-type nil)) (error () nil))) ;; more kinds of arrays here later? )) (defparameter *hash-tables* (list (make-hash-table) (make-hash-table :test #'eq) (make-hash-table :test #'eql) (make-hash-table :test #'equal) #-(or 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:"))) ))) (defparameter *streams* (remove-duplicates (remove-if #'null (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *terminal-io* *trace-output*)))) (defparameter *readtables* (list *readtable* (copy-readtable))) (defstruct foo-structure x y z) (defstruct bar-structure x y z) (defparameter *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) )) (defun meaningless-user-function-for-universe (x y z) (list (+ x 1) (+ y 2) (+ z 3))) (defgeneric meaningless-user-generic-function-for-universe (x y z) #+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z))) (eval-when (:load-toplevel :execute) (compile 'meaningless-user-function-for-universe) ;; Conditionalize to avoid a cmucl bug #-(or cmu gcl ecl) (compile 'meaningless-user-generic-function-for-universe) ) (defparameter *functions* (list #'cons #'car #'append #'values (macro-function 'cond) #'meaningless-user-function-for-universe #'meaningless-user-generic-function-for-universe #'(lambda (x) x) (compile nil '(lambda (x) x)))) (defparameter *methods* (list #+(or (not :gcl) :ansi-cl ) (find-method #'meaningless-user-generic-function-for-universe nil (mapcar #'find-class '(integer integer integer))) ;; Add more methods here )) (defparameter *random-states* (list (make-random-state))) (defparameter *universe* (remove-duplicates (append *symbols* *numbers* *characters* (mapcar #'copy-seq *strings*) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *logical-pathnames* *streams* *readtables* *structures* *functions* *random-states* *methods* nil))) (defparameter *mini-universe* (remove-duplicates (append (mapcar #'first (list *symbols* *numbers* *characters* (list (copy-seq (first *strings*))) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *logical-pathnames* *streams* *readtables* *structures* *functions* *random-states* *methods*)) '(;;; Others to fill in gaps 1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000)))) (defparameter *classes* (remove-duplicates (mapcar #'class-of *universe*))) (defparameter *built-in-classes* (remove-if-not #'(lambda (x) (typep x 'built-in-class)) *classes*)) gcl-2.7.1/ansi-tests/PaxHeaders/load-hash-tables.lsp0000644000000000000000000000013014772071553017277 xustar0030 mtime=1743287147.138903117 28 atime=1744294960.4737891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-hash-tables.lsp0000644000175000017500000000065314772071553016703 0ustar00cammcamm(compile-and-load "hash-table-aux.lsp") (load "hash-table.lsp") (load "make-hash-table.lsp") (load "hash-table-p.lsp") (load "hash-table-count.lsp") (load "hash-table-size.lsp") (load "hash-table-rehash-size.lsp") (load "hash-table-rehash-threshold.lsp") (load "hash-table-test.lsp") (load "gethash.lsp") (load "remhash.lsp") (load "clrhash.lsp") (load "maphash.lsp") (load "with-hash-table-iterator.lsp") (load "sxhash.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/length.lsp0000644000000000000000000000012714542551762015456 xustar0029 mtime=1703597042.99602242 28 atime=1744294960.4737891 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/length.lsp0000644000175000017500000000747414542551762015064 0ustar00cammcamm;-*- 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.bit-vector.1 (length #*) 0) (deftest length.bit-vector.2 (length #*1) 1) (deftest length.bit-vector.3 (length #*0) 1) (deftest length.bit-vector.4 (length #*010101) 6) (deftest length.bit-vector.5 (let ((i 0)) (flet ((%f () (incf i) (make-array 5 :element-type 'bit :initial-contents '(0 0 1 1 0)))) (values (length (the (simple-bit-vector 5) (%f))) i))) 5 1) (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) (deftest length.string.5 (let ((i 0)) (flet ((%f () (incf i) (make-string 5 :initial-element #\a))) (values (length (the (simple-string 5) (%f))) i))) 5 1) (deftest length.string.6 (let ((i 0)) (flet ((%f () (incf i) (make-array 5 :element-type 'base-char :initial-element #\a))) (values (length (the (simple-base-string 5) (%f))) i))) 5 1) (deftest length.string.7 (do-special-strings (s "12345" nil) (assert (= (length s) 5))) nil) (deftest length.string.8 (do-special-strings (s "" nil) (assert (= (length s) 0))) nil) ;;; Error cases (deftest length.error.1 (check-type-error #'length #'(lambda (x) (typep x 'sequence))) nil) (deftest length.error.6 (signals-error (length) program-error) t) (deftest length.error.7 (signals-error (length nil nil) program-error) t) (deftest length.error.8 (signals-error (locally (length 'a) t) type-error) t) ;;; Length on vectors created with make-array (deftest length.array.1 (length (make-array '(20))) 20) (deftest length.array.2 (length (make-array '(100001))) 100001) (deftest length.array.3 (length (make-array '(0))) 0) (deftest length.array.4 (let ((x (make-array '(100) :fill-pointer 10))) (length x)) 10) (deftest length.array.5 (let ((x (make-array '(100) :fill-pointer 10))) (setf (fill-pointer x) 20) (length x)) 20) ;;; Unusual vectors (deftest length.array.6 (loop for i from 1 to 40 for etype = `(unsigned-byte ,i) for vec = (make-array 7 :element-type etype :initial-element 0) for len = (length vec) unless (eql len 7) collect (list i vec len)) nil) (deftest length.array.7 (loop for i from 1 to 40 for etype = `(signed-byte ,i) for vec = (make-array 13 :element-type etype :initial-element 0) for len = (length vec) unless (eql len 13) collect (list i vec len)) nil) (deftest length.array.8 (loop for etype in '(short-float single-float double-float long-float rational) for vec = (make-array 5 :element-type etype :initial-element (coerce 0 etype)) for len = (length vec) unless (eql len 5) collect (list etype vec len)) nil) (deftest length.array.9 (do-special-integer-vectors (v #(0 1 1 0 0 1) nil) (assert (eql (length v) 6))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/makunbound.lsp0000644000000000000000000000013014542551763016333 xustar0030 mtime=1703597043.000022426 28 atime=1744294960.4737891 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/makunbound.lsp0000644000175000017500000000215314542551763015734 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 13 07:55:05 2004 ;;;; Contains: Add tests for MAKUNBOUND (in-package :cl-test) (deftest makunbound.1 (let ((sym (gensym))) (values (boundp sym) (equalt (multiple-value-list (makunbound sym)) (list sym)) (boundp sym) (setf (symbol-value sym) nil) (notnot (boundp sym)) (equalt (multiple-value-list (makunbound sym)) (list sym)) (boundp sym))) nil t nil nil t t nil) (deftest makunbound.2 (let ((sym (gensym))) (values (boundp sym) (setf (symbol-value sym) :foo) (equalt (multiple-value-list (makunbound sym)) (list sym)) (boundp sym) (handler-case (symbol-value sym) (unbound-variable (c) (if (eq (cell-error-name c) sym) :good (list :bad sym (cell-error-name c))))))) nil :foo t nil :good) ;;; Error cases (deftest makunbound.error.1 (signals-error (makunbound) program-error) t) (deftest makunbound.error.2 (signals-error (makunbound (gensym) nil) program-error) t) (deftest makunbound.error.3 (check-type-error #'makunbound #'symbolp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/last.lsp0000644000000000000000000000012714542551762015140 xustar0029 mtime=1703597042.99602242 28 atime=1744294960.4737891 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/last.lsp0000644000175000017500000000402514542551762014533 0ustar00cammcamm;-*- 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) (compile-and-load "cons-aux.lsp") (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.11 (let ((x '(a b c))) (eqt (last x (1+ most-positive-fixnum)) x)) t) (deftest last.12 (let ((x '(a b c . d))) (eqt (last x (1+ most-positive-fixnum)) x)) t) (deftest last.13 (let ((x '(a b c . d))) (eqt (last x most-positive-fixnum) x)) t) (deftest last.14 (let ((x '(a b c . d))) (eqt (last x (1- most-positive-fixnum)) x)) t) (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 (signals-error (last (list 'a 'b 'c) -1) type-error) t) (deftest last.error.2 (signals-error (last (list 'a 'b 'c) 'a) type-error) t) (deftest last.error.3 (signals-error (last (list 'a 'b 'c) 10.0) type-error) t) (deftest last.error.4 (signals-error (last (list 'a 'b 'c) -10.0) type-error) t) (deftest last.error.5 (signals-error (last (list 'a 'b 'c) #\w) type-error) t) (deftest last.error.6 (signals-error (last) program-error) t) (deftest last.error.7 (signals-error (last '(a b c) 2 nil) program-error) t) (deftest last.error.8 (signals-error (locally (last (list 'a 'b 'c) 'a) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/integerp.lsp0000644000000000000000000000012714542551762016012 xustar0029 mtime=1703597042.99602242 28 atime=1744294960.4737891 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/integerp.lsp0000644000175000017500000000120214542551762015377 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 10:18:34 2003 ;;;; Contains: Tests for INTEGERP (in-package :cl-test) (deftest integerp.error.1 (signals-error (integerp) program-error) t) (deftest integerp.error.2 (signals-error (integerp 0 0) program-error) t) (deftest integerp.error.3 (signals-error (integerp nil nil) program-error) t) (deftest integerp.1 (loop for i in *integers* for vals = (multiple-value-list (integerp i)) unless (and (= (length vals) 1) (first vals)) collect (cons i vals)) nil) (deftest integerp.2 (check-type-predicate #'integerp 'integer) nil) gcl-2.7.1/ansi-tests/PaxHeaders/random-state-p.lsp0000644000000000000000000000012714542551763017031 xustar0030 mtime=1703597043.016022451 28 atime=1744294960.4737891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-state-p.lsp0000644000175000017500000000111114542551763016415 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 17:50:04 2003 ;;;; Contains: Tests of RANDOM-STATE-P (in-package :cl-test) (deftest random-state-p.error.1 (signals-error (random-state-p) program-error) t) (deftest random-state-p.error.2 (signals-error (random-state-p nil nil) program-error) t) (deftest random-state-p.1 (check-type-predicate #'random-state-p 'random-state) nil) (deftest random-state-p.2 (notnot-mv (random-state-p *random-state*)) t) (deftest random-state-p.3 (notnot-mv (random-state-p (make-random-state))) t) gcl-2.7.1/ansi-tests/PaxHeaders/rest.lsp0000644000000000000000000000012714542551763015153 xustar0030 mtime=1703597043.020022457 28 atime=1744294960.4737891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rest.lsp0000644000175000017500000000072214542551763014546 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:49:14 2003 ;;;; Contains: Tests of REST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (rest) program-error) t) (deftest rest.error.2 (signals-error (rest nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/sqrt.lsp0000644000000000000000000000013014557713047015162 xustar0030 mtime=1707054631.470785173 28 atime=1744294960.4737891 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sqrt.lsp0000644000175000017500000001044014557713047014561 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 10:54:17 2003 ;;;; Contains: Tests of SQRT (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest sqrt.error.1 (signals-error (sqrt) program-error) t) (deftest sqrt.error.2 (signals-error (sqrt 0 nil) program-error) t) (deftest sqrt.error.3 (check-type-error #'sqrt #'numberp) nil) (deftest sqrt.1 (let ((s (sqrt 0))) (and (realp s) (=t s 0))) t) (deftest sqrt.2 (let ((s (sqrt 1))) (and (realp s) (=t s 1))) t) (deftest sqrt.3 (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) for s = (sqrt x) unless (eql s x) collect (list x s)) nil) (deftest sqrt.4 (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) for c = (complex x 0) for s = (sqrt c) unless (eql s c) collect (list x c s)) nil) (deftest sqrt.5 (loop for x in '(-1.0s0 -1.0f0 -1.0d0 -1.0l0) for s = (sqrt x) unless (eql s (complex 0 (- x))) collect (list x s)) nil) ;;; (deftest sqrt.6 ;;; (let ((result (sqrt (ash 1 10000)))) ;;; (if (integerp result) ;;; (=t result (ash 1 5000)) ;;; (=t result (float (ash 1 5000) result)))) ;;; t) (deftest sqrt.7 (let ((result (sqrt -1))) (or (eqlt result #c(0 1)) (eqlt result #c(0.0 1.0)))) t) (deftest sqrt.8 (loop for x in *floats* for s = (sqrt x) unless (cond ((zerop x) (=t x 0)) ((plusp x) (and (eqlt (float s x) s) (eqlt (float x s) x))) (t (complexp s))) collect (list x s)) nil) (deftest sqrt.9 (let ((upper (rational most-positive-double-float)) (lower (rational most-negative-double-float))) (loop for x = (random-fixnum) repeat 1000 unless (or (< x lower) (> x upper) (let ((s (sqrt x))) (or (and (rationalp s) (>= s 0) (eql (* s s) x)) (and (floatp s) (>= x 0)) (and (complexp s) (zerop (realpart s)) (> (imagpart s) 0) (< x 0))))) collect (list x (sqrt x)))) nil) (deftest sqrt.10 (loop for x from 1 to 1000 for x2 = (* x x) for s = (sqrt x2) unless (if (rationalp s) (eql x s) (and (typep s 'single-float) (= x s))) collect (list x s)) nil) (deftest sqrt.11 (loop for x from 1 to 1000 for x2 = (* x x) for s = (sqrt (- x2)) unless (and (complexp s) (zerop (realpart s)) (let ((i (imagpart s))) (if (rationalp i) (eql i x) (= i x)))) collect (list x s)) nil) ;;; Tests of the branch cut (deftest sqrt.12 (loop for xr = (random-fixnum) for xi = (random-fixnum) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.13 (loop for xr = (random-from-interval 1.0f6 -1.0f6) for xi = (random-from-interval 1.0f6 -1.0f6) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.14 (loop for xr = (random-from-interval 1.0s3 -1.0s3) for xi = (random-from-interval 1.0s3 -1.0s3) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.15 (loop for xr = (random-from-interval 1.0d7 -1.0d7) for xi = (random-from-interval 1.0d7 -1.0d7) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.16 (loop for xr = (random-from-interval 1.0l9 -1.0l9) for xi = (random-from-interval 1.0l9 -1.0l9) for c = (complex xr xi) for s = (sqrt c) repeat 1000 unless (or (> (realpart s) 0) (and (= (realpart s) 0) (>= (imagpart s) 0))) collect (list c s)) nil) (deftest sqrt.17 (let ((b1 (find-largest-exactly-floatable-integer most-positive-fixnum))) (loop for i = (random-from-interval (* b1 b1) 0) repeat 1000 unless (>= (sqrt i) (isqrt i)) collect i)) nil) (deftest sqrt.18 (loop for x = (random-from-interval 1.0f6 0.0f0) repeat 1000 unless (>= (sqrt x) (isqrt (floor x))) collect x) nil) (deftest sqrt.19 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for s = (sqrt x) unless (= s x) collect (list x s)) nil) (deftest sqrt.20 (sqrt 1075) 32.78719262151) gcl-2.7.1/ansi-tests/PaxHeaders/reduce.lsp0000644000000000000000000000013114542551763015440 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.477789118 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/reduce.lsp0000644000175000017500000003277414542551763015054 0ustar00cammcamm;-*- 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) ;;; Specialized vectors (deftest reduce-array.20 (do-special-integer-vectors (v #(1 0 0 1 1 0) nil) (assert (eql (reduce #'+ v) 3))) nil) (deftest reduce-array.21 (do-special-integer-vectors (v #(1 0 0 1 1 0) nil) (assert (equal (reduce #'cons v :from-end t :initial-value nil) '(1 0 0 1 1 0)))) nil) (deftest reduce-array.22 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (eql (reduce #'+ v) 28)) (assert (eql (reduce #'+ v :from-end t) 28)) (assert (eql (reduce #'+ v :start 1) 27)) (assert (eql (reduce #'+ v :initial-value 10) 38)) (assert (eql (reduce #'+ v :end 6) 21))) nil) (deftest reduce-array.23 (let* ((len 10) (expected (* 1/2 (1+ len) len))) (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for i from 1 to len collect (coerce i etype)) for vec = (make-array len :initial-contents vals :element-type etype) for result = (reduce #'+ vec) unless (= result (coerce expected etype)) collect (list etype vals vec result))) nil) (deftest reduce-array.24 (let* ((len 10) (expected (* 1/2 (1+ len) len))) (loop for cetype in '(short-float single-float double-float long-float) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :initial-contents vals :element-type etype) for result = (reduce #'+ vec) unless (= result (complex (coerce expected cetype) (coerce (- expected) cetype))) collect (list etype vals vec result))) nil) (deftest reduce-array.25 (do-special-integer-vectors (v (vector 0 most-positive-fixnum 0 most-positive-fixnum 0) nil) (assert (eql (reduce #'+ v) (* 2 most-positive-fixnum)))) nil) ;;;;;;;; (deftest reduce.error.1 (check-type-error #'(lambda (x) (reduce 'cons x)) #'sequencep) nil) (deftest reduce.error.2 (signals-error (reduce) program-error) t) (deftest reduce.error.3 (signals-error (reduce #'list nil :start) program-error) t) (deftest reduce.error.4 (signals-error (reduce #'list nil 'bad t) program-error) t) (deftest reduce.error.5 (signals-error (reduce #'list nil 'bad t :allow-other-keys nil) program-error) t) (deftest reduce.error.6 (signals-error (reduce #'list nil 1 2) program-error) t) (deftest reduce.error.7 (signals-error (locally (reduce 'cons 'a) t) type-error) t) (deftest reduce.error.8 (signals-error (reduce #'identity '(a b c)) program-error) t) (deftest reduce.error.9 (signals-error (reduce #'cons '(a b c) :key #'cons) program-error) t) (deftest reduce.error.10 (signals-error (reduce #'cons '(a b c) :key #'car) type-error) t) ;;;;;;;; (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-string.18 (do-special-strings (s "12345" nil) (let ((x (reduce #'(lambda (x y) (cons y x)) s))) (assert (equal x '(#\5 #\4 #\3 #\2 . #\1))))) nil) (deftest reduce-string.19 (do-special-strings (s "54321" nil) (let ((x (reduce #'cons s :from-end t))) (assert (equal x '(#\5 #\4 #\3 #\2 . #\1))))) nil) (deftest reduce-string.20 (do-special-strings (s "12345" nil) (let ((x (reduce #'(lambda (x y) (cons y x)) s :initial-value nil))) (assert (equal x '(#\5 #\4 #\3 #\2 #\1))))) nil) ;;;;;;;; (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.7.1/ansi-tests/PaxHeaders/rename-package.lsp0000644000000000000000000000013114542551763017031 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.477789118 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rename-package.lsp0000644000175000017500000001531614542551763016436 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:00:28 1998 ;;;; Contains: Tests of RENAME-PACKAGE (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.7 (block nil (let ((name1 (make-array '(5) :element-type 'base-char :initial-contents "TEST1")) (name2 (make-array '(5) :element-type 'base-char :initial-contents "TEST2"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package name1))) (unless (packagep p) (return nil)) (let ((p2 (rename-package name1 name2))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) name2)) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t)))) t) (deftest rename-package.8 (block nil (let ((name1 (make-array '(10) :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1 ")) (name2 (make-array '(9) :element-type 'character :fill-pointer 5 :initial-contents "TEST2XXXX"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package "TEST1"))) (unless (packagep p) (return nil)) (let ((p2 (rename-package name1 name2))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (string= (package-name p2) "TEST2")) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t)))) t) (deftest rename-package.9 (block nil (let ((name1 (make-array '(5) :element-type 'character :adjustable t :initial-contents "TEST1")) (name2 (make-array '(5) :element-type 'base-char :adjustable t :initial-contents "TEST2"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package "TEST1"))) (unless (packagep p) (return nil)) (let ((p2 (rename-package name1 name2))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (string= (package-name p2) "TEST2")) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t)))) t) (deftest rename-package.error.1 (signals-error (rename-package) program-error) t) (deftest rename-package.error.2 (signals-error (rename-package "CL") program-error) t) (deftest rename-package.error.3 (signals-error (rename-package "A" "XXXXX" NIL NIL) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/bit-eqv.lsp0000644000000000000000000000013014542551762015536 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.477789118 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-eqv.lsp0000644000175000017500000001532114542551762015140 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:07:23 2003 ;;;; Contains: Tests of BIT-EQV (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-eqv (expand-in-current-env (%m #*0011)) #*0101)) #*1001) (deftest bit-eqv.21 (macrolet ((%m (z) z)) (bit-eqv #*1010 (expand-in-current-env (%m #*1100)))) #*1001) (deftest bit-eqv.22 (macrolet ((%m (z) z)) (bit-eqv #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*00110110) (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) (def-fold-test bit-eqv.fold.1 (bit-eqv #*01101 #*10100)) ;;; Random tests (deftest bit-eqv.random.1 (bit-random-test-fn #'bit-eqv #'logeqv) nil) ;;; Error tests (deftest bit-eqv.error.1 (signals-error (bit-eqv) program-error) t) (deftest bit-eqv.error.2 (signals-error (bit-eqv #*000) program-error) t) (deftest bit-eqv.error.3 (signals-error (bit-eqv #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/upgraded-complex-part-type.lsp0000644000000000000000000000013114542551763021354 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.477789118 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/upgraded-complex-part-type.lsp0000644000175000017500000000645414542551763020764 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 27 21:15:46 2004 ;;;; Contains: Tests of UPGRADE-COMPLEX-PART-TYPE (in-package :cl-test) (compile-and-load "types-aux.lsp") (defmacro def-ucpt-test (name types) `(deftest ,name (loop for type in (remove-duplicates ,types) for upgraded-type = (upgraded-complex-part-type type) for result = (append (check-all-subtypep type upgraded-type) (check-all-subtypep type 'real) (check-all-subtypep `(complex ,type) 'complex) (check-all-subtypep `(complex ,upgraded-type) 'complex) (check-all-subtypep `(complex ,type) `(complex ,upgraded-type))) when result collect result) nil)) (def-ucpt-test upgraded-complex-part-type.1 '(real integer rational ratio float short-float single-float double-float long-float fixnum bignum bit unsigned-byte signed-byte)) (def-ucpt-test upgraded-complex-part-type.2 (mapcar #'find-class '(real float integer rational ratio))) (def-ucpt-test upgraded-complex-part-type.3 (mapcar #'class-of '(1.0s0 1.0f0 1.0d0 1.0l0))) (def-ucpt-test upgraded-complex-part-type.4 (loop for i from 1 to 100 collect `(unsigned-byte ,i))) (def-ucpt-test upgraded-complex-part-type.5 (loop for i from 1 to 100 collect `(signed-byte ,i))) (def-ucpt-test upgraded-complex-part-type.6 (loop for i = 1 then (* i 2) repeat 100 collect (class-of i))) ;;; environment argument (deftest upgraded-complex-part-type.7 (loop for type in '(real integer rational float short-float single-float double-float long-float fixnum bignum bit unsigned-byte signed-byte) for ut1 = (upgraded-complex-part-type type) for ut2 = (upgraded-complex-part-type type nil) unless (equal ut1 ut2) collect (list type ut1 ut2)) nil) (deftest upgraded-complex-part-type.8 (loop for type in '(real integer rational float short-float single-float double-float long-float fixnum bignum bit unsigned-byte signed-byte) for ut1 = (upgraded-complex-part-type type) for ut2 = (eval `(macrolet ((%m (&environment env) (list 'quote (upgraded-complex-part-type ',type env)))) (%m))) unless (equal ut1 ut2) collect (list type ut1 ut2)) nil) ;;; Subtype constraint (deftest upgraded-complex-part-type.9 (let* ((types `(nil integer fixnum bignum float short-float single-float double-float long-float rational #-sbcl ratio real ,@(remove-duplicates (mapcar #'class-of '(0.0s0 0.0f0 0.0d0 0.0l0 0 100000000000000000))) ,@(mapcar #'(lambda (x) `(eql ,x)) (remove-duplicates '(0.0s0 0.0f0 0.0d0 0.0l0 0 1.0s0 1.0f0 1.0d0 1.0l0 1 100000000000000000))))) (utypes (mapcar #'upgraded-complex-part-type types))) (loop for sublist on types for usublist on utypes for tp1 = (car sublist) for utp1 = (car usublist) nconc (loop for tp2 in (cdr sublist) for utp2 in (cdr usublist) nconc (and (subtypep tp1 tp2) (let ((result (check-all-subtypep utp1 utp2))) (and result (list (list tp1 tp2 result)))))))) nil) ;;; Error tests (deftest upgraded-complex-part-type.error.1 (signals-error (upgraded-complex-part-type) program-error) t) (deftest upgraded-complex-part-type.error.2 (signals-error (upgraded-complex-part-type 'real nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-condition.lsp0000644000000000000000000000013214542551763017073 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.477789118 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-condition.lsp0000644000175000017500000000245714542551763016501 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 23 11:54:10 2005 ;;;; Contains: Tests of MAKE-CONDITION (in-package :cl-test) (deftest make-condition.1 (loop for tp in *cl-condition-type-symbols* for c = (make-condition tp) unless (and (typep c tp) (typep c 'condition)) collect (list tp c)) nil) (deftest make-condition.2 (loop for tp in *cl-condition-type-symbols* for class = (find-class tp) for c = (and class (make-condition class)) unless (or (not class) (and (typep c tp) (typep c class) (typep c 'condition))) collect (list tp c)) nil) (deftest make-condition.3 :notes (:make-condition-with-compound-name :ansi-spec-problem) (let* ((tp '(or program-error type-error)) (c (make-condition tp))) (or (not (and (subtypep tp 'condition) (or (subtypep 'program-error tp) (subtypep 'type-error tp)))) (notnot-mv (typep c tp)))) t) (deftest make-condition.4 :notes (:make-condition-with-compound-name :ansi-spec-problem) (let* ((tp '(and simple-error type-error)) (c (make-condition tp))) (or (not (and (subtypep 'simple-error tp) (subtypep 'type-error tp) (subtypep tp 'condition))) (notnot-mv (typep c tp)))) t) ;;; Error tests (deftest make-condition.error.1 (signals-error (make-condition) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/princ.lsp0000644000000000000000000000013114542551763015304 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.477789118 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/princ.lsp0000644000175000017500000000154314542551763014706 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:40:37 2004 ;;;; Contains: Tests of PRINC (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest princ.1 (random-princ-test 5) nil) (deftest princ.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (princ 2 t))))) "2") (deftest princ.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (princ 3 nil))) "3") ;;; Error tests (deftest princ.error.1 (signals-error (with-output-to-string (*standard-output*) (princ)) program-error) t) (deftest princ.error.2 (signals-error (with-output-to-string (s) (princ nil s nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-strings.lsp0000644000000000000000000000013214772071557016603 xustar0030 mtime=1743287151.234907028 30 atime=1744294960.477789118 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-strings.lsp0000644000175000017500000000112514772071557016200 0ustar00cammcamm;;; Tests of strings (load "char-schar.lsp") (load "string.lsp") (load "base-string.lsp") (load "simple-string.lsp") (load "simple-base-string.lsp") (load "simple-string-p.lsp") (load "stringp.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.7.1/ansi-tests/PaxHeaders/loop10.lsp0000644000000000000000000000013214542551763015304 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.477789118 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop10.lsp0000644000175000017500000002556414542551763014716 0ustar00cammcamm;-*- 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 (signals-error (loop with foo = 10 for x in '(a b c) count x into foo finally (return foo)) program-error) t) (deftest loop.10.10 (signals-error (loop with foo = 10 for x in '(a b c) counting x into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = 100 for i from 1 to 10 maximize i into foo finally (return foo)) program-error) t) (deftest loop.10.38 (signals-error (loop with foo = 100 for i from 1 to 10 maximizing i into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = 100 for i from 1 to 10 minimize i into foo finally (return foo)) program-error) t) (deftest loop.10.58 (signals-error (loop with foo = 100 for i from 1 to 10 minimizing i into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = 100 for i from 1 to 4 sum i into foo finally (return foo)) program-error) t) (deftest loop.10.86 (signals-error (loop with foo = 100 for i from 1 to 4 summing i into foo finally (return foo)) program-error) t) (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) (deftest loop.10.94 (loop for i in nil sum i of-type integer) 0) (deftest loop.10.95 (loop for i in nil sum i of-type fixnum) 0) (deftest loop.10.96 (loop for i in nil sum i of-type bit) 0) (deftest loop.10.97 (loop for i in nil sum i of-type (integer 0 100)) 0) (deftest loop.10.98 (loop for i in nil sum i of-type (integer -100 0)) 0) (deftest loop.10.99 (loop for i in nil sum i of-type (integer -100 100)) 0) (deftest loop.10.100 (loop for i in nil sum i of-type (and integer (real -100.0 100.0))) 0) (deftest loop.10.101 (loop for i in nil sum i of-type short-float) 0.0s0) (deftest loop.10.102 (loop for i in nil sum i of-type single-float) 0.0f0) (deftest loop.10.103 (loop for i in nil sum i of-type double-float) 0.0d0) (deftest loop.10.104 (loop for i in nil sum i of-type long-float) 0.0l0) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.10.105 (macrolet ((%m (z) z)) (loop for x from 1 to 10 count (expand-in-current-env (%m (< x 5))))) 4) (deftest loop.10.106 (macrolet ((%m (z) z)) (loop for x from 1 to 10 counting (expand-in-current-env (%m t)))) 10) (deftest loop.10.107 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) maximize (expand-in-current-env (%m x)))) 10) (deftest loop.10.108 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) maximizing (expand-in-current-env (%m 17)))) 17) (deftest loop.10.109 (macrolet ((%m (z) z)) (loop for x in '(5 4 10 1 7 9) minimize (expand-in-current-env (%m x)))) 1) (deftest loop.10.110 (macrolet ((%m (z) z)) (loop for x in '(5 4 10 1 7 9) minimizing (expand-in-current-env (%m 3)))) 3) (deftest loop.10.111 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) sum (expand-in-current-env (%m x)))) 36) (deftest loop.10.112 (macrolet ((%m (z) z)) (loop for x in '(1 4 10 5 7 9) summing (expand-in-current-env (%m 2)))) 12) gcl-2.7.1/ansi-tests/PaxHeaders/dolist.lsp0000644000000000000000000000013214542551762015467 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.477789118 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/dolist.lsp0000644000175000017500000000555414542551762015076 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:26:48 2005 ;;;; Contains: Tests of DOLIST (in-package :cl-test) (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)) ;;; Scope of free declarations (deftest dolist.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (dolist (e (return-from done x)) (declare (special x)))))) :good) (deftest dolist.17 (let ((x :good)) (declare (special x)) (let ((x :bad)) (dolist (e nil x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest dolist.18 (let ((result nil)) (macrolet ((%m (z) z)) (dolist (x (expand-in-current-env (%m '(a b c))) result) (push x result)))) (c b a)) (deftest dolist.19 (let ((result nil)) (macrolet ((%m (z) z)) (dolist (x '(a b c) (expand-in-current-env (%m result))) (push x result)))) (c b a)) ;;; Error tests (def-macro-test dolist.error.1 (dolist (x nil))) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-16.lsp0000644000000000000000000000013214542551762016334 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.477789118 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-16.lsp0000644000175000017500000003761414542551762015745 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/oneminus.lsp0000644000000000000000000000013114542551763016026 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.477789118 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/oneminus.lsp0000644000175000017500000000701314542551763015426 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 20:14:34 2003 ;;;; Contains: Tests of 1- (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest 1-.error.1 (signals-error (1-) program-error) t) (deftest 1-.error.2 (signals-error (1- 0 0) program-error) t) (deftest 1-.error.3 (signals-error (1- 0 nil nil) program-error) t) ;;; Non-error tests (deftest 1-.1 (loop for x = (random-fixnum) for y = (1- x) for z = (- x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.2 (loop for x = (random-from-interval (ash 1 1000)) for y = (1- x) for z = (- x 1) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.3 (loop for x = (random (1- most-positive-short-float)) for y = (1- x) for z = (- x 1.0s0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.4 (loop for x = (random (1- most-positive-single-float)) for y = (1- x) for z = (- x 1.0f0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.5 (loop for x = (random (1- most-positive-double-float)) for y = (1- x) for z = (- x 1.0d0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.6 (loop for x = (random (1- most-positive-long-float)) for y = (1- x) for z = (- x 1.0l0) repeat 1000 unless (eql y z) collect (list x y z)) nil) (deftest 1-.7 (loop for x = (random-fixnum) for y = (random-fixnum) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1- r) for r2 = (- r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2)) nil) (deftest 1-.8 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for y2 = (if (zerop y) 1 y) for r = (/ x y2) for r1 = (1- r) for r2 = (- r 1) repeat 1000 unless (eql r1 r2) collect (list x y2 r1 r2))) nil) ;;; Complex numbers (deftest 1-.9 (loop for xr = (random-fixnum) for xi = (random-fixnum) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1)) nil) (deftest 1-.10 (let ((bound (ash 1 100))) (loop for xr = (random-from-interval bound) for xi = (random-from-interval bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.11 (let ((bound (1- most-positive-short-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.12 (let ((bound (1- most-positive-single-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.13 (let ((bound (1- most-positive-double-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.14 (let ((bound (1- most-positive-long-float))) (loop for xr = (random bound) for xi = (random bound) for xc = (complex xr xi) for xc1 = (1- xc) repeat 1000 unless (eql xc1 (complex (- xr 1) xi)) collect (list xr xi xc xc1))) nil) (deftest 1-.15 (macrolet ((%m (z) z)) (1- (expand-in-current-env (%m 2)))) 1) gcl-2.7.1/ansi-tests/PaxHeaders/read-char.lsp0000644000000000000000000000013114542551763016017 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.477789118 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-char.lsp0000644000175000017500000000415314542551763015421 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/symbol-macrolet.lsp0000644000000000000000000000013114542551763017302 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.481789135 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/symbol-macrolet.lsp0000644000175000017500000000346514542551763016711 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 05:58:53 2005 ;;;; Contains: Tests of SYMBOL-MACROLET (in-package :cl-test) (deftest symbol-macrolet.1 (loop for s in *cl-non-variable-constant-symbols* for form = `(ignore-errors (symbol-macrolet ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) (deftest symbol-macrolet.2 (symbol-macrolet ()) nil) (deftest symbol-macrolet.3 (symbol-macrolet () (declare (optimize))) nil) (deftest symbol-macrolet.4 (symbol-macrolet ((x 1)) (symbol-macrolet ((x 2)) x)) 2) (deftest symbol-macrolet.5 (let ((x 10)) (symbol-macrolet ((y x)) (list x y (let ((x 20)) x) (let ((y 30)) x) (let ((y 50)) y) x y))) (10 10 20 10 50 10 10)) (deftest symbol-macrolet.6 (symbol-macrolet () (values))) (deftest symbol-macrolet.7 (symbol-macrolet () (values 'a 'b 'c 'd 'e)) a b c d e) (deftest symbol-macrolet.8 (let ((x :good)) (declare (special x)) (let ((x :bad)) (symbol-macrolet () (declare (special x)) x))) :good) ;;; Error tests (deftest symbol-macrolet.error.1 (signals-error (symbol-macrolet ((x 10)) (declare (special x)) 20) program-error) t) (defconstant constant-for-symbol-macrolet.error.2 nil) (deftest symbol-macrolet.error.2 (signals-error (symbol-macrolet ((constant-for-symbol-macrolet.error.2 'a)) constant-for-symbol-macrolet.error.2) program-error) t) (deftest symbol-macrolet.error.3 (signals-error (symbol-macrolet ((*pathnames* 19)) *pathnames*) program-error) t) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest symbol-macrolet.9 (macrolet ((%m (z) z)) (symbol-macrolet () (expand-in-current-env (%m :good)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/defgeneric.lsp0000644000000000000000000000013214542551762016264 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.481789135 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric.lsp0000644000175000017500000005466714542551762015704 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 20:55:50 2003 ;;;; Contains: Tests of DEFGENERIC (in-package :cl-test) ;;; Various error cases (defun defgeneric-testfn-01 (x) x) (deftest defgeneric.error.1 ;; Cannot make ordinary functions generic (let* ((name 'defgeneric-testfn-01) (fn (symbol-function name))) (if (not (typep fn 'generic-function)) (handler-case (progn (eval `(defgeneric ,name ())) :bad) (program-error () :good)) :good)) :good) (defmacro defgeneric-testmacro-02 (x) x) (deftest defgeneric.error.2 ;; Cannot make macros generic (let* ((name 'defgeneric-testmacro-02)) (handler-case (progn (eval `(defgeneric ,name ())) :bad) (program-error () :good))) :good) (deftest defgeneric.error.3 ;; Cannot make special operators generic (loop for name in *cl-special-operator-symbols* for result = (handler-case (progn (eval `(defgeneric ,name ())) t) (program-error () nil)) when result collect name) nil) (deftest defgeneric.error.4 (signals-error (defgeneric defgeneric-error-fn.4 (x y) (:argument-precedence-order x y x)) program-error) t) (deftest defgeneric.error.5 (signals-error (defgeneric defgeneric-error-fn.5 (x) (:documentation "some documentation") (:documentation "illegally repeated documentation")) program-error) t) (deftest defgeneric.error.6 (signals-error (defgeneric defgeneric-error-fn.6 (x) (unknown-option nil)) program-error) t) (deftest defgeneric.error.7 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.7 (x y) (:method ((x t)) x))) :bad) (error () :good)) :good) (deftest defgeneric.error.8 (signals-error (defgeneric defgeneric-error-fn.8 (x y) (:argument-precedence-order x)) program-error) t) ;;; Non-congruent methods cause defgeneric to signal an error (deftest defgeneric.error.9 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.9 (x) (:method ((x t)(y t)) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.10 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.10 (x &optional y) (:method ((x t)) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.11 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.11 (x &optional y) (:method (x &optional y z) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.12 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.12 (x &rest y) (:method (x) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.13 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.13 (x) (:method (x &rest y) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.14 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.14 (x &key) (:method (x) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.15 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.15 (x &key y) (:method (x) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.16 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.16 (x) (:method (x &key) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.17 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.17 (x) (:method (x &key foo) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.18 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.18 (x &key foo) (:method (x &key) t))) :bad) (error () :good)) :good) (deftest defgeneric.error.19 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.19 (x &key foo) (:method (x &key bar) t))) :bad) (error () :good)) :good) ;;; A close reading of the rules for keyword arguments to ;;; generic functions convinced me that the following two ;;; error tests are necessary. See sections 7.6.5 of the CLHS. (deftest defgeneric.error.20 (signals-error (let ((fn (defgeneric defgeneric-error-fn.20 (x &key) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar))))) (funcall fn 1 :bar 'a)) program-error) t) (deftest defgeneric.error.21 (signals-error (let ((fn (defgeneric defgeneric-error-fn.21 (x &key) (:method ((x number) &key foo &allow-other-keys) (list x foo)) (:method ((x symbol) &key bar) (list x bar))))) (funcall fn 'x :foo 'a)) program-error) t) ;;; (deftest defgeneric.error.22 (progn (defgeneric defgeneric-error-fn.22 (x)) (defmethod defgeneric-error-fn.22 ((x t)) nil) (handler-case (eval '(defgeneric defgeneric-error-fn.22 (x y))) (error () :good))) :good) ;;; Non error cases (deftest defgeneric.1 (let ((fn (eval '(defgeneric defgeneric.fun.1 (x y z) (:method ((x t) (y t) (z t)) (list x y z)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 'a 'b 'c) (apply fn 1 2 3 nil) (apply fn (list 4 5 6)) (mapcar fn '(1 2) '(3 4) '(5 6)) (defgeneric.fun.1 'd 'e 'f))) t t (a b c) (1 2 3) (4 5 6) ((1 3 5) (2 4 6)) (d e f)) (deftest defgeneric.2 (let ((fn (eval '(defgeneric defgeneric.fun.2 (x y z) (:documentation "boo!") (:method ((x t) (y t) (z t)) (vector x y z)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 'a 'b 'c) (defgeneric.fun.2 'd 'e 'f) (let ((doc (documentation fn t))) (or (not doc) (and (stringp doc) (string=t doc "boo!")))) (let ((doc (documentation fn 'function))) (or (not doc) (and (stringp doc) (string=t doc "boo!")))) (setf (documentation fn t) "foo") (let ((doc (documentation fn t))) (or (not doc) (and (stringp doc) (string=t doc "foo")))) (setf (documentation fn 'function) "bar") (let ((doc (documentation fn t))) (or (not doc) (and (stringp doc) (string=t doc "bar")))))) t t #(a b c) #(d e f) t t "foo" t "bar" t) (deftest defgeneric.3 (let ((fn (eval '(defgeneric defgeneric.fun.3 (x y) (:method ((x t) (y symbol)) (list x y)) (:method ((x symbol) (y t)) (list y x)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 1 'a) (funcall fn 'b 2) (funcall fn 'a 'b))) t t (1 a) (2 b) (b a)) (deftest defgeneric.4 (let ((fn (eval '(defgeneric defgeneric.fun.4 (x y) (:argument-precedence-order y x) (:method ((x t) (y symbol)) (list x y)) (:method ((x symbol) (y t)) (list y x)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (funcall fn 1 'a) (funcall fn 'b 2) (funcall fn 'a 'b))) t t (1 a) (2 b) (a b)) (deftest defgeneric.5 (let ((fn (eval '(defgeneric defgeneric.fun.5 () (:method () (values)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn)) (multiple-value-list (defgeneric.fun.5)) (multiple-value-list (apply fn nil)))) t t nil nil nil) (deftest defgeneric.6 (let ((fn (eval '(defgeneric defgeneric.fun.6 () (:method () (values 'a 'b 'c)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn)) (multiple-value-list (defgeneric.fun.6)) (multiple-value-list (apply fn nil)))) t t (a b c) (a b c) (a b c)) (deftest defgeneric.7 (let ((fn (eval '(defgeneric defgeneric.fun.7 () (:method () (return-from defgeneric.fun.7 'a) 'b))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn)) (multiple-value-list (defgeneric.fun.7)) (multiple-value-list (apply fn nil)))) t t (a) (a) (a)) (deftest defgeneric.8 (let ((fn (eval '(defgeneric defgeneric.fun.8 (x &optional y z) (:method ((x number) &optional y z) (list x y z)) (:method ((p symbol) &optional q r) (list r q p)))))) (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) (multiple-value-list (funcall fn 1)) (multiple-value-list (funcall fn 1 2)) (multiple-value-list (funcall fn 1 2 3)) (multiple-value-list (defgeneric.fun.8 'a)) (multiple-value-list (defgeneric.fun.8 'a 'b)) (multiple-value-list (defgeneric.fun.8 'a 'b 'c)) (multiple-value-list (apply fn '(x y z))))) t t ((1 nil nil)) ((1 2 nil)) ((1 2 3)) ((nil nil a)) ((nil b a)) ((c b a)) ((z y x))) (deftest defgeneric.9 (let ((fn (eval '(defgeneric defgeneric.fun.9 (x &optional y z) (:method ((x number) &optional (y 10) (z 20)) (list x y z)) (:method ((p symbol) &optional (q 's) (r 't)) (list r q p)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 2) (funcall fn 1 2 3) (funcall fn 'a) (funcall fn 'a 'b) (funcall fn 'a 'b 'c))) (1 10 20) (1 2 20) (1 2 3) (t s a) (t b a) (c b a)) (deftest defgeneric.10 (let ((fn (eval '(defgeneric defgeneric.fun.10 (x &rest y) (:method ((x number) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (defgeneric.fun.10 5/3 :foo 'x :foo 'y) (defgeneric.fun.10 10 :bar t :allow-other-keys t) (defgeneric.fun.10 20 :allow-other-keys nil :foo 'x))) (1 nil) (1 a) (5/3 x) (10 nil) (20 x)) (deftest defgeneric.11 (let ((fn (eval '(defgeneric defgeneric.fun.11 (x &key) (:method ((x number) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (defgeneric.fun.11 5/3 :foo 'x :foo 'y) (defgeneric.fun.11 11 :bar t :allow-other-keys t) (defgeneric.fun.11 20 :allow-other-keys nil :foo 'x))) (1 nil) (1 a) (5/3 x) (11 nil) (20 x)) (deftest defgeneric.12 (let ((fn (eval '(defgeneric defgeneric.fun.12 (x &key foo bar baz) (:method ((x number) &rest y) (list x y)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (defgeneric.fun.12 5/3 :foo 'x :foo 'y :bar 'z) (defgeneric.fun.12 11 :zzz t :allow-other-keys t) (defgeneric.fun.12 20 :allow-other-keys nil :foo 'x))) (1 nil) (1 (:foo a)) (5/3 (:foo x :foo y :bar z)) (11 (:zzz t :allow-other-keys t)) (20 (:allow-other-keys nil :foo x))) (deftest defgeneric.13 (let ((fn (eval '(defgeneric defgeneric.fun.13 (x &key) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) (funcall fn 1 :foo 2) ;; (funcall fn 1 :foo 2 :bar 3) ;; (funcall fn 1 :bar 4) ;; (funcall fn 'a :foo 'b) (funcall fn 'a :bar 'b) ;; (funcall fn 'a :foo 'c :bar 'b) )) (1 nil) (a nil) (1 2) ;; (1 2) ;; (1 nil) ;; (a nil) (a b) ;; (a b) ) (deftest defgeneric.14 (let ((fn (eval '(defgeneric defgeneric.fun.14 (x &key &allow-other-keys) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) (funcall fn 1 :foo 2) (funcall fn 1 :foo 2 :bar 3) (funcall fn 1 :bar 4) (funcall fn 'a :foo 'b) (funcall fn 'a :bar 'b) (funcall fn 'a :foo 'c :bar 'b) (funcall fn 1 :baz 10) (funcall fn 'a :baz 10) (funcall fn 1 :allow-other-keys nil :baz 'a) (funcall fn 'a :allow-other-keys nil :baz 'b) )) (1 nil) (a nil) (1 2) (1 2) (1 nil) (a nil) (a b) (a b) (1 nil) (a nil) (1 nil) (a nil)) (deftest defgeneric.15 (let ((fn (eval '(defgeneric defgeneric.fun.15 (x &key) (:method ((x number) &key foo &allow-other-keys) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) (funcall fn 1 :foo 2) (funcall fn 1 :foo 2 :bar 3) (funcall fn 1 :bar 4) (funcall fn 'a :allow-other-keys t :foo 'b) (funcall fn 'a :bar 'b) (funcall fn 'a :foo 'c :bar 'b :allow-other-keys t) (funcall fn 1 :baz 10) ;; (funcall fn 'a :baz 10) (funcall fn 1 :allow-other-keys nil :baz 'a) ;; (funcall fn 'a :allow-other-keys nil :baz 'b) )) (1 nil) (a nil) (1 2) (1 2) (1 nil) (a nil) (a b) (a b) (1 nil) ;; (a nil) (1 nil) ;; (a nil) ) (deftest defgeneric.16 (let ((fn (eval '(defgeneric defgeneric.fun.16 (x &key) (:method ((x number) &key (foo 'a)) (list x foo)) (:method ((x symbol) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo nil) (funcall fn 1 :foo 2) (funcall fn 'x) (funcall fn 'x :foo nil) (funcall fn 'x :foo 'y))) (1 a) (1 nil) (1 2) (x nil) (x nil) (x y)) (deftest defgeneric.17 (let ((fn (eval '(defgeneric defgeneric.fun.17 (x &key) (:method ((x number) &key (foo 'a foo-p)) (list x foo (notnot foo-p))) (:method ((x symbol) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo nil) (funcall fn 1 :foo 2) (funcall fn 'x) (funcall fn 'x :foo nil) (funcall fn 'x :foo 'y))) (1 a nil) (1 nil t) (1 2 t) (x nil) (x nil) (x y)) (deftest defgeneric.18 (let ((fn (eval '(defgeneric defgeneric.fun.18 (x &optional y) (:method ((x number) &optional (y 'a)) (list x y)) (:method ((x symbol) &optional (z nil z-p)) (list x z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 nil) (funcall fn 1 2) (funcall fn 'x) (funcall fn 'x nil) (funcall fn 'x 'y))) (1 a) (1 nil) (1 2) (x nil nil) (x nil t) (x y t)) (deftest defgeneric.19 (let ((fn (eval '(defgeneric defgeneric.fun.19 (x &key) (:method ((x number) &key ((:bar foo) 'a foo-p)) (list x foo (notnot foo-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :bar nil) (funcall fn 1 :bar 2))) (1 a nil) (1 nil t) (1 2 t)) (deftest defgeneric.20 (let ((fn (eval '(defgeneric defgeneric.fun.20 (x &optional y z) (:method ((x number) &optional (y (1+ x) y-p) (z (if y-p (1+ y) (+ x 10)) z-p)) (list x y (notnot y-p) z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 5) (funcall fn 1 5 9))) (1 2 nil 11 nil) (1 5 t 6 nil) (1 5 t 9 t)) (deftest defgeneric.21 (let ((fn (eval '(defgeneric defgeneric.fun.21 (x &key) (:method ((x number) &key (y (1+ x) y-p) (z (if y-p (1+ y) (+ x 10)) z-p)) (list x y (notnot y-p) z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :y 5) (funcall fn 1 :y 5 :z 9) (funcall fn 1 :z 8) (funcall fn 1 :z 8 :y 4))) (1 2 nil 11 nil) (1 5 t 6 nil) (1 5 t 9 t) (1 2 nil 8 t) (1 4 t 8 t)) (deftest defgeneric.22 (let ((fn (eval '(defgeneric defgeneric.fun.22 (x &key) (:method ((x number) &key ((:allow-other-keys y))) (list x y)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :allow-other-keys nil) (funcall fn 1 :allow-other-keys t) (funcall fn 1 :foo 'x :allow-other-keys t :bar 'y) (funcall fn 1 :allow-other-keys t :foo 'x) (funcall fn 1 :allow-other-keys nil :allow-other-keys t) (funcall fn 1 :foo 'x :allow-other-keys t :allow-other-keys nil) (funcall fn 1 :allow-other-keys t 'foo 'y :allow-other-keys nil) (funcall fn 1 :allow-other-keys t :allow-other-keys nil '#:foo 'z))) (1 nil) (1 nil) (1 t) (1 t) (1 t) (1 nil) (1 t) (1 t) (1 t)) (deftest defgeneric.23 (let ((fn (eval '(defgeneric defgeneric.fun.23 (x) (:method ((x number) &aux (y (1+ x))) (list x y)) (:method ((x symbol) &aux (z (list x))) (list x z)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a))) (1 2) (a (a))) (deftest defgeneric.24 (let ((fn (eval '(defgeneric defgeneric.fun.24 (x) (:method ((x number) &aux (y (1+ x)) (z (1+ y))) (list x y z)) (:method ((x symbol) &aux (y (list x)) (z (list x y))) (list x y z)))))) (values (funcall fn 1) (funcall fn 'a))) (1 2 3) (a (a) (a (a)))) (deftest defgeneric.25 (let ((fn (eval '(defgeneric defgeneric.fun.25 (x &optional y &key) (:method ((x symbol) &optional (y 'd y-p) &key ((:foo bar) (list x y) bar-p) &aux (z (list x y (notnot y-p) bar (notnot bar-p)))) z))))) (declare (type function fn)) (values (funcall fn 'a) (funcall fn 'a 'b) (funcall fn 'a 'b :foo 'c))) (a d nil (a d) nil) (a b t (a b) nil) (a b t c t)) (deftest defgeneric.26 (let ((fn (eval '(defgeneric defgeneric.fun.26 (x) (declare (optimize (safety 3))) (:method ((x symbol)) x) (declare (optimize (debug 3))))))) (declare (type function fn)) (funcall fn 'a)) a) #| (when (subtypep (class-of (find-class 'standard-method)) 'standard-class) (defclass substandard-method (standard-method) ()) (deftest defgeneric.27 (let ((fn (eval '(defgeneric defgeneric.fun.27 (x y) (:method-class substandard-method) (:method ((x number) (y number)) (+ x y)) (:method ((x string) (y string)) (concatenate 'string x y)))))) (declare (type function fn)) (values (funcall fn 1 2) (funcall fn "1" "2"))) 3 "12")) |# (deftest defgeneric.28 (let ((fn (eval '(defgeneric defgeneric.fun.28 (x &key) (:method ((x integer) &key foo) (list x foo)) (:method ((x number) &key bar) (list x bar)) (:method ((x t) &key baz) (list x baz)))))) (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) (funcall fn 1 :bar 'b) (funcall fn 1 :baz 'c) (funcall fn 1 :bar 'b :baz 'c) (funcall fn 1 :foo 'a :bar 'b) (funcall fn 1 :foo 'a :baz 'c) (funcall fn 1 :foo 'a :bar 'b :baz 'c) (funcall fn 5/3) (funcall fn 5/3 :bar 'b) (funcall fn 5/3 :baz 'c) (funcall fn 5/3 :bar 'b :baz 'c) (funcall fn 'x) (funcall fn 'x :baz 'c) )) (1 nil) (1 a) (1 nil) (1 nil) (1 nil) (1 a) (1 a) (1 a) (5/3 nil) (5/3 b) (5/3 nil) (5/3 b) (x nil) (x c)) (defclass defgeneric.29.class.1 () ()) (defclass defgeneric.29.class.2 () ()) (defclass defgeneric.29.class.3 (defgeneric.29.class.1 defgeneric.29.class.2) ()) (deftest defgeneric.29 (let ((fn (eval '(defgeneric defgeneric.fun.29 (x &key) (:method ((x defgeneric.29.class.1) &key foo) foo) (:method ((x defgeneric.29.class.2) &key bar) bar))))) (declare (type function fn)) (let ((x (make-instance 'defgeneric.29.class.3))) (values (funcall fn x) (funcall fn x :foo 'a) (funcall fn x :bar 'b) (funcall fn x :foo 'a :bar 'b) (funcall fn x :bar 'b :foo 'a)))) nil a nil a a) ;;; I'm not sure this one is proper ;;; Added :metaclass at prompting of Martin Simmons (when (subtypep (class-of (find-class 'standard-generic-function)) 'standard-class) (defclass substandard-generic-function (standard-generic-function) () (:metaclass #.(class-name (class-of (find-class 'standard-generic-function))))) (deftest defgeneric.30 (let ((fn (eval '(defgeneric defgeneric.fun.29 (x) (:generic-function-class substandard-generic-function) (:method ((x symbol)) 1) (:method ((x integer)) 2))))) (declare (type function fn)) (values (typep* fn 'substandard-generic-function) (typep* fn 'standard-generic-function) (typep* fn 'generic-function) (typep* fn 'function) (funcall fn 'a) (funcall fn 1) (defgeneric.fun.29 'x) (defgeneric.fun.29 12345678901234567890))) t t t t 1 2 1 2)) (deftest defgeneric.31 (progn (defgeneric defgeneric.fun.31 (x) (:method ((x t)) t)) (defgeneric defgeneric.fun.31 (x y) (:method ((x t) (y t)) (list x y))) (defgeneric.fun.31 'a 'b)) (a b)) (deftest defgeneric.32 (progn (defgeneric defgeneric.fun.32 (x) (:method ((x symbol)) :bad)) (defgeneric defgeneric.fun.32 (x) (:method ((x t)) :good)) (defgeneric.fun.32 'x)) :good) (deftest defgeneric.33 (let ((fn (eval '(defgeneric (setf defgeneric.fun.33) (x y &rest args) (:method (x (y cons) &rest args) (assert (null args)) (setf (car y) x)) (:method (x (y array) &rest args) (setf (apply #'aref y args) x)))))) (declare (type function fn)) (values (let ((z (list 'a 'b))) (list (setf (defgeneric.fun.33 z) 'c) z)) (let ((a (make-array '(10) :initial-element nil))) (list (setf (defgeneric.fun.33 a 5) 'd) a)))) (c (c b)) (d #(nil nil nil nil nil d nil nil nil nil))) (deftest defgeneric.34 (let ((fn (eval '(defgeneric #:defgeneric.fun.34 (x) (:method ((x t)) (list x :good)))))) (funcall fn 10)) (10 :good)) (deftest defgeneric.35 (let ((fn (eval '(defgeneric defgeneric.fun.35 (x) (:method ((x (eql 'a))) (declare (optimize (speed 0))) "FOO" (declare (optimize (safety 3))) x))))) (declare (type function fn)) (values (funcall fn 'a) (let ((method (first (compute-applicable-methods fn '(a))))) (and method (let ((doc (documentation method t))) (list (or (null doc) (equalt doc "FOO")) (setf (documentation method t) "BAR") (let ((doc (documentation method t))) (or (null doc) (equalt doc "BAR"))) )))))) a (t "BAR" t)) gcl-2.7.1/ansi-tests/PaxHeaders/load-arrays.lsp0000644000000000000000000000013214772071546016411 xustar0030 mtime=1743287142.046898455 30 atime=1744294960.481789135 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-arrays.lsp0000644000175000017500000000230014772071546016002 0ustar00cammcamm;;; 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 "adjust-array.lsp") (load "adjustable-array-p.lsp") (load "array-displacement.lsp") (load "array-dimension.lsp") (load "array-dimensions.lsp") (load "array-element-type.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.7.1/ansi-tests/PaxHeaders/roman-numerals.lsp0000644000000000000000000000013214542551763017132 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.481789135 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/roman-numerals.lsp0000644000175000017500000012610014542551763016530 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jul 29 08:44:15 2004 ;;;; Contains: The roman numbers from 1 to 3999 (in-package :cl-test) (defparameter *roman-numerals* '("I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX" "X" "XI" "XII" "XIII" "XIV" "XV" "XVI" "XVII" "XVIII" "XIX" "XX" "XXI" "XXII" "XXIII" "XXIV" "XXV" "XXVI" "XXVII" "XXVIII" "XXIX" "XXX" "XXXI" "XXXII" "XXXIII" "XXXIV" "XXXV" "XXXVI" "XXXVII" "XXXVIII" "XXXIX" "XL" "XLI" "XLII" "XLIII" "XLIV" "XLV" "XLVI" "XLVII" "XLVIII" "XLIX" "L" "LI" "LII" "LIII" "LIV" "LV" "LVI" "LVII" "LVIII" "LIX" "LX" "LXI" "LXII" "LXIII" "LXIV" "LXV" "LXVI" "LXVII" "LXVIII" "LXIX" "LXX" "LXXI" "LXXII" "LXXIII" "LXXIV" "LXXV" "LXXVI" "LXXVII" "LXXVIII" "LXXIX" "LXXX" "LXXXI" "LXXXII" "LXXXIII" "LXXXIV" "LXXXV" "LXXXVI" "LXXXVII" "LXXXVIII" "LXXXIX" "XC" "XCI" "XCII" "XCIII" "XCIV" "XCV" "XCVI" "XCVII" "XCVIII" "XCIX" "C" "CI" "CII" "CIII" "CIV" "CV" "CVI" "CVII" "CVIII" "CIX" "CX" "CXI" "CXII" "CXIII" "CXIV" "CXV" "CXVI" "CXVII" "CXVIII" "CXIX" "CXX" "CXXI" "CXXII" "CXXIII" "CXXIV" "CXXV" "CXXVI" "CXXVII" "CXXVIII" "CXXIX" "CXXX" "CXXXI" "CXXXII" "CXXXIII" "CXXXIV" "CXXXV" "CXXXVI" "CXXXVII" "CXXXVIII" "CXXXIX" "CXL" "CXLI" "CXLII" "CXLIII" "CXLIV" "CXLV" "CXLVI" "CXLVII" "CXLVIII" "CXLIX" "CL" "CLI" "CLII" "CLIII" "CLIV" "CLV" "CLVI" "CLVII" "CLVIII" "CLIX" "CLX" "CLXI" "CLXII" "CLXIII" "CLXIV" "CLXV" "CLXVI" "CLXVII" "CLXVIII" "CLXIX" "CLXX" "CLXXI" "CLXXII" "CLXXIII" "CLXXIV" "CLXXV" "CLXXVI" "CLXXVII" "CLXXVIII" "CLXXIX" "CLXXX" "CLXXXI" "CLXXXII" "CLXXXIII" "CLXXXIV" "CLXXXV" "CLXXXVI" "CLXXXVII" "CLXXXVIII" "CLXXXIX" "CXC" "CXCI" "CXCII" "CXCIII" "CXCIV" "CXCV" "CXCVI" "CXCVII" "CXCVIII" "CXCIX" "CC" "CCI" "CCII" "CCIII" "CCIV" "CCV" "CCVI" "CCVII" "CCVIII" "CCIX" "CCX" "CCXI" "CCXII" "CCXIII" "CCXIV" "CCXV" "CCXVI" "CCXVII" "CCXVIII" "CCXIX" "CCXX" "CCXXI" "CCXXII" "CCXXIII" "CCXXIV" "CCXXV" "CCXXVI" "CCXXVII" "CCXXVIII" "CCXXIX" "CCXXX" "CCXXXI" "CCXXXII" "CCXXXIII" "CCXXXIV" "CCXXXV" "CCXXXVI" "CCXXXVII" "CCXXXVIII" "CCXXXIX" "CCXL" "CCXLI" "CCXLII" "CCXLIII" "CCXLIV" "CCXLV" "CCXLVI" "CCXLVII" "CCXLVIII" "CCXLIX" "CCL" "CCLI" "CCLII" "CCLIII" "CCLIV" "CCLV" "CCLVI" "CCLVII" "CCLVIII" "CCLIX" "CCLX" "CCLXI" "CCLXII" "CCLXIII" "CCLXIV" "CCLXV" "CCLXVI" "CCLXVII" "CCLXVIII" "CCLXIX" "CCLXX" "CCLXXI" "CCLXXII" "CCLXXIII" "CCLXXIV" "CCLXXV" "CCLXXVI" "CCLXXVII" "CCLXXVIII" "CCLXXIX" "CCLXXX" "CCLXXXI" "CCLXXXII" "CCLXXXIII" "CCLXXXIV" "CCLXXXV" "CCLXXXVI" "CCLXXXVII" "CCLXXXVIII" "CCLXXXIX" "CCXC" "CCXCI" "CCXCII" "CCXCIII" "CCXCIV" "CCXCV" "CCXCVI" "CCXCVII" "CCXCVIII" "CCXCIX" "CCC" "CCCI" "CCCII" "CCCIII" "CCCIV" "CCCV" "CCCVI" "CCCVII" "CCCVIII" "CCCIX" "CCCX" "CCCXI" "CCCXII" "CCCXIII" "CCCXIV" "CCCXV" "CCCXVI" "CCCXVII" "CCCXVIII" "CCCXIX" "CCCXX" "CCCXXI" "CCCXXII" "CCCXXIII" "CCCXXIV" "CCCXXV" "CCCXXVI" "CCCXXVII" "CCCXXVIII" "CCCXXIX" "CCCXXX" "CCCXXXI" "CCCXXXII" "CCCXXXIII" "CCCXXXIV" "CCCXXXV" "CCCXXXVI" "CCCXXXVII" "CCCXXXVIII" "CCCXXXIX" "CCCXL" "CCCXLI" "CCCXLII" "CCCXLIII" "CCCXLIV" "CCCXLV" "CCCXLVI" "CCCXLVII" "CCCXLVIII" "CCCXLIX" "CCCL" "CCCLI" "CCCLII" "CCCLIII" "CCCLIV" "CCCLV" "CCCLVI" "CCCLVII" "CCCLVIII" "CCCLIX" "CCCLX" "CCCLXI" "CCCLXII" "CCCLXIII" "CCCLXIV" "CCCLXV" "CCCLXVI" "CCCLXVII" "CCCLXVIII" "CCCLXIX" "CCCLXX" "CCCLXXI" "CCCLXXII" "CCCLXXIII" "CCCLXXIV" "CCCLXXV" "CCCLXXVI" "CCCLXXVII" "CCCLXXVIII" "CCCLXXIX" "CCCLXXX" "CCCLXXXI" "CCCLXXXII" "CCCLXXXIII" "CCCLXXXIV" "CCCLXXXV" "CCCLXXXVI" "CCCLXXXVII" "CCCLXXXVIII" "CCCLXXXIX" "CCCXC" "CCCXCI" "CCCXCII" "CCCXCIII" "CCCXCIV" "CCCXCV" "CCCXCVI" "CCCXCVII" "CCCXCVIII" "CCCXCIX" "CD" "CDI" "CDII" "CDIII" "CDIV" "CDV" "CDVI" "CDVII" "CDVIII" "CDIX" "CDX" "CDXI" "CDXII" "CDXIII" "CDXIV" "CDXV" "CDXVI" "CDXVII" "CDXVIII" "CDXIX" "CDXX" "CDXXI" "CDXXII" "CDXXIII" "CDXXIV" "CDXXV" "CDXXVI" "CDXXVII" "CDXXVIII" "CDXXIX" "CDXXX" "CDXXXI" "CDXXXII" "CDXXXIII" "CDXXXIV" "CDXXXV" "CDXXXVI" "CDXXXVII" "CDXXXVIII" "CDXXXIX" "CDXL" "CDXLI" "CDXLII" "CDXLIII" "CDXLIV" "CDXLV" "CDXLVI" "CDXLVII" "CDXLVIII" "CDXLIX" "CDL" "CDLI" "CDLII" "CDLIII" "CDLIV" "CDLV" "CDLVI" "CDLVII" "CDLVIII" "CDLIX" "CDLX" "CDLXI" "CDLXII" "CDLXIII" "CDLXIV" "CDLXV" "CDLXVI" "CDLXVII" "CDLXVIII" "CDLXIX" "CDLXX" "CDLXXI" "CDLXXII" "CDLXXIII" "CDLXXIV" "CDLXXV" "CDLXXVI" "CDLXXVII" "CDLXXVIII" "CDLXXIX" "CDLXXX" "CDLXXXI" "CDLXXXII" "CDLXXXIII" "CDLXXXIV" "CDLXXXV" "CDLXXXVI" "CDLXXXVII" "CDLXXXVIII" "CDLXXXIX" "CDXC" "CDXCI" "CDXCII" "CDXCIII" "CDXCIV" "CDXCV" "CDXCVI" "CDXCVII" "CDXCVIII" "CDXCIX" "D" "DI" "DII" "DIII" "DIV" "DV" "DVI" "DVII" "DVIII" "DIX" "DX" "DXI" "DXII" "DXIII" "DXIV" "DXV" "DXVI" "DXVII" "DXVIII" "DXIX" "DXX" "DXXI" "DXXII" "DXXIII" "DXXIV" "DXXV" "DXXVI" "DXXVII" "DXXVIII" "DXXIX" "DXXX" "DXXXI" "DXXXII" "DXXXIII" "DXXXIV" "DXXXV" "DXXXVI" "DXXXVII" "DXXXVIII" "DXXXIX" "DXL" "DXLI" "DXLII" "DXLIII" "DXLIV" "DXLV" "DXLVI" "DXLVII" "DXLVIII" "DXLIX" "DL" "DLI" "DLII" "DLIII" "DLIV" "DLV" "DLVI" "DLVII" "DLVIII" "DLIX" "DLX" "DLXI" "DLXII" "DLXIII" "DLXIV" "DLXV" "DLXVI" "DLXVII" "DLXVIII" "DLXIX" "DLXX" "DLXXI" "DLXXII" "DLXXIII" "DLXXIV" "DLXXV" "DLXXVI" "DLXXVII" "DLXXVIII" "DLXXIX" "DLXXX" "DLXXXI" "DLXXXII" "DLXXXIII" "DLXXXIV" "DLXXXV" "DLXXXVI" "DLXXXVII" "DLXXXVIII" "DLXXXIX" "DXC" "DXCI" "DXCII" "DXCIII" "DXCIV" "DXCV" "DXCVI" "DXCVII" "DXCVIII" "DXCIX" "DC" "DCI" "DCII" "DCIII" "DCIV" "DCV" "DCVI" "DCVII" "DCVIII" "DCIX" "DCX" "DCXI" "DCXII" "DCXIII" "DCXIV" "DCXV" "DCXVI" "DCXVII" "DCXVIII" "DCXIX" "DCXX" "DCXXI" "DCXXII" "DCXXIII" "DCXXIV" "DCXXV" "DCXXVI" "DCXXVII" "DCXXVIII" "DCXXIX" "DCXXX" "DCXXXI" "DCXXXII" "DCXXXIII" "DCXXXIV" "DCXXXV" "DCXXXVI" "DCXXXVII" "DCXXXVIII" "DCXXXIX" "DCXL" "DCXLI" "DCXLII" "DCXLIII" "DCXLIV" "DCXLV" "DCXLVI" "DCXLVII" "DCXLVIII" "DCXLIX" "DCL" "DCLI" "DCLII" "DCLIII" "DCLIV" "DCLV" "DCLVI" "DCLVII" "DCLVIII" "DCLIX" "DCLX" "DCLXI" "DCLXII" "DCLXIII" "DCLXIV" "DCLXV" "DCLXVI" "DCLXVII" "DCLXVIII" "DCLXIX" "DCLXX" "DCLXXI" "DCLXXII" "DCLXXIII" "DCLXXIV" "DCLXXV" "DCLXXVI" "DCLXXVII" "DCLXXVIII" "DCLXXIX" "DCLXXX" "DCLXXXI" "DCLXXXII" "DCLXXXIII" "DCLXXXIV" "DCLXXXV" "DCLXXXVI" "DCLXXXVII" "DCLXXXVIII" "DCLXXXIX" "DCXC" "DCXCI" "DCXCII" "DCXCIII" "DCXCIV" "DCXCV" "DCXCVI" "DCXCVII" "DCXCVIII" "DCXCIX" "DCC" "DCCI" "DCCII" "DCCIII" "DCCIV" "DCCV" "DCCVI" "DCCVII" "DCCVIII" "DCCIX" "DCCX" "DCCXI" "DCCXII" "DCCXIII" "DCCXIV" "DCCXV" "DCCXVI" "DCCXVII" "DCCXVIII" "DCCXIX" "DCCXX" "DCCXXI" "DCCXXII" "DCCXXIII" "DCCXXIV" "DCCXXV" "DCCXXVI" "DCCXXVII" "DCCXXVIII" "DCCXXIX" "DCCXXX" "DCCXXXI" "DCCXXXII" "DCCXXXIII" "DCCXXXIV" "DCCXXXV" "DCCXXXVI" "DCCXXXVII" "DCCXXXVIII" "DCCXXXIX" "DCCXL" "DCCXLI" "DCCXLII" "DCCXLIII" "DCCXLIV" "DCCXLV" "DCCXLVI" "DCCXLVII" "DCCXLVIII" "DCCXLIX" "DCCL" "DCCLI" "DCCLII" "DCCLIII" "DCCLIV" "DCCLV" "DCCLVI" "DCCLVII" "DCCLVIII" "DCCLIX" "DCCLX" "DCCLXI" "DCCLXII" "DCCLXIII" "DCCLXIV" "DCCLXV" "DCCLXVI" "DCCLXVII" "DCCLXVIII" "DCCLXIX" "DCCLXX" "DCCLXXI" "DCCLXXII" "DCCLXXIII" "DCCLXXIV" "DCCLXXV" "DCCLXXVI" "DCCLXXVII" "DCCLXXVIII" "DCCLXXIX" "DCCLXXX" "DCCLXXXI" "DCCLXXXII" "DCCLXXXIII" "DCCLXXXIV" "DCCLXXXV" "DCCLXXXVI" "DCCLXXXVII" "DCCLXXXVIII" "DCCLXXXIX" "DCCXC" "DCCXCI" "DCCXCII" "DCCXCIII" "DCCXCIV" "DCCXCV" "DCCXCVI" "DCCXCVII" "DCCXCVIII" "DCCXCIX" "DCCC" "DCCCI" "DCCCII" "DCCCIII" "DCCCIV" "DCCCV" "DCCCVI" "DCCCVII" "DCCCVIII" "DCCCIX" "DCCCX" "DCCCXI" "DCCCXII" "DCCCXIII" "DCCCXIV" "DCCCXV" "DCCCXVI" "DCCCXVII" "DCCCXVIII" "DCCCXIX" "DCCCXX" "DCCCXXI" "DCCCXXII" "DCCCXXIII" "DCCCXXIV" "DCCCXXV" "DCCCXXVI" "DCCCXXVII" "DCCCXXVIII" "DCCCXXIX" "DCCCXXX" "DCCCXXXI" "DCCCXXXII" "DCCCXXXIII" "DCCCXXXIV" "DCCCXXXV" "DCCCXXXVI" "DCCCXXXVII" "DCCCXXXVIII" "DCCCXXXIX" "DCCCXL" "DCCCXLI" "DCCCXLII" "DCCCXLIII" "DCCCXLIV" "DCCCXLV" "DCCCXLVI" "DCCCXLVII" "DCCCXLVIII" "DCCCXLIX" "DCCCL" "DCCCLI" "DCCCLII" "DCCCLIII" "DCCCLIV" "DCCCLV" "DCCCLVI" "DCCCLVII" "DCCCLVIII" "DCCCLIX" "DCCCLX" "DCCCLXI" "DCCCLXII" "DCCCLXIII" "DCCCLXIV" "DCCCLXV" "DCCCLXVI" "DCCCLXVII" "DCCCLXVIII" "DCCCLXIX" "DCCCLXX" "DCCCLXXI" "DCCCLXXII" "DCCCLXXIII" "DCCCLXXIV" "DCCCLXXV" "DCCCLXXVI" "DCCCLXXVII" "DCCCLXXVIII" "DCCCLXXIX" "DCCCLXXX" "DCCCLXXXI" "DCCCLXXXII" "DCCCLXXXIII" "DCCCLXXXIV" "DCCCLXXXV" "DCCCLXXXVI" "DCCCLXXXVII" "DCCCLXXXVIII" "DCCCLXXXIX" "DCCCXC" "DCCCXCI" "DCCCXCII" "DCCCXCIII" "DCCCXCIV" "DCCCXCV" "DCCCXCVI" "DCCCXCVII" "DCCCXCVIII" "DCCCXCIX" "CM" "CMI" "CMII" "CMIII" "CMIV" "CMV" "CMVI" "CMVII" "CMVIII" "CMIX" "CMX" "CMXI" "CMXII" "CMXIII" "CMXIV" "CMXV" "CMXVI" "CMXVII" "CMXVIII" "CMXIX" "CMXX" "CMXXI" "CMXXII" "CMXXIII" "CMXXIV" "CMXXV" "CMXXVI" "CMXXVII" "CMXXVIII" "CMXXIX" "CMXXX" "CMXXXI" "CMXXXII" "CMXXXIII" "CMXXXIV" "CMXXXV" "CMXXXVI" "CMXXXVII" "CMXXXVIII" "CMXXXIX" "CMXL" "CMXLI" "CMXLII" "CMXLIII" "CMXLIV" "CMXLV" "CMXLVI" "CMXLVII" "CMXLVIII" "CMXLIX" "CML" "CMLI" "CMLII" "CMLIII" "CMLIV" "CMLV" "CMLVI" "CMLVII" "CMLVIII" "CMLIX" "CMLX" "CMLXI" "CMLXII" "CMLXIII" "CMLXIV" "CMLXV" "CMLXVI" "CMLXVII" "CMLXVIII" "CMLXIX" "CMLXX" "CMLXXI" "CMLXXII" "CMLXXIII" "CMLXXIV" "CMLXXV" "CMLXXVI" "CMLXXVII" "CMLXXVIII" "CMLXXIX" "CMLXXX" "CMLXXXI" "CMLXXXII" "CMLXXXIII" "CMLXXXIV" "CMLXXXV" "CMLXXXVI" "CMLXXXVII" "CMLXXXVIII" "CMLXXXIX" "CMXC" "CMXCI" "CMXCII" "CMXCIII" "CMXCIV" "CMXCV" "CMXCVI" "CMXCVII" "CMXCVIII" "CMXCIX" "M" "MI" "MII" "MIII" "MIV" "MV" "MVI" "MVII" "MVIII" "MIX" "MX" "MXI" "MXII" "MXIII" "MXIV" "MXV" "MXVI" "MXVII" "MXVIII" "MXIX" "MXX" "MXXI" "MXXII" "MXXIII" "MXXIV" "MXXV" "MXXVI" "MXXVII" "MXXVIII" "MXXIX" "MXXX" "MXXXI" "MXXXII" "MXXXIII" "MXXXIV" "MXXXV" "MXXXVI" "MXXXVII" "MXXXVIII" "MXXXIX" "MXL" "MXLI" "MXLII" "MXLIII" "MXLIV" "MXLV" "MXLVI" "MXLVII" "MXLVIII" "MXLIX" "ML" "MLI" "MLII" "MLIII" "MLIV" "MLV" "MLVI" "MLVII" "MLVIII" "MLIX" "MLX" "MLXI" "MLXII" "MLXIII" "MLXIV" "MLXV" "MLXVI" "MLXVII" "MLXVIII" "MLXIX" "MLXX" "MLXXI" "MLXXII" "MLXXIII" "MLXXIV" "MLXXV" "MLXXVI" "MLXXVII" "MLXXVIII" "MLXXIX" "MLXXX" "MLXXXI" "MLXXXII" "MLXXXIII" "MLXXXIV" "MLXXXV" "MLXXXVI" "MLXXXVII" "MLXXXVIII" "MLXXXIX" "MXC" "MXCI" "MXCII" "MXCIII" "MXCIV" "MXCV" "MXCVI" "MXCVII" "MXCVIII" "MXCIX" "MC" "MCI" "MCII" "MCIII" "MCIV" "MCV" "MCVI" "MCVII" "MCVIII" "MCIX" "MCX" "MCXI" "MCXII" "MCXIII" "MCXIV" "MCXV" "MCXVI" "MCXVII" "MCXVIII" "MCXIX" "MCXX" "MCXXI" "MCXXII" "MCXXIII" "MCXXIV" "MCXXV" "MCXXVI" "MCXXVII" "MCXXVIII" "MCXXIX" "MCXXX" "MCXXXI" "MCXXXII" "MCXXXIII" "MCXXXIV" "MCXXXV" "MCXXXVI" "MCXXXVII" "MCXXXVIII" "MCXXXIX" "MCXL" "MCXLI" "MCXLII" "MCXLIII" "MCXLIV" "MCXLV" "MCXLVI" "MCXLVII" "MCXLVIII" "MCXLIX" "MCL" "MCLI" "MCLII" "MCLIII" "MCLIV" "MCLV" "MCLVI" "MCLVII" "MCLVIII" "MCLIX" "MCLX" "MCLXI" "MCLXII" "MCLXIII" "MCLXIV" "MCLXV" "MCLXVI" "MCLXVII" "MCLXVIII" "MCLXIX" "MCLXX" "MCLXXI" "MCLXXII" "MCLXXIII" "MCLXXIV" "MCLXXV" "MCLXXVI" "MCLXXVII" "MCLXXVIII" "MCLXXIX" "MCLXXX" "MCLXXXI" "MCLXXXII" "MCLXXXIII" "MCLXXXIV" "MCLXXXV" "MCLXXXVI" "MCLXXXVII" "MCLXXXVIII" "MCLXXXIX" "MCXC" "MCXCI" "MCXCII" "MCXCIII" "MCXCIV" "MCXCV" "MCXCVI" "MCXCVII" "MCXCVIII" "MCXCIX" "MCC" "MCCI" "MCCII" "MCCIII" "MCCIV" "MCCV" "MCCVI" "MCCVII" "MCCVIII" "MCCIX" "MCCX" "MCCXI" "MCCXII" "MCCXIII" "MCCXIV" "MCCXV" "MCCXVI" "MCCXVII" "MCCXVIII" "MCCXIX" "MCCXX" "MCCXXI" "MCCXXII" "MCCXXIII" "MCCXXIV" "MCCXXV" "MCCXXVI" "MCCXXVII" "MCCXXVIII" "MCCXXIX" "MCCXXX" "MCCXXXI" "MCCXXXII" "MCCXXXIII" "MCCXXXIV" "MCCXXXV" "MCCXXXVI" "MCCXXXVII" "MCCXXXVIII" "MCCXXXIX" "MCCXL" "MCCXLI" "MCCXLII" "MCCXLIII" "MCCXLIV" "MCCXLV" "MCCXLVI" "MCCXLVII" "MCCXLVIII" "MCCXLIX" "MCCL" "MCCLI" "MCCLII" "MCCLIII" "MCCLIV" "MCCLV" "MCCLVI" "MCCLVII" "MCCLVIII" "MCCLIX" "MCCLX" "MCCLXI" "MCCLXII" "MCCLXIII" "MCCLXIV" "MCCLXV" "MCCLXVI" "MCCLXVII" "MCCLXVIII" "MCCLXIX" "MCCLXX" "MCCLXXI" "MCCLXXII" "MCCLXXIII" "MCCLXXIV" "MCCLXXV" "MCCLXXVI" "MCCLXXVII" "MCCLXXVIII" "MCCLXXIX" "MCCLXXX" "MCCLXXXI" "MCCLXXXII" "MCCLXXXIII" "MCCLXXXIV" "MCCLXXXV" "MCCLXXXVI" "MCCLXXXVII" "MCCLXXXVIII" "MCCLXXXIX" "MCCXC" "MCCXCI" "MCCXCII" "MCCXCIII" "MCCXCIV" "MCCXCV" "MCCXCVI" "MCCXCVII" "MCCXCVIII" "MCCXCIX" "MCCC" "MCCCI" "MCCCII" "MCCCIII" "MCCCIV" "MCCCV" "MCCCVI" "MCCCVII" "MCCCVIII" "MCCCIX" "MCCCX" "MCCCXI" "MCCCXII" "MCCCXIII" "MCCCXIV" "MCCCXV" "MCCCXVI" "MCCCXVII" "MCCCXVIII" "MCCCXIX" "MCCCXX" "MCCCXXI" "MCCCXXII" "MCCCXXIII" "MCCCXXIV" "MCCCXXV" "MCCCXXVI" "MCCCXXVII" "MCCCXXVIII" "MCCCXXIX" "MCCCXXX" "MCCCXXXI" "MCCCXXXII" "MCCCXXXIII" "MCCCXXXIV" "MCCCXXXV" "MCCCXXXVI" "MCCCXXXVII" "MCCCXXXVIII" "MCCCXXXIX" "MCCCXL" "MCCCXLI" "MCCCXLII" "MCCCXLIII" "MCCCXLIV" "MCCCXLV" "MCCCXLVI" "MCCCXLVII" "MCCCXLVIII" "MCCCXLIX" "MCCCL" "MCCCLI" "MCCCLII" "MCCCLIII" "MCCCLIV" "MCCCLV" "MCCCLVI" "MCCCLVII" "MCCCLVIII" "MCCCLIX" "MCCCLX" "MCCCLXI" "MCCCLXII" "MCCCLXIII" "MCCCLXIV" "MCCCLXV" "MCCCLXVI" "MCCCLXVII" "MCCCLXVIII" "MCCCLXIX" "MCCCLXX" "MCCCLXXI" "MCCCLXXII" "MCCCLXXIII" "MCCCLXXIV" "MCCCLXXV" "MCCCLXXVI" "MCCCLXXVII" "MCCCLXXVIII" "MCCCLXXIX" "MCCCLXXX" "MCCCLXXXI" "MCCCLXXXII" "MCCCLXXXIII" "MCCCLXXXIV" "MCCCLXXXV" "MCCCLXXXVI" "MCCCLXXXVII" "MCCCLXXXVIII" "MCCCLXXXIX" "MCCCXC" "MCCCXCI" "MCCCXCII" "MCCCXCIII" "MCCCXCIV" "MCCCXCV" "MCCCXCVI" "MCCCXCVII" "MCCCXCVIII" "MCCCXCIX" "MCD" "MCDI" "MCDII" "MCDIII" "MCDIV" "MCDV" "MCDVI" "MCDVII" "MCDVIII" "MCDIX" "MCDX" "MCDXI" "MCDXII" "MCDXIII" "MCDXIV" "MCDXV" "MCDXVI" "MCDXVII" "MCDXVIII" "MCDXIX" "MCDXX" "MCDXXI" "MCDXXII" "MCDXXIII" "MCDXXIV" "MCDXXV" "MCDXXVI" "MCDXXVII" "MCDXXVIII" "MCDXXIX" "MCDXXX" "MCDXXXI" "MCDXXXII" "MCDXXXIII" "MCDXXXIV" "MCDXXXV" "MCDXXXVI" "MCDXXXVII" "MCDXXXVIII" "MCDXXXIX" "MCDXL" "MCDXLI" "MCDXLII" "MCDXLIII" "MCDXLIV" "MCDXLV" "MCDXLVI" "MCDXLVII" "MCDXLVIII" "MCDXLIX" "MCDL" "MCDLI" "MCDLII" "MCDLIII" "MCDLIV" "MCDLV" "MCDLVI" "MCDLVII" "MCDLVIII" "MCDLIX" "MCDLX" "MCDLXI" "MCDLXII" "MCDLXIII" "MCDLXIV" "MCDLXV" "MCDLXVI" "MCDLXVII" "MCDLXVIII" "MCDLXIX" "MCDLXX" "MCDLXXI" "MCDLXXII" "MCDLXXIII" "MCDLXXIV" "MCDLXXV" "MCDLXXVI" "MCDLXXVII" "MCDLXXVIII" "MCDLXXIX" "MCDLXXX" "MCDLXXXI" "MCDLXXXII" "MCDLXXXIII" "MCDLXXXIV" "MCDLXXXV" "MCDLXXXVI" "MCDLXXXVII" "MCDLXXXVIII" "MCDLXXXIX" "MCDXC" "MCDXCI" "MCDXCII" "MCDXCIII" "MCDXCIV" "MCDXCV" "MCDXCVI" "MCDXCVII" "MCDXCVIII" "MCDXCIX" "MD" "MDI" "MDII" "MDIII" "MDIV" "MDV" "MDVI" "MDVII" "MDVIII" "MDIX" "MDX" "MDXI" "MDXII" "MDXIII" "MDXIV" "MDXV" "MDXVI" "MDXVII" "MDXVIII" "MDXIX" "MDXX" "MDXXI" "MDXXII" "MDXXIII" "MDXXIV" "MDXXV" "MDXXVI" "MDXXVII" "MDXXVIII" "MDXXIX" "MDXXX" "MDXXXI" "MDXXXII" "MDXXXIII" "MDXXXIV" "MDXXXV" "MDXXXVI" "MDXXXVII" "MDXXXVIII" "MDXXXIX" "MDXL" "MDXLI" "MDXLII" "MDXLIII" "MDXLIV" "MDXLV" "MDXLVI" "MDXLVII" "MDXLVIII" "MDXLIX" "MDL" "MDLI" "MDLII" "MDLIII" "MDLIV" "MDLV" "MDLVI" "MDLVII" "MDLVIII" "MDLIX" "MDLX" "MDLXI" "MDLXII" "MDLXIII" "MDLXIV" "MDLXV" "MDLXVI" "MDLXVII" "MDLXVIII" "MDLXIX" "MDLXX" "MDLXXI" "MDLXXII" "MDLXXIII" "MDLXXIV" "MDLXXV" "MDLXXVI" "MDLXXVII" "MDLXXVIII" "MDLXXIX" "MDLXXX" "MDLXXXI" "MDLXXXII" "MDLXXXIII" "MDLXXXIV" "MDLXXXV" "MDLXXXVI" "MDLXXXVII" "MDLXXXVIII" "MDLXXXIX" "MDXC" "MDXCI" "MDXCII" "MDXCIII" "MDXCIV" "MDXCV" "MDXCVI" "MDXCVII" "MDXCVIII" "MDXCIX" "MDC" "MDCI" "MDCII" "MDCIII" "MDCIV" "MDCV" "MDCVI" "MDCVII" "MDCVIII" "MDCIX" "MDCX" "MDCXI" "MDCXII" "MDCXIII" "MDCXIV" "MDCXV" "MDCXVI" "MDCXVII" "MDCXVIII" "MDCXIX" "MDCXX" "MDCXXI" "MDCXXII" "MDCXXIII" "MDCXXIV" "MDCXXV" "MDCXXVI" "MDCXXVII" "MDCXXVIII" "MDCXXIX" "MDCXXX" "MDCXXXI" "MDCXXXII" "MDCXXXIII" "MDCXXXIV" "MDCXXXV" "MDCXXXVI" "MDCXXXVII" "MDCXXXVIII" "MDCXXXIX" "MDCXL" "MDCXLI" "MDCXLII" "MDCXLIII" "MDCXLIV" "MDCXLV" "MDCXLVI" "MDCXLVII" "MDCXLVIII" "MDCXLIX" "MDCL" "MDCLI" "MDCLII" "MDCLIII" "MDCLIV" "MDCLV" "MDCLVI" "MDCLVII" "MDCLVIII" "MDCLIX" "MDCLX" "MDCLXI" "MDCLXII" "MDCLXIII" "MDCLXIV" "MDCLXV" "MDCLXVI" "MDCLXVII" "MDCLXVIII" "MDCLXIX" "MDCLXX" "MDCLXXI" "MDCLXXII" "MDCLXXIII" "MDCLXXIV" "MDCLXXV" "MDCLXXVI" "MDCLXXVII" "MDCLXXVIII" "MDCLXXIX" "MDCLXXX" "MDCLXXXI" "MDCLXXXII" "MDCLXXXIII" "MDCLXXXIV" "MDCLXXXV" "MDCLXXXVI" "MDCLXXXVII" "MDCLXXXVIII" "MDCLXXXIX" "MDCXC" "MDCXCI" "MDCXCII" "MDCXCIII" "MDCXCIV" "MDCXCV" "MDCXCVI" "MDCXCVII" "MDCXCVIII" "MDCXCIX" "MDCC" "MDCCI" "MDCCII" "MDCCIII" "MDCCIV" "MDCCV" "MDCCVI" "MDCCVII" "MDCCVIII" "MDCCIX" "MDCCX" "MDCCXI" "MDCCXII" "MDCCXIII" "MDCCXIV" "MDCCXV" "MDCCXVI" "MDCCXVII" "MDCCXVIII" "MDCCXIX" "MDCCXX" "MDCCXXI" "MDCCXXII" "MDCCXXIII" "MDCCXXIV" "MDCCXXV" "MDCCXXVI" "MDCCXXVII" "MDCCXXVIII" "MDCCXXIX" "MDCCXXX" "MDCCXXXI" "MDCCXXXII" "MDCCXXXIII" "MDCCXXXIV" "MDCCXXXV" "MDCCXXXVI" "MDCCXXXVII" "MDCCXXXVIII" "MDCCXXXIX" "MDCCXL" "MDCCXLI" "MDCCXLII" "MDCCXLIII" "MDCCXLIV" "MDCCXLV" "MDCCXLVI" "MDCCXLVII" "MDCCXLVIII" "MDCCXLIX" "MDCCL" "MDCCLI" "MDCCLII" "MDCCLIII" "MDCCLIV" "MDCCLV" "MDCCLVI" "MDCCLVII" "MDCCLVIII" "MDCCLIX" "MDCCLX" "MDCCLXI" "MDCCLXII" "MDCCLXIII" "MDCCLXIV" "MDCCLXV" "MDCCLXVI" "MDCCLXVII" "MDCCLXVIII" "MDCCLXIX" "MDCCLXX" "MDCCLXXI" "MDCCLXXII" "MDCCLXXIII" "MDCCLXXIV" "MDCCLXXV" "MDCCLXXVI" "MDCCLXXVII" "MDCCLXXVIII" "MDCCLXXIX" "MDCCLXXX" "MDCCLXXXI" "MDCCLXXXII" "MDCCLXXXIII" "MDCCLXXXIV" "MDCCLXXXV" "MDCCLXXXVI" "MDCCLXXXVII" "MDCCLXXXVIII" "MDCCLXXXIX" "MDCCXC" "MDCCXCI" "MDCCXCII" "MDCCXCIII" "MDCCXCIV" "MDCCXCV" "MDCCXCVI" "MDCCXCVII" "MDCCXCVIII" "MDCCXCIX" "MDCCC" "MDCCCI" "MDCCCII" "MDCCCIII" "MDCCCIV" "MDCCCV" "MDCCCVI" "MDCCCVII" "MDCCCVIII" "MDCCCIX" "MDCCCX" "MDCCCXI" "MDCCCXII" "MDCCCXIII" "MDCCCXIV" "MDCCCXV" "MDCCCXVI" "MDCCCXVII" "MDCCCXVIII" "MDCCCXIX" "MDCCCXX" "MDCCCXXI" "MDCCCXXII" "MDCCCXXIII" "MDCCCXXIV" "MDCCCXXV" "MDCCCXXVI" "MDCCCXXVII" "MDCCCXXVIII" "MDCCCXXIX" "MDCCCXXX" "MDCCCXXXI" "MDCCCXXXII" "MDCCCXXXIII" "MDCCCXXXIV" "MDCCCXXXV" "MDCCCXXXVI" "MDCCCXXXVII" "MDCCCXXXVIII" "MDCCCXXXIX" "MDCCCXL" "MDCCCXLI" "MDCCCXLII" "MDCCCXLIII" "MDCCCXLIV" "MDCCCXLV" "MDCCCXLVI" "MDCCCXLVII" "MDCCCXLVIII" "MDCCCXLIX" "MDCCCL" "MDCCCLI" "MDCCCLII" "MDCCCLIII" "MDCCCLIV" "MDCCCLV" "MDCCCLVI" "MDCCCLVII" "MDCCCLVIII" "MDCCCLIX" "MDCCCLX" "MDCCCLXI" "MDCCCLXII" "MDCCCLXIII" "MDCCCLXIV" "MDCCCLXV" "MDCCCLXVI" "MDCCCLXVII" "MDCCCLXVIII" "MDCCCLXIX" "MDCCCLXX" "MDCCCLXXI" "MDCCCLXXII" "MDCCCLXXIII" "MDCCCLXXIV" "MDCCCLXXV" "MDCCCLXXVI" "MDCCCLXXVII" "MDCCCLXXVIII" "MDCCCLXXIX" "MDCCCLXXX" "MDCCCLXXXI" "MDCCCLXXXII" "MDCCCLXXXIII" "MDCCCLXXXIV" "MDCCCLXXXV" "MDCCCLXXXVI" "MDCCCLXXXVII" "MDCCCLXXXVIII" "MDCCCLXXXIX" "MDCCCXC" "MDCCCXCI" "MDCCCXCII" "MDCCCXCIII" "MDCCCXCIV" "MDCCCXCV" "MDCCCXCVI" "MDCCCXCVII" "MDCCCXCVIII" "MDCCCXCIX" "MCM" "MCMI" "MCMII" "MCMIII" "MCMIV" "MCMV" "MCMVI" "MCMVII" "MCMVIII" "MCMIX" "MCMX" "MCMXI" "MCMXII" "MCMXIII" "MCMXIV" "MCMXV" "MCMXVI" "MCMXVII" "MCMXVIII" "MCMXIX" "MCMXX" "MCMXXI" "MCMXXII" "MCMXXIII" "MCMXXIV" "MCMXXV" "MCMXXVI" "MCMXXVII" "MCMXXVIII" "MCMXXIX" "MCMXXX" "MCMXXXI" "MCMXXXII" "MCMXXXIII" "MCMXXXIV" "MCMXXXV" "MCMXXXVI" "MCMXXXVII" "MCMXXXVIII" "MCMXXXIX" "MCMXL" "MCMXLI" "MCMXLII" "MCMXLIII" "MCMXLIV" "MCMXLV" "MCMXLVI" "MCMXLVII" "MCMXLVIII" "MCMXLIX" "MCML" "MCMLI" "MCMLII" "MCMLIII" "MCMLIV" "MCMLV" "MCMLVI" "MCMLVII" "MCMLVIII" "MCMLIX" "MCMLX" "MCMLXI" "MCMLXII" "MCMLXIII" "MCMLXIV" "MCMLXV" "MCMLXVI" "MCMLXVII" "MCMLXVIII" "MCMLXIX" "MCMLXX" "MCMLXXI" "MCMLXXII" "MCMLXXIII" "MCMLXXIV" "MCMLXXV" "MCMLXXVI" "MCMLXXVII" "MCMLXXVIII" "MCMLXXIX" "MCMLXXX" "MCMLXXXI" "MCMLXXXII" "MCMLXXXIII" "MCMLXXXIV" "MCMLXXXV" "MCMLXXXVI" "MCMLXXXVII" "MCMLXXXVIII" "MCMLXXXIX" "MCMXC" "MCMXCI" "MCMXCII" "MCMXCIII" "MCMXCIV" "MCMXCV" "MCMXCVI" "MCMXCVII" "MCMXCVIII" "MCMXCIX" "MM" "MMI" "MMII" "MMIII" "MMIV" "MMV" "MMVI" "MMVII" "MMVIII" "MMIX" "MMX" "MMXI" "MMXII" "MMXIII" "MMXIV" "MMXV" "MMXVI" "MMXVII" "MMXVIII" "MMXIX" "MMXX" "MMXXI" "MMXXII" "MMXXIII" "MMXXIV" "MMXXV" "MMXXVI" "MMXXVII" "MMXXVIII" "MMXXIX" "MMXXX" "MMXXXI" "MMXXXII" "MMXXXIII" "MMXXXIV" "MMXXXV" "MMXXXVI" "MMXXXVII" "MMXXXVIII" "MMXXXIX" "MMXL" "MMXLI" "MMXLII" "MMXLIII" "MMXLIV" "MMXLV" "MMXLVI" "MMXLVII" "MMXLVIII" "MMXLIX" "MML" "MMLI" "MMLII" "MMLIII" "MMLIV" "MMLV" "MMLVI" "MMLVII" "MMLVIII" "MMLIX" "MMLX" "MMLXI" "MMLXII" "MMLXIII" "MMLXIV" "MMLXV" "MMLXVI" "MMLXVII" "MMLXVIII" "MMLXIX" "MMLXX" "MMLXXI" "MMLXXII" "MMLXXIII" "MMLXXIV" "MMLXXV" "MMLXXVI" "MMLXXVII" "MMLXXVIII" "MMLXXIX" "MMLXXX" "MMLXXXI" "MMLXXXII" "MMLXXXIII" "MMLXXXIV" "MMLXXXV" "MMLXXXVI" "MMLXXXVII" "MMLXXXVIII" "MMLXXXIX" "MMXC" "MMXCI" "MMXCII" "MMXCIII" "MMXCIV" "MMXCV" "MMXCVI" "MMXCVII" "MMXCVIII" "MMXCIX" "MMC" "MMCI" "MMCII" "MMCIII" "MMCIV" "MMCV" "MMCVI" "MMCVII" "MMCVIII" "MMCIX" "MMCX" "MMCXI" "MMCXII" "MMCXIII" "MMCXIV" "MMCXV" "MMCXVI" "MMCXVII" "MMCXVIII" "MMCXIX" "MMCXX" "MMCXXI" "MMCXXII" "MMCXXIII" "MMCXXIV" "MMCXXV" "MMCXXVI" "MMCXXVII" "MMCXXVIII" "MMCXXIX" "MMCXXX" "MMCXXXI" "MMCXXXII" "MMCXXXIII" "MMCXXXIV" "MMCXXXV" "MMCXXXVI" "MMCXXXVII" "MMCXXXVIII" "MMCXXXIX" "MMCXL" "MMCXLI" "MMCXLII" "MMCXLIII" "MMCXLIV" "MMCXLV" "MMCXLVI" "MMCXLVII" "MMCXLVIII" "MMCXLIX" "MMCL" "MMCLI" "MMCLII" "MMCLIII" "MMCLIV" "MMCLV" "MMCLVI" "MMCLVII" "MMCLVIII" "MMCLIX" "MMCLX" "MMCLXI" "MMCLXII" "MMCLXIII" "MMCLXIV" "MMCLXV" "MMCLXVI" "MMCLXVII" "MMCLXVIII" "MMCLXIX" "MMCLXX" "MMCLXXI" "MMCLXXII" "MMCLXXIII" "MMCLXXIV" "MMCLXXV" "MMCLXXVI" "MMCLXXVII" "MMCLXXVIII" "MMCLXXIX" "MMCLXXX" "MMCLXXXI" "MMCLXXXII" "MMCLXXXIII" "MMCLXXXIV" "MMCLXXXV" "MMCLXXXVI" "MMCLXXXVII" "MMCLXXXVIII" "MMCLXXXIX" "MMCXC" "MMCXCI" "MMCXCII" "MMCXCIII" "MMCXCIV" "MMCXCV" "MMCXCVI" "MMCXCVII" "MMCXCVIII" "MMCXCIX" "MMCC" "MMCCI" "MMCCII" "MMCCIII" "MMCCIV" "MMCCV" "MMCCVI" "MMCCVII" "MMCCVIII" "MMCCIX" "MMCCX" "MMCCXI" "MMCCXII" "MMCCXIII" "MMCCXIV" "MMCCXV" "MMCCXVI" "MMCCXVII" "MMCCXVIII" "MMCCXIX" "MMCCXX" "MMCCXXI" "MMCCXXII" "MMCCXXIII" "MMCCXXIV" "MMCCXXV" "MMCCXXVI" "MMCCXXVII" "MMCCXXVIII" "MMCCXXIX" "MMCCXXX" "MMCCXXXI" "MMCCXXXII" "MMCCXXXIII" "MMCCXXXIV" "MMCCXXXV" "MMCCXXXVI" "MMCCXXXVII" "MMCCXXXVIII" "MMCCXXXIX" "MMCCXL" "MMCCXLI" "MMCCXLII" "MMCCXLIII" "MMCCXLIV" "MMCCXLV" "MMCCXLVI" "MMCCXLVII" "MMCCXLVIII" "MMCCXLIX" "MMCCL" "MMCCLI" "MMCCLII" "MMCCLIII" "MMCCLIV" "MMCCLV" "MMCCLVI" "MMCCLVII" "MMCCLVIII" "MMCCLIX" "MMCCLX" "MMCCLXI" "MMCCLXII" "MMCCLXIII" "MMCCLXIV" "MMCCLXV" "MMCCLXVI" "MMCCLXVII" "MMCCLXVIII" "MMCCLXIX" "MMCCLXX" "MMCCLXXI" "MMCCLXXII" "MMCCLXXIII" "MMCCLXXIV" "MMCCLXXV" "MMCCLXXVI" "MMCCLXXVII" "MMCCLXXVIII" "MMCCLXXIX" "MMCCLXXX" "MMCCLXXXI" "MMCCLXXXII" "MMCCLXXXIII" "MMCCLXXXIV" "MMCCLXXXV" "MMCCLXXXVI" "MMCCLXXXVII" "MMCCLXXXVIII" "MMCCLXXXIX" "MMCCXC" "MMCCXCI" "MMCCXCII" "MMCCXCIII" "MMCCXCIV" "MMCCXCV" "MMCCXCVI" "MMCCXCVII" "MMCCXCVIII" "MMCCXCIX" "MMCCC" "MMCCCI" "MMCCCII" "MMCCCIII" "MMCCCIV" "MMCCCV" "MMCCCVI" "MMCCCVII" "MMCCCVIII" "MMCCCIX" "MMCCCX" "MMCCCXI" "MMCCCXII" "MMCCCXIII" "MMCCCXIV" "MMCCCXV" "MMCCCXVI" "MMCCCXVII" "MMCCCXVIII" "MMCCCXIX" "MMCCCXX" "MMCCCXXI" "MMCCCXXII" "MMCCCXXIII" "MMCCCXXIV" "MMCCCXXV" "MMCCCXXVI" "MMCCCXXVII" "MMCCCXXVIII" "MMCCCXXIX" "MMCCCXXX" "MMCCCXXXI" "MMCCCXXXII" "MMCCCXXXIII" "MMCCCXXXIV" "MMCCCXXXV" "MMCCCXXXVI" "MMCCCXXXVII" "MMCCCXXXVIII" "MMCCCXXXIX" "MMCCCXL" "MMCCCXLI" "MMCCCXLII" "MMCCCXLIII" "MMCCCXLIV" "MMCCCXLV" "MMCCCXLVI" "MMCCCXLVII" "MMCCCXLVIII" "MMCCCXLIX" "MMCCCL" "MMCCCLI" "MMCCCLII" "MMCCCLIII" "MMCCCLIV" "MMCCCLV" "MMCCCLVI" "MMCCCLVII" "MMCCCLVIII" "MMCCCLIX" "MMCCCLX" "MMCCCLXI" "MMCCCLXII" "MMCCCLXIII" "MMCCCLXIV" "MMCCCLXV" "MMCCCLXVI" "MMCCCLXVII" "MMCCCLXVIII" "MMCCCLXIX" "MMCCCLXX" "MMCCCLXXI" "MMCCCLXXII" "MMCCCLXXIII" "MMCCCLXXIV" "MMCCCLXXV" "MMCCCLXXVI" "MMCCCLXXVII" "MMCCCLXXVIII" "MMCCCLXXIX" "MMCCCLXXX" "MMCCCLXXXI" "MMCCCLXXXII" "MMCCCLXXXIII" "MMCCCLXXXIV" "MMCCCLXXXV" "MMCCCLXXXVI" "MMCCCLXXXVII" "MMCCCLXXXVIII" "MMCCCLXXXIX" "MMCCCXC" "MMCCCXCI" "MMCCCXCII" "MMCCCXCIII" "MMCCCXCIV" "MMCCCXCV" "MMCCCXCVI" "MMCCCXCVII" "MMCCCXCVIII" "MMCCCXCIX" "MMCD" "MMCDI" "MMCDII" "MMCDIII" "MMCDIV" "MMCDV" "MMCDVI" "MMCDVII" "MMCDVIII" "MMCDIX" "MMCDX" "MMCDXI" "MMCDXII" "MMCDXIII" "MMCDXIV" "MMCDXV" "MMCDXVI" "MMCDXVII" "MMCDXVIII" "MMCDXIX" "MMCDXX" "MMCDXXI" "MMCDXXII" "MMCDXXIII" "MMCDXXIV" "MMCDXXV" "MMCDXXVI" "MMCDXXVII" "MMCDXXVIII" "MMCDXXIX" "MMCDXXX" "MMCDXXXI" "MMCDXXXII" "MMCDXXXIII" "MMCDXXXIV" "MMCDXXXV" "MMCDXXXVI" "MMCDXXXVII" "MMCDXXXVIII" "MMCDXXXIX" "MMCDXL" "MMCDXLI" "MMCDXLII" "MMCDXLIII" "MMCDXLIV" "MMCDXLV" "MMCDXLVI" "MMCDXLVII" "MMCDXLVIII" "MMCDXLIX" "MMCDL" "MMCDLI" "MMCDLII" "MMCDLIII" "MMCDLIV" "MMCDLV" "MMCDLVI" "MMCDLVII" "MMCDLVIII" "MMCDLIX" "MMCDLX" "MMCDLXI" "MMCDLXII" "MMCDLXIII" "MMCDLXIV" "MMCDLXV" "MMCDLXVI" "MMCDLXVII" "MMCDLXVIII" "MMCDLXIX" "MMCDLXX" "MMCDLXXI" "MMCDLXXII" "MMCDLXXIII" "MMCDLXXIV" "MMCDLXXV" "MMCDLXXVI" "MMCDLXXVII" "MMCDLXXVIII" "MMCDLXXIX" "MMCDLXXX" "MMCDLXXXI" "MMCDLXXXII" "MMCDLXXXIII" "MMCDLXXXIV" "MMCDLXXXV" "MMCDLXXXVI" "MMCDLXXXVII" "MMCDLXXXVIII" "MMCDLXXXIX" "MMCDXC" "MMCDXCI" "MMCDXCII" "MMCDXCIII" "MMCDXCIV" "MMCDXCV" "MMCDXCVI" "MMCDXCVII" "MMCDXCVIII" "MMCDXCIX" "MMD" "MMDI" "MMDII" "MMDIII" "MMDIV" "MMDV" "MMDVI" "MMDVII" "MMDVIII" "MMDIX" "MMDX" "MMDXI" "MMDXII" "MMDXIII" "MMDXIV" "MMDXV" "MMDXVI" "MMDXVII" "MMDXVIII" "MMDXIX" "MMDXX" "MMDXXI" "MMDXXII" "MMDXXIII" "MMDXXIV" "MMDXXV" "MMDXXVI" "MMDXXVII" "MMDXXVIII" "MMDXXIX" "MMDXXX" "MMDXXXI" "MMDXXXII" "MMDXXXIII" "MMDXXXIV" "MMDXXXV" "MMDXXXVI" "MMDXXXVII" "MMDXXXVIII" "MMDXXXIX" "MMDXL" "MMDXLI" "MMDXLII" "MMDXLIII" "MMDXLIV" "MMDXLV" "MMDXLVI" "MMDXLVII" "MMDXLVIII" "MMDXLIX" "MMDL" "MMDLI" "MMDLII" "MMDLIII" "MMDLIV" "MMDLV" "MMDLVI" "MMDLVII" "MMDLVIII" "MMDLIX" "MMDLX" "MMDLXI" "MMDLXII" "MMDLXIII" "MMDLXIV" "MMDLXV" "MMDLXVI" "MMDLXVII" "MMDLXVIII" "MMDLXIX" "MMDLXX" "MMDLXXI" "MMDLXXII" "MMDLXXIII" "MMDLXXIV" "MMDLXXV" "MMDLXXVI" "MMDLXXVII" "MMDLXXVIII" "MMDLXXIX" "MMDLXXX" "MMDLXXXI" "MMDLXXXII" "MMDLXXXIII" "MMDLXXXIV" "MMDLXXXV" "MMDLXXXVI" "MMDLXXXVII" "MMDLXXXVIII" "MMDLXXXIX" "MMDXC" "MMDXCI" "MMDXCII" "MMDXCIII" "MMDXCIV" "MMDXCV" "MMDXCVI" "MMDXCVII" "MMDXCVIII" "MMDXCIX" "MMDC" "MMDCI" "MMDCII" "MMDCIII" "MMDCIV" "MMDCV" "MMDCVI" "MMDCVII" "MMDCVIII" "MMDCIX" "MMDCX" "MMDCXI" "MMDCXII" "MMDCXIII" "MMDCXIV" "MMDCXV" "MMDCXVI" "MMDCXVII" "MMDCXVIII" "MMDCXIX" "MMDCXX" "MMDCXXI" "MMDCXXII" "MMDCXXIII" "MMDCXXIV" "MMDCXXV" "MMDCXXVI" "MMDCXXVII" "MMDCXXVIII" "MMDCXXIX" "MMDCXXX" "MMDCXXXI" "MMDCXXXII" "MMDCXXXIII" "MMDCXXXIV" "MMDCXXXV" "MMDCXXXVI" "MMDCXXXVII" "MMDCXXXVIII" "MMDCXXXIX" "MMDCXL" "MMDCXLI" "MMDCXLII" "MMDCXLIII" "MMDCXLIV" "MMDCXLV" "MMDCXLVI" "MMDCXLVII" "MMDCXLVIII" "MMDCXLIX" "MMDCL" "MMDCLI" "MMDCLII" "MMDCLIII" "MMDCLIV" "MMDCLV" "MMDCLVI" "MMDCLVII" "MMDCLVIII" "MMDCLIX" "MMDCLX" "MMDCLXI" "MMDCLXII" "MMDCLXIII" "MMDCLXIV" "MMDCLXV" "MMDCLXVI" "MMDCLXVII" "MMDCLXVIII" "MMDCLXIX" "MMDCLXX" "MMDCLXXI" "MMDCLXXII" "MMDCLXXIII" "MMDCLXXIV" "MMDCLXXV" "MMDCLXXVI" "MMDCLXXVII" "MMDCLXXVIII" "MMDCLXXIX" "MMDCLXXX" "MMDCLXXXI" "MMDCLXXXII" "MMDCLXXXIII" "MMDCLXXXIV" "MMDCLXXXV" "MMDCLXXXVI" "MMDCLXXXVII" "MMDCLXXXVIII" "MMDCLXXXIX" "MMDCXC" "MMDCXCI" "MMDCXCII" "MMDCXCIII" "MMDCXCIV" "MMDCXCV" "MMDCXCVI" "MMDCXCVII" "MMDCXCVIII" "MMDCXCIX" "MMDCC" "MMDCCI" "MMDCCII" "MMDCCIII" "MMDCCIV" "MMDCCV" "MMDCCVI" "MMDCCVII" "MMDCCVIII" "MMDCCIX" "MMDCCX" "MMDCCXI" "MMDCCXII" "MMDCCXIII" "MMDCCXIV" "MMDCCXV" "MMDCCXVI" "MMDCCXVII" "MMDCCXVIII" "MMDCCXIX" "MMDCCXX" "MMDCCXXI" "MMDCCXXII" "MMDCCXXIII" "MMDCCXXIV" "MMDCCXXV" "MMDCCXXVI" "MMDCCXXVII" "MMDCCXXVIII" "MMDCCXXIX" "MMDCCXXX" "MMDCCXXXI" "MMDCCXXXII" "MMDCCXXXIII" "MMDCCXXXIV" "MMDCCXXXV" "MMDCCXXXVI" "MMDCCXXXVII" "MMDCCXXXVIII" "MMDCCXXXIX" "MMDCCXL" "MMDCCXLI" "MMDCCXLII" "MMDCCXLIII" "MMDCCXLIV" "MMDCCXLV" "MMDCCXLVI" "MMDCCXLVII" "MMDCCXLVIII" "MMDCCXLIX" "MMDCCL" "MMDCCLI" "MMDCCLII" "MMDCCLIII" "MMDCCLIV" "MMDCCLV" "MMDCCLVI" "MMDCCLVII" "MMDCCLVIII" "MMDCCLIX" "MMDCCLX" "MMDCCLXI" "MMDCCLXII" "MMDCCLXIII" "MMDCCLXIV" "MMDCCLXV" "MMDCCLXVI" "MMDCCLXVII" "MMDCCLXVIII" "MMDCCLXIX" "MMDCCLXX" "MMDCCLXXI" "MMDCCLXXII" "MMDCCLXXIII" "MMDCCLXXIV" "MMDCCLXXV" "MMDCCLXXVI" "MMDCCLXXVII" "MMDCCLXXVIII" "MMDCCLXXIX" "MMDCCLXXX" "MMDCCLXXXI" "MMDCCLXXXII" "MMDCCLXXXIII" "MMDCCLXXXIV" "MMDCCLXXXV" "MMDCCLXXXVI" "MMDCCLXXXVII" "MMDCCLXXXVIII" "MMDCCLXXXIX" "MMDCCXC" "MMDCCXCI" "MMDCCXCII" "MMDCCXCIII" "MMDCCXCIV" "MMDCCXCV" "MMDCCXCVI" "MMDCCXCVII" "MMDCCXCVIII" "MMDCCXCIX" "MMDCCC" "MMDCCCI" "MMDCCCII" "MMDCCCIII" "MMDCCCIV" "MMDCCCV" "MMDCCCVI" "MMDCCCVII" "MMDCCCVIII" "MMDCCCIX" "MMDCCCX" "MMDCCCXI" "MMDCCCXII" "MMDCCCXIII" "MMDCCCXIV" "MMDCCCXV" "MMDCCCXVI" "MMDCCCXVII" "MMDCCCXVIII" "MMDCCCXIX" "MMDCCCXX" "MMDCCCXXI" "MMDCCCXXII" "MMDCCCXXIII" "MMDCCCXXIV" "MMDCCCXXV" "MMDCCCXXVI" "MMDCCCXXVII" "MMDCCCXXVIII" "MMDCCCXXIX" "MMDCCCXXX" "MMDCCCXXXI" "MMDCCCXXXII" "MMDCCCXXXIII" "MMDCCCXXXIV" "MMDCCCXXXV" "MMDCCCXXXVI" "MMDCCCXXXVII" "MMDCCCXXXVIII" "MMDCCCXXXIX" "MMDCCCXL" "MMDCCCXLI" "MMDCCCXLII" "MMDCCCXLIII" "MMDCCCXLIV" "MMDCCCXLV" "MMDCCCXLVI" "MMDCCCXLVII" "MMDCCCXLVIII" "MMDCCCXLIX" "MMDCCCL" "MMDCCCLI" "MMDCCCLII" "MMDCCCLIII" "MMDCCCLIV" "MMDCCCLV" "MMDCCCLVI" "MMDCCCLVII" "MMDCCCLVIII" "MMDCCCLIX" "MMDCCCLX" "MMDCCCLXI" "MMDCCCLXII" "MMDCCCLXIII" "MMDCCCLXIV" "MMDCCCLXV" "MMDCCCLXVI" "MMDCCCLXVII" "MMDCCCLXVIII" "MMDCCCLXIX" "MMDCCCLXX" "MMDCCCLXXI" "MMDCCCLXXII" "MMDCCCLXXIII" "MMDCCCLXXIV" "MMDCCCLXXV" "MMDCCCLXXVI" "MMDCCCLXXVII" "MMDCCCLXXVIII" "MMDCCCLXXIX" "MMDCCCLXXX" "MMDCCCLXXXI" "MMDCCCLXXXII" "MMDCCCLXXXIII" "MMDCCCLXXXIV" "MMDCCCLXXXV" "MMDCCCLXXXVI" "MMDCCCLXXXVII" "MMDCCCLXXXVIII" "MMDCCCLXXXIX" "MMDCCCXC" "MMDCCCXCI" "MMDCCCXCII" "MMDCCCXCIII" "MMDCCCXCIV" "MMDCCCXCV" "MMDCCCXCVI" "MMDCCCXCVII" "MMDCCCXCVIII" "MMDCCCXCIX" "MMCM" "MMCMI" "MMCMII" "MMCMIII" "MMCMIV" "MMCMV" "MMCMVI" "MMCMVII" "MMCMVIII" "MMCMIX" "MMCMX" "MMCMXI" "MMCMXII" "MMCMXIII" "MMCMXIV" "MMCMXV" "MMCMXVI" "MMCMXVII" "MMCMXVIII" "MMCMXIX" "MMCMXX" "MMCMXXI" "MMCMXXII" "MMCMXXIII" "MMCMXXIV" "MMCMXXV" "MMCMXXVI" "MMCMXXVII" "MMCMXXVIII" "MMCMXXIX" "MMCMXXX" "MMCMXXXI" "MMCMXXXII" "MMCMXXXIII" "MMCMXXXIV" "MMCMXXXV" "MMCMXXXVI" "MMCMXXXVII" "MMCMXXXVIII" "MMCMXXXIX" "MMCMXL" "MMCMXLI" "MMCMXLII" "MMCMXLIII" "MMCMXLIV" "MMCMXLV" "MMCMXLVI" "MMCMXLVII" "MMCMXLVIII" "MMCMXLIX" "MMCML" "MMCMLI" "MMCMLII" "MMCMLIII" "MMCMLIV" "MMCMLV" "MMCMLVI" "MMCMLVII" "MMCMLVIII" "MMCMLIX" "MMCMLX" "MMCMLXI" "MMCMLXII" "MMCMLXIII" "MMCMLXIV" "MMCMLXV" "MMCMLXVI" "MMCMLXVII" "MMCMLXVIII" "MMCMLXIX" "MMCMLXX" "MMCMLXXI" "MMCMLXXII" "MMCMLXXIII" "MMCMLXXIV" "MMCMLXXV" "MMCMLXXVI" "MMCMLXXVII" "MMCMLXXVIII" "MMCMLXXIX" "MMCMLXXX" "MMCMLXXXI" "MMCMLXXXII" "MMCMLXXXIII" "MMCMLXXXIV" "MMCMLXXXV" "MMCMLXXXVI" "MMCMLXXXVII" "MMCMLXXXVIII" "MMCMLXXXIX" "MMCMXC" "MMCMXCI" "MMCMXCII" "MMCMXCIII" "MMCMXCIV" "MMCMXCV" "MMCMXCVI" "MMCMXCVII" "MMCMXCVIII" "MMCMXCIX" "MMM" "MMMI" "MMMII" "MMMIII" "MMMIV" "MMMV" "MMMVI" "MMMVII" "MMMVIII" "MMMIX" "MMMX" "MMMXI" "MMMXII" "MMMXIII" "MMMXIV" "MMMXV" "MMMXVI" "MMMXVII" "MMMXVIII" "MMMXIX" "MMMXX" "MMMXXI" "MMMXXII" "MMMXXIII" "MMMXXIV" "MMMXXV" "MMMXXVI" "MMMXXVII" "MMMXXVIII" "MMMXXIX" "MMMXXX" "MMMXXXI" "MMMXXXII" "MMMXXXIII" "MMMXXXIV" "MMMXXXV" "MMMXXXVI" "MMMXXXVII" "MMMXXXVIII" "MMMXXXIX" "MMMXL" "MMMXLI" "MMMXLII" "MMMXLIII" "MMMXLIV" "MMMXLV" "MMMXLVI" "MMMXLVII" "MMMXLVIII" "MMMXLIX" "MMML" "MMMLI" "MMMLII" "MMMLIII" "MMMLIV" "MMMLV" "MMMLVI" "MMMLVII" "MMMLVIII" "MMMLIX" "MMMLX" "MMMLXI" "MMMLXII" "MMMLXIII" "MMMLXIV" "MMMLXV" "MMMLXVI" "MMMLXVII" "MMMLXVIII" "MMMLXIX" "MMMLXX" "MMMLXXI" "MMMLXXII" "MMMLXXIII" "MMMLXXIV" "MMMLXXV" "MMMLXXVI" "MMMLXXVII" "MMMLXXVIII" "MMMLXXIX" "MMMLXXX" "MMMLXXXI" "MMMLXXXII" "MMMLXXXIII" "MMMLXXXIV" "MMMLXXXV" "MMMLXXXVI" "MMMLXXXVII" "MMMLXXXVIII" "MMMLXXXIX" "MMMXC" "MMMXCI" "MMMXCII" "MMMXCIII" "MMMXCIV" "MMMXCV" "MMMXCVI" "MMMXCVII" "MMMXCVIII" "MMMXCIX" "MMMC" "MMMCI" "MMMCII" "MMMCIII" "MMMCIV" "MMMCV" "MMMCVI" "MMMCVII" "MMMCVIII" "MMMCIX" "MMMCX" "MMMCXI" "MMMCXII" "MMMCXIII" "MMMCXIV" "MMMCXV" "MMMCXVI" "MMMCXVII" "MMMCXVIII" "MMMCXIX" "MMMCXX" "MMMCXXI" "MMMCXXII" "MMMCXXIII" "MMMCXXIV" "MMMCXXV" "MMMCXXVI" "MMMCXXVII" "MMMCXXVIII" "MMMCXXIX" "MMMCXXX" "MMMCXXXI" "MMMCXXXII" "MMMCXXXIII" "MMMCXXXIV" "MMMCXXXV" "MMMCXXXVI" "MMMCXXXVII" "MMMCXXXVIII" "MMMCXXXIX" "MMMCXL" "MMMCXLI" "MMMCXLII" "MMMCXLIII" "MMMCXLIV" "MMMCXLV" "MMMCXLVI" "MMMCXLVII" "MMMCXLVIII" "MMMCXLIX" "MMMCL" "MMMCLI" "MMMCLII" "MMMCLIII" "MMMCLIV" "MMMCLV" "MMMCLVI" "MMMCLVII" "MMMCLVIII" "MMMCLIX" "MMMCLX" "MMMCLXI" "MMMCLXII" "MMMCLXIII" "MMMCLXIV" "MMMCLXV" "MMMCLXVI" "MMMCLXVII" "MMMCLXVIII" "MMMCLXIX" "MMMCLXX" "MMMCLXXI" "MMMCLXXII" "MMMCLXXIII" "MMMCLXXIV" "MMMCLXXV" "MMMCLXXVI" "MMMCLXXVII" "MMMCLXXVIII" "MMMCLXXIX" "MMMCLXXX" "MMMCLXXXI" "MMMCLXXXII" "MMMCLXXXIII" "MMMCLXXXIV" "MMMCLXXXV" "MMMCLXXXVI" "MMMCLXXXVII" "MMMCLXXXVIII" "MMMCLXXXIX" "MMMCXC" "MMMCXCI" "MMMCXCII" "MMMCXCIII" "MMMCXCIV" "MMMCXCV" "MMMCXCVI" "MMMCXCVII" "MMMCXCVIII" "MMMCXCIX" "MMMCC" "MMMCCI" "MMMCCII" "MMMCCIII" "MMMCCIV" "MMMCCV" "MMMCCVI" "MMMCCVII" "MMMCCVIII" "MMMCCIX" "MMMCCX" "MMMCCXI" "MMMCCXII" "MMMCCXIII" "MMMCCXIV" "MMMCCXV" "MMMCCXVI" "MMMCCXVII" "MMMCCXVIII" "MMMCCXIX" "MMMCCXX" "MMMCCXXI" "MMMCCXXII" "MMMCCXXIII" "MMMCCXXIV" "MMMCCXXV" "MMMCCXXVI" "MMMCCXXVII" "MMMCCXXVIII" "MMMCCXXIX" "MMMCCXXX" "MMMCCXXXI" "MMMCCXXXII" "MMMCCXXXIII" "MMMCCXXXIV" "MMMCCXXXV" "MMMCCXXXVI" "MMMCCXXXVII" "MMMCCXXXVIII" "MMMCCXXXIX" "MMMCCXL" "MMMCCXLI" "MMMCCXLII" "MMMCCXLIII" "MMMCCXLIV" "MMMCCXLV" "MMMCCXLVI" "MMMCCXLVII" "MMMCCXLVIII" "MMMCCXLIX" "MMMCCL" "MMMCCLI" "MMMCCLII" "MMMCCLIII" "MMMCCLIV" "MMMCCLV" "MMMCCLVI" "MMMCCLVII" "MMMCCLVIII" "MMMCCLIX" "MMMCCLX" "MMMCCLXI" "MMMCCLXII" "MMMCCLXIII" "MMMCCLXIV" "MMMCCLXV" "MMMCCLXVI" "MMMCCLXVII" "MMMCCLXVIII" "MMMCCLXIX" "MMMCCLXX" "MMMCCLXXI" "MMMCCLXXII" "MMMCCLXXIII" "MMMCCLXXIV" "MMMCCLXXV" "MMMCCLXXVI" "MMMCCLXXVII" "MMMCCLXXVIII" "MMMCCLXXIX" "MMMCCLXXX" "MMMCCLXXXI" "MMMCCLXXXII" "MMMCCLXXXIII" "MMMCCLXXXIV" "MMMCCLXXXV" "MMMCCLXXXVI" "MMMCCLXXXVII" "MMMCCLXXXVIII" "MMMCCLXXXIX" "MMMCCXC" "MMMCCXCI" "MMMCCXCII" "MMMCCXCIII" "MMMCCXCIV" "MMMCCXCV" "MMMCCXCVI" "MMMCCXCVII" "MMMCCXCVIII" "MMMCCXCIX" "MMMCCC" "MMMCCCI" "MMMCCCII" "MMMCCCIII" "MMMCCCIV" "MMMCCCV" "MMMCCCVI" "MMMCCCVII" "MMMCCCVIII" "MMMCCCIX" "MMMCCCX" "MMMCCCXI" "MMMCCCXII" "MMMCCCXIII" "MMMCCCXIV" "MMMCCCXV" "MMMCCCXVI" "MMMCCCXVII" "MMMCCCXVIII" "MMMCCCXIX" "MMMCCCXX" "MMMCCCXXI" "MMMCCCXXII" "MMMCCCXXIII" "MMMCCCXXIV" "MMMCCCXXV" "MMMCCCXXVI" "MMMCCCXXVII" "MMMCCCXXVIII" "MMMCCCXXIX" "MMMCCCXXX" "MMMCCCXXXI" "MMMCCCXXXII" "MMMCCCXXXIII" "MMMCCCXXXIV" "MMMCCCXXXV" "MMMCCCXXXVI" "MMMCCCXXXVII" "MMMCCCXXXVIII" "MMMCCCXXXIX" "MMMCCCXL" "MMMCCCXLI" "MMMCCCXLII" "MMMCCCXLIII" "MMMCCCXLIV" "MMMCCCXLV" "MMMCCCXLVI" "MMMCCCXLVII" "MMMCCCXLVIII" "MMMCCCXLIX" "MMMCCCL" "MMMCCCLI" "MMMCCCLII" "MMMCCCLIII" "MMMCCCLIV" "MMMCCCLV" "MMMCCCLVI" "MMMCCCLVII" "MMMCCCLVIII" "MMMCCCLIX" "MMMCCCLX" "MMMCCCLXI" "MMMCCCLXII" "MMMCCCLXIII" "MMMCCCLXIV" "MMMCCCLXV" "MMMCCCLXVI" "MMMCCCLXVII" "MMMCCCLXVIII" "MMMCCCLXIX" "MMMCCCLXX" "MMMCCCLXXI" "MMMCCCLXXII" "MMMCCCLXXIII" "MMMCCCLXXIV" "MMMCCCLXXV" "MMMCCCLXXVI" "MMMCCCLXXVII" "MMMCCCLXXVIII" "MMMCCCLXXIX" "MMMCCCLXXX" "MMMCCCLXXXI" "MMMCCCLXXXII" "MMMCCCLXXXIII" "MMMCCCLXXXIV" "MMMCCCLXXXV" "MMMCCCLXXXVI" "MMMCCCLXXXVII" "MMMCCCLXXXVIII" "MMMCCCLXXXIX" "MMMCCCXC" "MMMCCCXCI" "MMMCCCXCII" "MMMCCCXCIII" "MMMCCCXCIV" "MMMCCCXCV" "MMMCCCXCVI" "MMMCCCXCVII" "MMMCCCXCVIII" "MMMCCCXCIX" "MMMCD" "MMMCDI" "MMMCDII" "MMMCDIII" "MMMCDIV" "MMMCDV" "MMMCDVI" "MMMCDVII" "MMMCDVIII" "MMMCDIX" "MMMCDX" "MMMCDXI" "MMMCDXII" "MMMCDXIII" "MMMCDXIV" "MMMCDXV" "MMMCDXVI" "MMMCDXVII" "MMMCDXVIII" "MMMCDXIX" "MMMCDXX" "MMMCDXXI" "MMMCDXXII" "MMMCDXXIII" "MMMCDXXIV" "MMMCDXXV" "MMMCDXXVI" "MMMCDXXVII" "MMMCDXXVIII" "MMMCDXXIX" "MMMCDXXX" "MMMCDXXXI" "MMMCDXXXII" "MMMCDXXXIII" "MMMCDXXXIV" "MMMCDXXXV" "MMMCDXXXVI" "MMMCDXXXVII" "MMMCDXXXVIII" "MMMCDXXXIX" "MMMCDXL" "MMMCDXLI" "MMMCDXLII" "MMMCDXLIII" "MMMCDXLIV" "MMMCDXLV" "MMMCDXLVI" "MMMCDXLVII" "MMMCDXLVIII" "MMMCDXLIX" "MMMCDL" "MMMCDLI" "MMMCDLII" "MMMCDLIII" "MMMCDLIV" "MMMCDLV" "MMMCDLVI" "MMMCDLVII" "MMMCDLVIII" "MMMCDLIX" "MMMCDLX" "MMMCDLXI" "MMMCDLXII" "MMMCDLXIII" "MMMCDLXIV" "MMMCDLXV" "MMMCDLXVI" "MMMCDLXVII" "MMMCDLXVIII" "MMMCDLXIX" "MMMCDLXX" "MMMCDLXXI" "MMMCDLXXII" "MMMCDLXXIII" "MMMCDLXXIV" "MMMCDLXXV" "MMMCDLXXVI" "MMMCDLXXVII" "MMMCDLXXVIII" "MMMCDLXXIX" "MMMCDLXXX" "MMMCDLXXXI" "MMMCDLXXXII" "MMMCDLXXXIII" "MMMCDLXXXIV" "MMMCDLXXXV" "MMMCDLXXXVI" "MMMCDLXXXVII" "MMMCDLXXXVIII" "MMMCDLXXXIX" "MMMCDXC" "MMMCDXCI" "MMMCDXCII" "MMMCDXCIII" "MMMCDXCIV" "MMMCDXCV" "MMMCDXCVI" "MMMCDXCVII" "MMMCDXCVIII" "MMMCDXCIX" "MMMD" "MMMDI" "MMMDII" "MMMDIII" "MMMDIV" "MMMDV" "MMMDVI" "MMMDVII" "MMMDVIII" "MMMDIX" "MMMDX" "MMMDXI" "MMMDXII" "MMMDXIII" "MMMDXIV" "MMMDXV" "MMMDXVI" "MMMDXVII" "MMMDXVIII" "MMMDXIX" "MMMDXX" "MMMDXXI" "MMMDXXII" "MMMDXXIII" "MMMDXXIV" "MMMDXXV" "MMMDXXVI" "MMMDXXVII" "MMMDXXVIII" "MMMDXXIX" "MMMDXXX" "MMMDXXXI" "MMMDXXXII" "MMMDXXXIII" "MMMDXXXIV" "MMMDXXXV" "MMMDXXXVI" "MMMDXXXVII" "MMMDXXXVIII" "MMMDXXXIX" "MMMDXL" "MMMDXLI" "MMMDXLII" "MMMDXLIII" "MMMDXLIV" "MMMDXLV" "MMMDXLVI" "MMMDXLVII" "MMMDXLVIII" "MMMDXLIX" "MMMDL" "MMMDLI" "MMMDLII" "MMMDLIII" "MMMDLIV" "MMMDLV" "MMMDLVI" "MMMDLVII" "MMMDLVIII" "MMMDLIX" "MMMDLX" "MMMDLXI" "MMMDLXII" "MMMDLXIII" "MMMDLXIV" "MMMDLXV" "MMMDLXVI" "MMMDLXVII" "MMMDLXVIII" "MMMDLXIX" "MMMDLXX" "MMMDLXXI" "MMMDLXXII" "MMMDLXXIII" "MMMDLXXIV" "MMMDLXXV" "MMMDLXXVI" "MMMDLXXVII" "MMMDLXXVIII" "MMMDLXXIX" "MMMDLXXX" "MMMDLXXXI" "MMMDLXXXII" "MMMDLXXXIII" "MMMDLXXXIV" "MMMDLXXXV" "MMMDLXXXVI" "MMMDLXXXVII" "MMMDLXXXVIII" "MMMDLXXXIX" "MMMDXC" "MMMDXCI" "MMMDXCII" "MMMDXCIII" "MMMDXCIV" "MMMDXCV" "MMMDXCVI" "MMMDXCVII" "MMMDXCVIII" "MMMDXCIX" "MMMDC" "MMMDCI" "MMMDCII" "MMMDCIII" "MMMDCIV" "MMMDCV" "MMMDCVI" "MMMDCVII" "MMMDCVIII" "MMMDCIX" "MMMDCX" "MMMDCXI" "MMMDCXII" "MMMDCXIII" "MMMDCXIV" "MMMDCXV" "MMMDCXVI" "MMMDCXVII" "MMMDCXVIII" "MMMDCXIX" "MMMDCXX" "MMMDCXXI" "MMMDCXXII" "MMMDCXXIII" "MMMDCXXIV" "MMMDCXXV" "MMMDCXXVI" "MMMDCXXVII" "MMMDCXXVIII" "MMMDCXXIX" "MMMDCXXX" "MMMDCXXXI" "MMMDCXXXII" "MMMDCXXXIII" "MMMDCXXXIV" "MMMDCXXXV" "MMMDCXXXVI" "MMMDCXXXVII" "MMMDCXXXVIII" "MMMDCXXXIX" "MMMDCXL" "MMMDCXLI" "MMMDCXLII" "MMMDCXLIII" "MMMDCXLIV" "MMMDCXLV" "MMMDCXLVI" "MMMDCXLVII" "MMMDCXLVIII" "MMMDCXLIX" "MMMDCL" "MMMDCLI" "MMMDCLII" "MMMDCLIII" "MMMDCLIV" "MMMDCLV" "MMMDCLVI" "MMMDCLVII" "MMMDCLVIII" "MMMDCLIX" "MMMDCLX" "MMMDCLXI" "MMMDCLXII" "MMMDCLXIII" "MMMDCLXIV" "MMMDCLXV" "MMMDCLXVI" "MMMDCLXVII" "MMMDCLXVIII" "MMMDCLXIX" "MMMDCLXX" "MMMDCLXXI" "MMMDCLXXII" "MMMDCLXXIII" "MMMDCLXXIV" "MMMDCLXXV" "MMMDCLXXVI" "MMMDCLXXVII" "MMMDCLXXVIII" "MMMDCLXXIX" "MMMDCLXXX" "MMMDCLXXXI" "MMMDCLXXXII" "MMMDCLXXXIII" "MMMDCLXXXIV" "MMMDCLXXXV" "MMMDCLXXXVI" "MMMDCLXXXVII" "MMMDCLXXXVIII" "MMMDCLXXXIX" "MMMDCXC" "MMMDCXCI" "MMMDCXCII" "MMMDCXCIII" "MMMDCXCIV" "MMMDCXCV" "MMMDCXCVI" "MMMDCXCVII" "MMMDCXCVIII" "MMMDCXCIX" "MMMDCC" "MMMDCCI" "MMMDCCII" "MMMDCCIII" "MMMDCCIV" "MMMDCCV" "MMMDCCVI" "MMMDCCVII" "MMMDCCVIII" "MMMDCCIX" "MMMDCCX" "MMMDCCXI" "MMMDCCXII" "MMMDCCXIII" "MMMDCCXIV" "MMMDCCXV" "MMMDCCXVI" "MMMDCCXVII" "MMMDCCXVIII" "MMMDCCXIX" "MMMDCCXX" "MMMDCCXXI" "MMMDCCXXII" "MMMDCCXXIII" "MMMDCCXXIV" "MMMDCCXXV" "MMMDCCXXVI" "MMMDCCXXVII" "MMMDCCXXVIII" "MMMDCCXXIX" "MMMDCCXXX" "MMMDCCXXXI" "MMMDCCXXXII" "MMMDCCXXXIII" "MMMDCCXXXIV" "MMMDCCXXXV" "MMMDCCXXXVI" "MMMDCCXXXVII" "MMMDCCXXXVIII" "MMMDCCXXXIX" "MMMDCCXL" "MMMDCCXLI" "MMMDCCXLII" "MMMDCCXLIII" "MMMDCCXLIV" "MMMDCCXLV" "MMMDCCXLVI" "MMMDCCXLVII" "MMMDCCXLVIII" "MMMDCCXLIX" "MMMDCCL" "MMMDCCLI" "MMMDCCLII" "MMMDCCLIII" "MMMDCCLIV" "MMMDCCLV" "MMMDCCLVI" "MMMDCCLVII" "MMMDCCLVIII" "MMMDCCLIX" "MMMDCCLX" "MMMDCCLXI" "MMMDCCLXII" "MMMDCCLXIII" "MMMDCCLXIV" "MMMDCCLXV" "MMMDCCLXVI" "MMMDCCLXVII" "MMMDCCLXVIII" "MMMDCCLXIX" "MMMDCCLXX" "MMMDCCLXXI" "MMMDCCLXXII" "MMMDCCLXXIII" "MMMDCCLXXIV" "MMMDCCLXXV" "MMMDCCLXXVI" "MMMDCCLXXVII" "MMMDCCLXXVIII" "MMMDCCLXXIX" "MMMDCCLXXX" "MMMDCCLXXXI" "MMMDCCLXXXII" "MMMDCCLXXXIII" "MMMDCCLXXXIV" "MMMDCCLXXXV" "MMMDCCLXXXVI" "MMMDCCLXXXVII" "MMMDCCLXXXVIII" "MMMDCCLXXXIX" "MMMDCCXC" "MMMDCCXCI" "MMMDCCXCII" "MMMDCCXCIII" "MMMDCCXCIV" "MMMDCCXCV" "MMMDCCXCVI" "MMMDCCXCVII" "MMMDCCXCVIII" "MMMDCCXCIX" "MMMDCCC" "MMMDCCCI" "MMMDCCCII" "MMMDCCCIII" "MMMDCCCIV" "MMMDCCCV" "MMMDCCCVI" "MMMDCCCVII" "MMMDCCCVIII" "MMMDCCCIX" "MMMDCCCX" "MMMDCCCXI" "MMMDCCCXII" "MMMDCCCXIII" "MMMDCCCXIV" "MMMDCCCXV" "MMMDCCCXVI" "MMMDCCCXVII" "MMMDCCCXVIII" "MMMDCCCXIX" "MMMDCCCXX" "MMMDCCCXXI" "MMMDCCCXXII" "MMMDCCCXXIII" "MMMDCCCXXIV" "MMMDCCCXXV" "MMMDCCCXXVI" "MMMDCCCXXVII" "MMMDCCCXXVIII" "MMMDCCCXXIX" "MMMDCCCXXX" "MMMDCCCXXXI" "MMMDCCCXXXII" "MMMDCCCXXXIII" "MMMDCCCXXXIV" "MMMDCCCXXXV" "MMMDCCCXXXVI" "MMMDCCCXXXVII" "MMMDCCCXXXVIII" "MMMDCCCXXXIX" "MMMDCCCXL" "MMMDCCCXLI" "MMMDCCCXLII" "MMMDCCCXLIII" "MMMDCCCXLIV" "MMMDCCCXLV" "MMMDCCCXLVI" "MMMDCCCXLVII" "MMMDCCCXLVIII" "MMMDCCCXLIX" "MMMDCCCL" "MMMDCCCLI" "MMMDCCCLII" "MMMDCCCLIII" "MMMDCCCLIV" "MMMDCCCLV" "MMMDCCCLVI" "MMMDCCCLVII" "MMMDCCCLVIII" "MMMDCCCLIX" "MMMDCCCLX" "MMMDCCCLXI" "MMMDCCCLXII" "MMMDCCCLXIII" "MMMDCCCLXIV" "MMMDCCCLXV" "MMMDCCCLXVI" "MMMDCCCLXVII" "MMMDCCCLXVIII" "MMMDCCCLXIX" "MMMDCCCLXX" "MMMDCCCLXXI" "MMMDCCCLXXII" "MMMDCCCLXXIII" "MMMDCCCLXXIV" "MMMDCCCLXXV" "MMMDCCCLXXVI" "MMMDCCCLXXVII" "MMMDCCCLXXVIII" "MMMDCCCLXXIX" "MMMDCCCLXXX" "MMMDCCCLXXXI" "MMMDCCCLXXXII" "MMMDCCCLXXXIII" "MMMDCCCLXXXIV" "MMMDCCCLXXXV" "MMMDCCCLXXXVI" "MMMDCCCLXXXVII" "MMMDCCCLXXXVIII" "MMMDCCCLXXXIX" "MMMDCCCXC" "MMMDCCCXCI" "MMMDCCCXCII" "MMMDCCCXCIII" "MMMDCCCXCIV" "MMMDCCCXCV" "MMMDCCCXCVI" "MMMDCCCXCVII" "MMMDCCCXCVIII" "MMMDCCCXCIX" "MMMCM" "MMMCMI" "MMMCMII" "MMMCMIII" "MMMCMIV" "MMMCMV" "MMMCMVI" "MMMCMVII" "MMMCMVIII" "MMMCMIX" "MMMCMX" "MMMCMXI" "MMMCMXII" "MMMCMXIII" "MMMCMXIV" "MMMCMXV" "MMMCMXVI" "MMMCMXVII" "MMMCMXVIII" "MMMCMXIX" "MMMCMXX" "MMMCMXXI" "MMMCMXXII" "MMMCMXXIII" "MMMCMXXIV" "MMMCMXXV" "MMMCMXXVI" "MMMCMXXVII" "MMMCMXXVIII" "MMMCMXXIX" "MMMCMXXX" "MMMCMXXXI" "MMMCMXXXII" "MMMCMXXXIII" "MMMCMXXXIV" "MMMCMXXXV" "MMMCMXXXVI" "MMMCMXXXVII" "MMMCMXXXVIII" "MMMCMXXXIX" "MMMCMXL" "MMMCMXLI" "MMMCMXLII" "MMMCMXLIII" "MMMCMXLIV" "MMMCMXLV" "MMMCMXLVI" "MMMCMXLVII" "MMMCMXLVIII" "MMMCMXLIX" "MMMCML" "MMMCMLI" "MMMCMLII" "MMMCMLIII" "MMMCMLIV" "MMMCMLV" "MMMCMLVI" "MMMCMLVII" "MMMCMLVIII" "MMMCMLIX" "MMMCMLX" "MMMCMLXI" "MMMCMLXII" "MMMCMLXIII" "MMMCMLXIV" "MMMCMLXV" "MMMCMLXVI" "MMMCMLXVII" "MMMCMLXVIII" "MMMCMLXIX" "MMMCMLXX" "MMMCMLXXI" "MMMCMLXXII" "MMMCMLXXIII" "MMMCMLXXIV" "MMMCMLXXV" "MMMCMLXXVI" "MMMCMLXXVII" "MMMCMLXXVIII" "MMMCMLXXIX" "MMMCMLXXX" "MMMCMLXXXI" "MMMCMLXXXII" "MMMCMLXXXIII" "MMMCMLXXXIV" "MMMCMLXXXV" "MMMCMLXXXVI" "MMMCMLXXXVII" "MMMCMLXXXVIII" "MMMCMLXXXIX" "MMMCMXC" "MMMCMXCI" "MMMCMXCII" "MMMCMXCIII" "MMMCMXCIV" "MMMCMXCV" "MMMCMXCVI" "MMMCMXCVII" "MMMCMXCVIII" "MMMCMXCIX")) gcl-2.7.1/ansi-tests/PaxHeaders/gensym.lsp0000644000000000000000000000013114542551762015472 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.481789135 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/gensym.lsp0000644000175000017500000000560014542551762015072 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:43:47 2003 ;;;; Contains: Tests of GENSYM (in-package :cl-test) ;;; 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)) (symbol-name (gensym))) #.(string '#:g1)) ;;; Gensym uses the string argument instead of the default (deftest gensym.4 (let ((*gensym-counter* 1327)) (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)) (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)) (symbol-name (gensym))) #.(string '#:g1234567890123456789012345678901234567890)) ;;; gensym increments Really Big values of *gensym-counter* (deftest gensym.11 (let ((*gensym-counter* 12345678901234567890123456789012345678901234567890)) (gensym) *gensym-counter*) 12345678901234567890123456789012345678901234567891) ;;; Gensym uses an integer argument instead of the counter (deftest gensym.12 (let ((*gensym-counter* 10)) (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)) (gensym 123) *gensym-counter*) 10) ;;; GENSYM counter is a non-negative integer (deftest gensym-counter.1 (and (integerp *gensym-counter*) (>= *gensym-counter* 0) t) t) ;;; 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 (check-type-error #'gensym #'(lambda (x) (typep x '(or string unsigned-byte)))) nil) (deftest gensym.error.7 (signals-error (gensym 10 'foo) program-error) t) (deftest gensym.error.8 (signals-error (locally (gensym t) t) type-error) t) (deftest gensym.error.9 (signals-error (gensym "FOO" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/slot-missing.lsp0000644000000000000000000000013214542551763016622 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.481789135 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/slot-missing.lsp0000644000175000017500000000376014542551763016226 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 06:03:58 2003 ;;;; Contains: Tests of SLOT-MISSING (in-package :cl-test) (defparameter *slot-missing-class-01-var* nil) (defclass slot-missing-class-01 () (a b c)) (defmethod slot-missing ((class t) (obj slot-missing-class-01) (slot-name t) (operation t) &optional (new-value nil new-value-p)) (setf *slot-missing-class-01-var* (list slot-name operation new-value (notnot new-value-p)))) (deftest slot-missing.1 (let ((obj (make-instance 'slot-missing-class-01))) (values (slot-value obj 'foo) *slot-missing-class-01-var*)) (foo slot-value nil nil) (foo slot-value nil nil)) (deftest slot-missing.2 (let ((obj (make-instance 'slot-missing-class-01))) (values (setf (slot-value obj 'foo) 'bar) *slot-missing-class-01-var*)) bar (foo setf bar t)) (deftest slot-missing.3 (let ((obj (make-instance 'slot-missing-class-01))) (values (eqt obj (slot-makunbound obj 'xyz)) *slot-missing-class-01-var*)) t (xyz slot-makunbound nil nil)) (deftest slot-missing.4 (let ((obj (make-instance 'slot-missing-class-01))) (values (notnot (slot-boundp obj 'abc)) *slot-missing-class-01-var*)) t (abc slot-boundp nil nil)) (deftest slot-missing.5 (let ((obj (make-instance 'slot-missing-class-01))) (slot-value obj 'd)) (d slot-value nil nil)) (deftest slot-missing.6 (let ((obj (make-instance 'slot-missing-class-01))) (setf (slot-value obj 'd) 'bar)) bar) (deftest slot-missing.7 (let* ((obj (make-instance 'slot-missing-class-01)) (val (slot-makunbound obj 'd))) (if (eq val obj) :good val)) :good) (defmethod slot-missing ((class t) (obj slot-missing-class-01) (slot-name (eql 'not-there)) (operation (eql 'slot-boundp)) &optional new-value) (declare (ignore new-value)) (values nil :ignore-this)) (deftest slot-missing.8 (let* ((obj (make-instance 'slot-missing-class-01))) (slot-boundp obj 'not-there)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/cl-symbols.lsp0000644000000000000000000000013014542551762016253 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.481789135 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cl-symbols.lsp0000644000175000017500000023445514542551762015670 0ustar00cammcamm;-*- 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) ;;; Standardized packages have the right names, nicknames (deftest keyword-package-nicknames :notes :standardized-package-nicknames (package-nicknames (find-package "KEYWORD")) nil) (deftest common-lisp-package-nicknames :notes :standardized-package-nicknames (remove "CL" (package-nicknames (find-package "COMMON-LISP")) :test-not 'string=);FIXME double check, spec just says CL is a nickname ("CL")) (deftest common-lisp-user-package-nicknames :notes :standardized-package-nicknames (remove "CL-USER" (package-nicknames (find-package "COMMON-LISP-USER")) :test-not 'string=);FIXME double check, spec just says CL-USER is a nickname ("CL-USER")) ;;; Test there are no extra exported symbols (deftest no-extra-symbols-exported-from-common-lisp (let ((ht (make-hash-table :test 'equal))) (loop for n in *cl-symbol-names* do (setf (gethash n ht) t)) (let ((extras nil)) (do-external-symbols (s "CL") (unless (gethash (symbol-name s) ht) (push s extras))) extras)) 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) ;;;;;;;;;;;;;;;;;;;; ;;; 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 symbol-package.error.1 (signals-error (symbol-package) program-error) t) (deftest symbol-package.error.2 (signals-error (symbol-package 'cons nil) program-error) t) (deftest symbol-package.error.3 (check-type-error #'symbol-package #'symbolp) nil) (deftest symbol-plist.error.1 (signals-error (symbol-plist) program-error) t) (deftest symbol-plist.error.2 (signals-error (symbol-plist 'cons nil) program-error) t) (deftest symbol-plist.error.3 (check-type-error #'symbol-plist #'symbolp) nil) (deftest symbol-plist.error.4 (check-type-error #'(lambda (x) (setf (symbol-plist x) nil)) #'symbolp) nil) (deftest symbol-value.error.1 (signals-error (symbol-value) program-error) t) (deftest symbol-value.error.2 (signals-error (symbol-value '*package* nil) program-error) t) (deftest symbol-value.error.3 (check-type-error #'symbol-value #'symbolp) nil) (deftest symbol-value.error.4 (check-type-error #'(lambda (x) (setf (symbol-value x) nil)) #'symbolp) nil) (deftest symbol-value.error.5 (let ((sym (gensym))) (declare (optimize safety)) (handler-case (progn (symbol-value sym) :bad) (unbound-variable (c) (assert (eq (cell-error-name c) sym)) :good))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/log.lsp0000644000000000000000000000013214720126436014744 xustar0030 mtime=1732291870.142085631 30 atime=1744294960.481789135 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/log.lsp0000644000175000017500000000601314720126436014342 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:53:33 2004 ;;;; Contains: Tests of LOG (in-package :cl-test) (deftest log.1 (let ((result (log 1))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest log.2 (mapcar #'log '(1.0s0 1.0f0 1.0d0 1.0l0)) (0.0s0 0.0f0 0.0d0 0.0l0)) (deftest log.3 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (+ (random (coerce 1 type)) (/ 1 1000)) for rlist = (multiple-value-list (log x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest log.4 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (1+ (random (coerce 1000000 type))) for rlist = (multiple-value-list (log x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest log.5 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x = (- (random (coerce 1 type))) for rlist = (and (/= x zero) (multiple-value-list (log x))) for y = (car rlist) repeat 1000 unless (or (= x zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x rlist))) nil) (deftest log.6 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x = (- (random (coerce 1000000 type))) for rlist = (and (/= x zero) (multiple-value-list (log x))) for y = (car rlist) repeat 1000 unless (or (= x zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x rlist))) nil) (deftest log.7 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x1 = (- (random (coerce 2000 type)) 1000) for x2 = (1+ (random (coerce 1000 type))) for rlist = (and (/= x1 zero) (multiple-value-list (log (complex x1 x2)))) for y = (car rlist) repeat 1000 unless (or (= x1 zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x1 x2 rlist))) nil) (deftest log.8 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) nconc (loop for x1 = (- (random (coerce 2000 type)) 1000) for x2 = (- -1 (random (coerce 1000 type))) for rlist = (and (/= x1 zero) (multiple-value-list (log (complex x1 x2)))) for y = (car rlist) repeat 1000 unless (or (= x1 zero) (and (null (cdr rlist)) (typep y `(complex ,type)))) collect (list x1 x2 rlist))) nil) (deftest log.9 (log (expt 2 1024)) 709.782712893384) (deftest log.10 (log (complex (expt 2 1024) 3)) #C(709.782712893384 1.668805393880401E-308)) ;;; FIXME ;;; Add tests for two-arg calls ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest log.error.1 (signals-error (log) program-error) t) (deftest log.error.2 (signals-error (log 1.0 2.0 3.0) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-reader.lsp0000644000000000000000000000013214772071556016353 xustar0030 mtime=1743287150.054905886 30 atime=1744294960.481789135 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-reader.lsp0000644000175000017500000000116714772071556015756 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 05:20:41 2004 ;;;; Contains: Load tests of the reader (in-package :cl-test) (load "reader-test.lsp") (load "with-standard-io-syntax.lsp") (load "copy-readtable.lsp") (load "read.lsp") (load "read-preserving-whitespace.lsp") (load "read-delimited-list.lsp") (load "read-from-string.lsp") (load "readtable-case.lsp") (load "readtablep.lsp") (load "get-macro-character.lsp") (load "set-macro-character.lsp") (load "read-suppress.lsp") (load "set-syntax-from-char.lsp") (load "dispatch-macro-characters.lsp") (load "syntax.lsp") (load "syntax-tokens.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/subst.lsp0000644000000000000000000000013114542551763015331 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.485789153 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subst.lsp0000644000175000017500000001070714542551763014735 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:37:56 2003 ;;;; Contains: Tests of SUBST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest subst.10 (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (1 2 10 x x 4)) (deftest subst.11 (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (1 2 10 x x 4)) (defharmless subset.test-and-test-not.1 (subst 'a 'b (list 'a 'b 'c 'd 'e) :test #'eq :test-not #'eq)) (defharmless subset.test-and-test-not.2 (subst 'a 'b (list 'a 'b 'c 'd 'e) :test-not #'eq :test #'eq)) ;;; 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) ;;; Const fold tests (def-fold-test subst.fold.1 (subst 'a 'b '(a b c (a . b) . a))) ;;; 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)) (deftest subst.error.1 (signals-error (subst) program-error) t) (deftest subst.error.2 (signals-error (subst 'a) program-error) t) (deftest subst.error.3 (signals-error (subst 'a 'b) program-error) t) (deftest subst.error.4 (signals-error (subst 'a 'b nil :foo nil) program-error) t) (deftest subst.error.5 (signals-error (subst 'a 'b nil :test) program-error) t) (deftest subst.error.6 (signals-error (subst 'a 'b nil 1) program-error) t) (deftest subst.error.7 (signals-error (subst 'a 'b nil :bad t :allow-other-keys nil) program-error) t) (deftest subst.error.8 (signals-error (subst 'a 'b (list 'a 'b) :test #'identity) program-error) t) (deftest subst.error.9 (signals-error (subst 'a 'b (list 'a 'b) :test-not #'identity) program-error) t) (deftest subst.error.10 (signals-error (subst 'a 'b (list 'a 'b) :key #'equal) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/complexp.lsp0000644000000000000000000000013014542551762016016 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.485789153 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/complexp.lsp0000644000175000017500000000071514542551762015421 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 21:03:18 2003 ;;;; Contains: Tests for COMPLEXP (in-package :cl-test) (deftest complexp.error.1 (signals-error (complexp) program-error) t) (deftest complexp.error.2 (signals-error (complexp 0 0) program-error) t) (deftest complexp.error.3 (signals-error (complexp #C(1 1) nil) program-error) t) (deftest complexp.1 (check-type-predicate #'complexp 'complex) nil) gcl-2.7.1/ansi-tests/PaxHeaders/count-if-not.lsp0000644000000000000000000000013214542551762016513 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.485789153 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/count-if-not.lsp0000644000175000017500000003547514542551762016127 0ustar00cammcamm;-*- 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) ;;; Other special vectors `(deftest count-if-not.special-vector.1 (do-special-integer-vectors (v #(1 0 1 1 1 0 1 1 1 0 1) nil) (assert (eql (count-if-not #'plusp v) 3)) (assert (eql (count-if-not #'zerop v) 8)) (assert (eql (count-if-not #'plusp v :start 2) 2)) (assert (eql (count-if-not #'zerop v :end 9) 7))) nil) (deftest count-if-not.special-vector.2 (do-special-integer-vectors (v #(1 3 2 4 7 5 6 1 0 2 4) nil) (assert (eql (count-if-not #'evenp v) 5)) (assert (eql (count-if-not #'oddp v) 6)) (assert (eql (count-if-not #'plusp v :start 2) 1)) (assert (eql (count-if-not #'zerop v :end 8) 8))) nil) (deftest count-if-not.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) collect (coerce e etype)) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if-not #'zerop vec) unless (= result 7) collect (list etype vals vec result)) nil) (deftest count-if-not.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float integer rational) for etype = `(complex ,cetype) for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) collect (complex 0 (coerce e cetype))) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if-not #'(lambda (x) (< (abs x) 5/2)) vec) unless (= result 7) collect (list etype vals vec result)) nil) ;;; 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) (deftest count-if-not-string.18 (do-special-strings (s "a1ha^%&%#( 873ff83nfa!" nil) (assert (= (count-if-not #'alpha-char-p s) 14))) nil) ;;; 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 (check-type-error #'(lambda (x) (count-if-not #'identity x)) #'sequencep) nil) (deftest count-if-not.error.4 (signals-error (count-if-not) program-error) t) (deftest count-if-not.error.5 (signals-error (count-if-not #'null) program-error) t) (deftest count-if-not.error.6 (signals-error (count-if-not #'null nil :bad t) program-error) t) (deftest count-if-not.error.7 (signals-error (count-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest count-if-not.error.8 (signals-error (count-if-not #'null nil :key) program-error) t) (deftest count-if-not.error.9 (signals-error (count-if-not #'null nil 3 3) program-error) t) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if-not.error.10 (signals-error (count-if-not #'null nil :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest count-if-not.error.11 (signals-error (locally (count-if-not #'identity 1) t) type-error) t) (deftest count-if-not.error.12 (signals-error (count-if-not #'cons '(a b c)) program-error) t) (deftest count-if-not.error.13 (signals-error (count-if-not #'car '(a b c)) type-error) t) (deftest count-if-not.error.14 (signals-error (count-if-not #'identity '(a b c) :key #'cdr) type-error) t) (deftest count-if-not.error.15 (signals-error (count-if-not #'identity '(a b c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/expt.lsp0000644000000000000000000000013214542551762015151 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.485789153 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/expt.lsp0000644000175000017500000001222414542551762014550 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 2 19:36:22 2003 ;;;; Contains: Tests of EXPT (in-package :cl-test) ;;; Error tests (defun texpt (x y) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow t :floating-point-underflow t) (unwind-protect (expt x y) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow nil :floating-point-underflow nil))) (deftest expt.error.1 (signals-error (expt) program-error) t) (deftest expt.error.2 (signals-error (expt 1 1 1) program-error) t) (deftest expt.error.3 (signals-error (expt 1 1 nil nil) program-error) t) (deftest expt.error.4 (signals-error (texpt most-positive-short-float 2) floating-point-overflow) t) (deftest expt.error.5 (signals-error (texpt most-positive-single-float 2) floating-point-overflow) t) (deftest expt.error.6 (signals-error (texpt most-positive-double-float 2) floating-point-overflow) t) (deftest expt.error.7 (signals-error (texpt most-positive-long-float 2) floating-point-overflow) t) (deftest expt.error.8 (signals-error (texpt least-positive-short-float 2) floating-point-underflow) t) (deftest expt.error.9 (signals-error (texpt least-positive-single-float 2) floating-point-underflow) t) (deftest expt.error.10 (signals-error (texpt least-positive-double-float 2) floating-point-underflow) t) (deftest expt.error.11 (signals-error (texpt least-positive-long-float 2) floating-point-underflow) t) ;;; Non-error tests (deftest expt.1 (expt 0 0) 1) (deftest expt.2 (loop for i from -1000 to 1000 always (eql (expt i 0) 1)) t) (deftest expt.3 (loop for i = (random 1.0s3) repeat 1000 always (eql (expt i 0) 1.0s0)) t) (deftest expt.4 (loop for i = (random 1.0f6) repeat 1000 always (eql (expt i 0) 1.0f0)) t) (deftest expt.5 (loop for i = (random 1.0d10) repeat 1000 always (eql (expt i 0) 1.0d0)) t) (deftest expt.6 (loop for i = (random 1.0l10) repeat 1000 always (eql (expt i 0) 1.0l0)) t) (deftest expt.7 (loop for i from -1000 to 1000 for c = (complex i i) always (eql (expt c 0) 1)) t) (deftest expt.8 (loop for i = (random 1.0s3) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0s0 0.0s0))) t) (deftest expt.9 (loop for i = (random 1.0f6) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0f0 0.0f0))) t) (deftest expt.10 (loop for i = (random 1.0d10) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0d0 0.0d0))) t) (deftest expt.11 (loop for i = (random 1.0l10) for c = (complex i i) repeat 1000 always (eql (expt c 0) #c(1.0l0 0.0l0))) t) (deftest expt.12 (loop for x in *numbers* unless (or (floatp (realpart x)) (eql (expt x 1) x)) collect x) nil) (deftest expt.13 (loop for x in *rationals* unless (and (eql (expt x 2) (* x x)) (or (zerop x) (eql (expt x -1) (/ x)))) collect x) nil) (deftest expt.14 (expt #c(0 2) 2) -4) (deftest expt.15 (expt #c(1 1) 2) #c(0 2)) (deftest expt.16 (expt #c(1/2 1/3) 3) #c(-1/24 23/108)) (deftest expt.17 (expt #c(1 1) -2) #c(0 -1/2)) (deftest expt.18 (loop for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt i zero) (float 1 zero))))) t) (deftest expt.19 (loop for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt (float i 0.0s0) zero) (float 1 zero))))) t) (deftest expt.20 (loop for zero in '(0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt (float i 0.0f0) zero) (float 1 zero))))) t) (deftest expt.21 (loop for zero in '(0.0d0 0.0l0) always (loop for i from -1000 to 1000 always (or (zerop i) (eql (expt (float i 0.0d0) zero) (float 1 zero))))) t) (deftest expt.22 (expt 2.0f0 0.0s0) 1.0f0) (deftest expt.23 (expt 2.0d0 0.0s0) 1.0d0) (deftest expt.24 (expt 2.0l0 0.0s0) 1.0l0) (deftest expt.25 (expt 2.0d0 0.0f0) 1.0d0) (deftest expt.26 (expt 2.0l0 0.0f0) 1.0l0) (deftest expt.27 (expt 2.0l0 0.0d0) 1.0l0) (deftest expt.28 (<= (realpart (expt -8 1/3)) 0.0) nil) #| ;;; FIXME ;;; I need to think more about how to do approximate float ;;; equality in a principled way. (deftest expt.29 (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) for ebound in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for ebound2 = (max (* 2 ebound) (/ bound)) nconc (loop for x = (1+ (random 1.0f6)) for s1 = (sqrt x) for s2 = (expt x 1/2) for error = (/ (abs (- s2 s2)) x) repeat 1000 unless (< error ebound2) collect (list x s1 s2))) nil) (deftest expt.30 (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) for ebound in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for ebound2 = (max (* 2 ebound) (/ bound)) nconc (loop for x = (- (1+ (random 1.0f6))) for s1 = (sqrt x) for s2 = (expt x 1/2) for error = (/ (abs (- s2 s2)) x) repeat 1000 unless (< error ebound2) collect (list x s1 s2))) nil) |# gcl-2.7.1/ansi-tests/PaxHeaders/loop13.lsp0000644000000000000000000000013214542551763015307 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.485789153 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop13.lsp0000644000175000017500000002222614542551763014711 0ustar00cammcamm;-*- 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- (min call-arguments-limit 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.13.88 (macrolet ((%m (z) z)) (loop do (expand-in-current-env (%m (return 10))))) 10) (deftest loop.13.89 (macrolet ((%m (z) z)) (loop for i from 0 below 100 by 7 when (> i 50) return (expand-in-current-env (%m i)))) 56) (deftest loop.13.90 (macrolet ((%m (z) z)) (loop return (expand-in-current-env (%m 'a)))) a) gcl-2.7.1/ansi-tests/PaxHeaders/find-method.lsp0000644000000000000000000000013214542551762016367 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.485789153 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find-method.lsp0000644000175000017500000000715114542551762015771 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jun 3 21:12:03 2003 ;;;; Contains: Tests for FIND-METHOD (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric find-method-gf-01 (x))) (report-and-ignore-errors (defparameter *find-method-gf-01-method1* (defmethod find-method-gf-01 ((x integer)) 'a))) (report-and-ignore-errors (defparameter *find-method-gf-01-method2* (defmethod find-method-gf-01 ((x rational)) 'b))) (report-and-ignore-errors (defparameter *find-method-gf-01-method3* (defmethod find-method-gf-01 ((x real)) 'c))) (report-and-ignore-errors (defparameter *find-method-gf-01-method4* (defmethod find-method-gf-01 ((x t)) 'd))) ) (deftest find-method.1 (eqt (find-method #'find-method-gf-01 nil (list (find-class 'integer))) *find-method-gf-01-method1*) t) (deftest find-method.2 (eqt (find-method #'find-method-gf-01 nil (list (find-class 'rational))) *find-method-gf-01-method2*) t) (deftest find-method.3 (eqt (find-method #'find-method-gf-01 nil (list (find-class 'real))) *find-method-gf-01-method3*) t) (deftest find-method.4 (eqt (find-method #'find-method-gf-01 nil (list (find-class t))) *find-method-gf-01-method4*) t) (deftest find-method.5 (find-method #'find-method-gf-01 (list :around) (list (find-class t)) nil) nil) (deftest find-method.6 (find-method #'find-method-gf-01 (list :after) (list (find-class 'integer)) nil) nil) (deftest find-method.7 (find-method #'find-method-gf-01 (list :before) (list (find-class 'real)) nil) nil) ;;; EQL specializers (defgeneric find-method-gf-02 (x)) (defparameter *find-method-gf-02-method1* (defmethod find-method-gf-02 ((x (eql 1234567890))) 'a)) (defparameter *find-method-02-method2-value* (list 'a)) (defparameter *find-method-gf-02-method2* (defmethod find-method-gf-02 ((x (eql *find-method-02-method2-value*))) 'b)) (deftest find-method.8 (eqt (find-method #'find-method-gf-02 nil (list '(eql 1234567890))) *find-method-gf-02-method1*) t) (deftest find-method.9 (eqt (find-method #'find-method-gf-02 nil (list (list 'eql *find-method-02-method2-value*))) *find-method-gf-02-method2*) t) ;;; Error tests (deftest find-method.error.1 (signals-error (find-method) program-error) t) (deftest find-method.error.2 (signals-error (find-method #'find-method-gf-01) program-error) t) (deftest find-method.error.3 (signals-error (find-method #'find-method-gf-01 nil) program-error) t) (deftest find-method.error.4 (signals-error (find-method #'find-method-gf-01 nil (list (find-class 'integer)) nil nil) program-error) t) (deftest find-method.error.5 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'symbol))) (error () :error)) :error) (deftest find-method.error.6 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'symbol)) 'x) (error () :error)) :error) (deftest find-method.error.7 (handler-case (find-method #'find-method-gf-01 nil nil) (error () :error)) :error) (deftest find-method.error.8 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'integer) (find-class t))) (error () :error)) :error) (deftest find-method.error.9 (handler-case (find-method #'find-method-gf-01 nil nil nil) (error () :error)) :error) (deftest find-method.error.10 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'integer) (find-class t)) nil) (error () :error)) :error) gcl-2.7.1/ansi-tests/PaxHeaders/pathname-match-p.lsp0000644000000000000000000000013114542551763017315 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.485789153 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname-match-p.lsp0000644000175000017500000000517714542551763016726 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/position-if-not.lsp0000644000000000000000000000013114542551763017227 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.485789153 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/position-if-not.lsp0000644000175000017500000003363114542551763016634 0ustar00cammcamm;-*- 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) (deftest position-if-not-vector.14 (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (position-if-not #'symbolp v2) (position-if-not #'symbolp v2 :from-end t))) 2 6) ;;; 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-string.14 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if-not (complement #'alpha-char-p) s))) (assert (eql pos 5) () "First alpha char in ~A is at position ~A" s pos))) nil) (deftest position-if-not-string.15 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if-not (complement #'alpha-char-p) s :from-end t))) (assert (eql pos 11) () "Last alpha char in ~A is at position ~A" s pos))) nil) (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 (check-type-error #'(lambda (x) (position-if-not #'identity x)) #'sequencep) nil) (deftest position-if-not.error.4 (signals-error (position-if-not 'identity '(a b c . d)) type-error) t) (deftest position-if-not.error.5 (signals-error (position-if-not) program-error) t) (deftest position-if-not.error.6 (signals-error (position-if-not #'null) program-error) t) (deftest position-if-not.error.7 (signals-error (position-if-not #'null nil :key) program-error) t) (deftest position-if-not.error.8 (signals-error (position-if-not #'null nil 'bad t) program-error) t) (deftest position-if-not.error.9 (signals-error (position-if-not #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest position-if-not.error.10 (signals-error (position-if-not #'null nil 1 2) program-error) t) (deftest position-if-not.error.11 (signals-error (locally (position-if-not #'identity 'b) t) type-error) t) (deftest position-if-not.error.12 (signals-error (position-if-not #'cons '(a b c d)) program-error) t) (deftest position-if-not.error.13 (signals-error (position-if-not #'car '(a b c d)) type-error) t) (deftest position-if-not.error.14 (signals-error (position-if-not #'identity '(a b c d) :key #'cdr) type-error) t) (deftest position-if-not.error.15 (signals-error (position-if-not #'identity '(a b c d) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/if.lsp0000644000000000000000000000013114542551762014566 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.485789153 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/if.lsp0000644000175000017500000000252514542551762014171 0ustar00cammcamm;-*- 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))) ;;; Macros are expanded in the appropriate environment (deftest if.8 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m t)) :good :bad)) :good) (deftest if.9 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m nil)) :bad)) nil) (deftest if.10 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m t)) :good)) :good) (deftest if.11 (macrolet ((%m (z) z)) (if (expand-in-current-env (%m nil)) :bad :good)) :good) (deftest if.12 (macrolet ((%m (z) z)) (flet ((%f (x y) (if x (expand-in-current-env (%m y))))) (declare (notinline %f)) (values (%f t :good) (%f nil :bad)))) :good nil) (deftest if.13 (macrolet ((%m (z) z)) (flet ((%f (x y z) (if x y (expand-in-current-env (%m z))))) (declare (notinline %f)) (values (%f t :good :bad) (%f nil :bad :good)))) :good :good) (deftest if.order.1 (let ((i 0)) (values (if (= (incf i) 1) 't nil) i)) t 1) gcl-2.7.1/ansi-tests/PaxHeaders/packages-11.lsp0000644000000000000000000000013114542551763016166 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.485789153 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-11.lsp0000644000175000017500000000652214542551763015572 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/load-format.lsp0000644000000000000000000000013114772071552016374 xustar0029 mtime=1743287146.74690275 30 atime=1744294960.485789153 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-format.lsp0000644000175000017500000000174314772071552016000 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 2 21:47:02 2004 ;;;; Contains: Load format-related tests (in-package :cl-test) ;;; Format tests ;;; 22.3.1 (load "format-c.lsp") (load "formatter-c.lsp") (load "format-percent.lsp") (load "format-ampersand.lsp") (load "format-page.lsp") (load "format-tilde.lsp") ;;; 22.3.2 (load "format-r.lsp") (load "format-d.lsp") (load "format-b.lsp") (load "format-o.lsp") (load "format-x.lsp") ;;; 22.3.3 (load "format-f.lsp") ;;; 22.3.4 (load "format-a.lsp") (load "format-s.lsp") ;;; 22.3.5 (load "format-underscore.lsp") (load "format-logical-block.lsp") (load "format-i.lsp") (load "format-slash.lsp") ;;; 22.3.6 (load "format-t.lsp") (load "format-justify.lsp") ;;; 22.3.7 (load "format-goto.lsp") (load "format-conditional.lsp") (load "format-brace.lsp") (load "format-question.lsp") ;;; 22.3.8 (load "format-paren.lsp") (load "format-p.lsp") ;;; 22.3.9 (load "format-circumflex.lsp") (load "format-newline.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/doit2.lsp0000644000000000000000000000013214542551762015212 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.485789153 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/doit2.lsp0000644000175000017500000000130114542551762014603 0ustar00cammcamm#+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) #+lispworks (progn (rtest:disable-note :allow-nil-arrays) (rtest:disable-note :nil-vectors-are-strings)) (in-package :cl-test) ;;; These two tests will misbehave if the tests are being ;;; invoked from a file that is being loaded, so remove them (when *load-pathname* (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) (time (regression-test:do-tests)) #+allegro (cl-user::exit) #+(or cmu sbcl gcl armedbear) (cl-user::quit) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-structs.lsp0000644000000000000000000000013114542551763022253 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.485789153 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-structs.lsp0000644000175000017500000000442314542551763021655 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Random type prop tests: structures (in-package :cl-test) (defstruct rtpt-1 a b) (defmethod make-random-element-of-type ((type (eql 'rtpt-1))) (make-rtpt-1 :a (make-random-element-of-type t) :b (make-random-element-of-type t))) (defmethod replicate ((obj rtpt-1)) (or (gethash obj *replicate-table*) (let ((x (make-rtpt-1))) (setf (gethash obj *replicate-table*) x) (setf (rtpt-1-a x) (replicate (rtpt-1-a obj))) (setf (rtpt-1-b x) (replicate (rtpt-1-b obj))) x))) (defmethods make-random-type-containing* (1 ((val rtpt-1)) 'rtpt-1)) (def-type-prop-test structure-ref.1 'rtpt-1-a '(rtpt-1) 1) (def-type-prop-test copy-structure.1 'copy-structure '(rtpt-1) 1 :test #'equalp) (defstruct rtpt-2 a) (defstruct (rtpt-2.1 (:include rtpt-2)) c d) (defstruct (rtpt-2.2 (:include rtpt-2)) d e) (defmethod make-random-element-of-type ((type (eql 'rtpt-2))) (rcase (1 (make-rtpt-2 :a (make-random-element-of-type t))) (1 (make-random-element-of-type 'rtpt-2.1)) (1 (make-random-element-of-type 'rtpt-2.2)))) (defmethod make-random-element-of-type ((type (eql 'rtpt-2.1))) (make-rtpt-2.1 :a (make-random-element-of-type t) :c (make-random-element-of-type t) :d (make-random-element-of-type t))) (defmethod make-random-element-of-type ((type (eql 'rtpt-2.2))) (make-rtpt-2.2 :a (make-random-element-of-type t) :d (make-random-element-of-type t) :e (make-random-element-of-type t))) (defmethod replicate ((obj rtpt-2)) (replicate-with (obj x (make-rtpt-2)) (setf (rtpt-2-a x) (replicate (rtpt-2-a obj))))) (defmethod replicate ((obj rtpt-2.1)) (replicate-with (obj x (make-rtpt-2.1)) (setf (rtpt-2.1-a x) (replicate (rtpt-2.1-a obj))) (setf (rtpt-2.1-c x) (replicate (rtpt-2.1-c obj))) (setf (rtpt-2.1-d x) (replicate (rtpt-2.1-d obj))))) (defmethod replicate ((obj rtpt-2.2)) (replicate-with (obj x (make-rtpt-2.2)) (setf (rtpt-2.2-a x) (replicate (rtpt-2.2-a obj))) (setf (rtpt-2.2-d x) (replicate (rtpt-2.2-d obj))) (setf (rtpt-2.2-e x) (replicate (rtpt-2.2-e obj))))) (defmethods make-random-type-containing* (1 ((val rtpt-2)) 'rtpt-2) (1 ((val rtpt-2.1)) 'rtpt-2.1) (1 ((val rtpt-2.2)) 'rtpt-2.2)) (def-type-prop-test structure-ref.2 'rtpt-2-a '(rtpt-2) 1) gcl-2.7.1/ansi-tests/PaxHeaders/deposit-field.lsp0000644000000000000000000000013214542551762016721 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.489789171 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/deposit-field.lsp0000644000175000017500000000430014542551762016314 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:23:15 2003 ;;;; Contains: Tests of DEPOSIT-FIELD (in-package :cl-test) ;;; Error tests (deftest deposit-field.error.1 (signals-error (deposit-field) program-error) t) (deftest deposit-field.error.2 (signals-error (deposit-field 1) program-error) t) (deftest deposit-field.error.3 (signals-error (deposit-field 1 (byte 1 0)) program-error) t) (deftest deposit-field.error.4 (signals-error (deposit-field 1 (byte 1 0) 0 nil) program-error) t) ;;; Non-error tests (deftest deposit-field.1 (loop for pos = (random 32) for size = (random 32) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (deposit-field newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp i newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest deposit-field.2 (loop for pos = (random 1000) for size = (random 1000) for newbyte = (random (ash 1 (+ pos size))) for val = (random (1+ (random (ash 1 (+ pos size))))) for result = (deposit-field newbyte (byte size pos) val) repeat 100 unless (loop for i from 0 to (+ pos size) always (if (or (< i pos) (>= i (+ pos size))) (if (logbitp i val) (logbitp i result) (not (logbitp i result))) (if (logbitp i newbyte) (logbitp i result) (not (logbitp i result))))) collect (list pos size newbyte val result)) nil) (deftest deposit-field.3 (loop for x = (random-fixnum) for y = (random-fixnum) for pos = (random 32) repeat 100 always (= (deposit-field x (byte 0 pos) y) y)) t) (deftest deposit-field.4 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) for y = (random-from-interval bound) for pos = (random 200) repeat 100 always (= (deposit-field x (byte 0 pos) y) y))) t) (deftest deposit-field.5 (loop for i of-type fixnum from -1000 to 1000 always (eql (deposit-field -1 (byte 0 0) i) i)) t) gcl-2.7.1/ansi-tests/PaxHeaders/pushnew.lsp0000644000000000000000000000013114542551763015662 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.489789171 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pushnew.lsp0000644000175000017500000001441314542551763015264 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:28:35 2003 ;;;; Contains: Tests of PUSHNEW (in-package :cl-test) (compile-and-load "cons-aux.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.16 (let ((x '(1 2 3))) (values (pushnew 10 x :test #'<=) x)) (10 1 2 3) (10 1 2 3)) (deftest pushnew.17 (let ((x '(1 2 3))) (values (pushnew 10 x :test #'>) x)) (1 2 3) (1 2 3)) (deftest pushnew.18 (let ((x '(1 2 3))) (values (pushnew 10 x :test-not #'>) x)) (10 1 2 3) (10 1 2 3)) (deftest pushnew.19 (let ((x '(1 2 3))) (values (pushnew 10 x :test-not #'<=) x)) (1 2 3) (1 2 3)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest pushnew.20 (macrolet ((%m (z) z)) (let ((x nil)) (values (pushnew (expand-in-current-env (%m 1)) x) x))) (1) (1)) (deftest pushnew.21 (macrolet ((%m (z) z)) (let ((x nil)) (values (pushnew 1 (expand-in-current-env (%m x))) x))) (1) (1)) (deftest pushnew.22 (macrolet ((%m (z) z)) (let ((x '(a b))) (values (pushnew 1 x :test (expand-in-current-env (%m #'eql))) x))) (1 a b) (1 a b)) (deftest pushnew.23 (macrolet ((%m (z) z)) (let ((x '(1))) (values (pushnew 1 x :test-not (expand-in-current-env (%m #'eql))) x))) (1 1) (1 1)) (deftest pushnew.24 (macrolet ((%m (z) z)) (let ((x '(3))) (values (pushnew 1 x :key (expand-in-current-env (%m #'evenp))) x))) (3) (3)) (defharmless pushnew.test-and-test-not.1 (let ((x '(b c))) (pushnew 'a x :test #'eql :test-not #'eql))) (defharmless pushnew.test-and-test-not.2 (let ((x '(b c))) (pushnew 'a x :test-not #'eql :test #'eql))) (deftest pushnew.order.1 (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 pushnew.order.3 (let ((x '(a b c))) (values (pushnew (progn (setq x '(d e)) 'z) x) x)) (z d e) (z d e)) (deftest pushnew.error.1 (signals-error (let ((x '(a b))) (pushnew 'c x :test #'identity)) program-error) t) (deftest pushnew.error.2 (signals-error (let ((x '(a b))) (pushnew 'c x :test-not #'identity)) program-error) t) (deftest pushnew.error.3 (signals-error (let ((x '(a b))) (pushnew 'c x :key #'cons)) program-error) t) (def-macro-test pushnew.error.4 (pushnew x y)) gcl-2.7.1/ansi-tests/PaxHeaders/asinh.lsp0000644000000000000000000000013214542551762015273 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.489789171 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/asinh.lsp0000644000175000017500000000377014542551762014700 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:19:02 2004 ;;;; Contains: Tests of ASINH (in-package :cl-test) (deftest asinh.1 (let ((result (asinh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest asinh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (asinh zero)) (list zero)) collect type) nil) (deftest asinh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (asinh zero)) (list zero)) collect type) nil) (deftest asinh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (asinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest asinh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (asinh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest asinh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (asinh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) (deftest asinh.7 (macrolet ((%m (z) z)) (asinh (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest asinh.error.1 (signals-error (asinh) program-error) t) (deftest asinh.error.2 (signals-error (asinh 1.0 1.0) program-error) t) (deftest asinh.error.3 (check-type-error #'asinh #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/loop6.lsp0000644000000000000000000000013214542551763015231 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.489789171 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop6.lsp0000644000175000017500000001676614542551763014647 0ustar00cammcamm;-*- 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.6.41 (macrolet ((%m (z) z)) (loop for x being the hash-value of (expand-in-current-env (%m *loop.6.hash.1*)) sum x)) 6) (deftest loop.6.42 (macrolet ((%m (z) z)) (sort (loop for x being the hash-key of (expand-in-current-env (%m *loop.6.hash.1*)) collect x) #'symbol<)) (a b c)) ;;; Error tests (deftest loop.6.error.1 (signals-error (loop for k from 1 to 10 for k being the hash-keys of *loop.6.hash.1* count t) program-error) t) (deftest loop.6.error.2 (signals-error (loop for k being the hash-keys of *loop.6.hash.1* for k from 1 to 10 count t) program-error) t) (deftest loop.6.error.3 (signals-error (loop for (k . k) being the hash-keys of *loop.6.hash.3* count t) program-error) t) (deftest loop.6.error.4 (signals-error (loop for k being the hash-keys of *loop.6.hash.3* using (hash-value k) count t) program-error) t) (deftest loop.6.error.5 (signals-error (loop for k being the hash-values of *loop.6.hash.3* using (hash-key k) count t) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/dynamic-extent.lsp0000644000000000000000000000013214542551762017122 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.489789171 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/dynamic-extent.lsp0000644000175000017500000000634414542551762016527 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 09:10:52 2005 ;;;; Contains: Tests of DYNAMIC-EXTENT (in-package :cl-test) (deftest dynamic-extent.1 (let () (declare (dynamic-extent))) nil) (deftest dynamic-extent.2 (let ((x 'a)) (declare (dynamic-extent x) (optimize speed (safety 0))) x) a) (deftest dynamic-extent.3 (let ((x (list 'a 'b 'c))) (declare (dynamic-extent x) (optimize speed (safety 0))) (length x)) 3) (deftest dynamic-extent.4 (let ((x (vector 'a 'b 'c))) (declare (dynamic-extent x) (optimize speed (safety 0))) (length x)) 3) (deftest dynamic-extent.5 (flet ((%f (x) (list 'a x))) (declare (dynamic-extent (function %f)) (optimize speed (safety 0))) (mapcar #'%f '(1 2 3))) ((a 1) (a 2) (a 3))) (deftest dynamic-extent.6 (labels ((%f (x) (list 'a x))) (declare (dynamic-extent (function %f)) (optimize speed (safety 0))) (mapcar #'%f '(1 2 3))) ((a 1) (a 2) (a 3))) (deftest dynamic-extent.7 (labels ((%f (x) (if (consp x) (cons (%f (car x)) (%f (cdr x))) '*))) (declare (dynamic-extent (function %f)) (optimize speed (safety 0))) (mapcar #'%f '((1) 2 (3 4 5)))) ((* . *) * (* * * . *))) (deftest dynamic-extent.8 (let ((x (+ most-positive-fixnum 2))) (declare (dynamic-extent x) (optimize speed (safety 0))) (1- x)) #.(1+ most-positive-fixnum)) (deftest dynamic-extent.9 (flet ((f () (list 'a 'b))) (let ((f (list 'c 'd))) (declare (dynamic-extent (function f)) (optimize speed (safety 0))) f)) (c d)) (deftest dynamic-extent.10 (let ((x nil)) (values x (locally (declare (dynamic-extent x) (notinline length) (optimize speed (safety 0))) (setq x (list 'a 'b 'c 'd 'e)) (prog1 (length x) (setq x t))) x)) nil 5 t) (deftest dynamic-extent.11 (let* ((x (list 'a 'b)) (y (cons 'c x))) (declare (dynamic-extent y) (optimize speed (safety 0))) (cdr y)) (a b)) (deftest dynamic-extent.12 (let* ((contents '(1 0 0 1 1 0 1 1 0 1)) (n (length contents))) (loop for i from 1 to 32 for type = `(unsigned-byte ,i) for form1 = `(make-array '(,n) :initial-contents ',contents :element-type ',type) for form2 = `(let ((a ,form1)) (declare (dynamic-extent a)) (declare (type (simple-array ,type (,n)))) (declare (notinline coerce)) (declare (optimize speed (safety 0))) (equal (coerce a 'list) ',contents)) unless (funcall (compile nil `(lambda () ,form2))) collect i)) nil) (deftest dynamic-extent.13 (let ((s (make-string 10 :initial-element #\a))) (declare (dynamic-extent s) (optimize speed (safety 0))) (notnot (every #'(lambda (c) (eql c #\a)) s))) t) (deftest dynamic-extent.14 (let ((s (make-string 10 :initial-element #\a :element-type 'base-char))) (declare (dynamic-extent s) (notinline every) (optimize speed (safety 0))) (notnot (every #'(lambda (c) (eql c #\a)) s))) t) (deftest dynamic-extent.15 (flet (((setf %f) (x y) (setf (car y) x))) (declare (dynamic-extent #'(setf %f))) :good) :good) (deftest dynamic-extent.16 (labels (((setf %f) (x y) (setf (car y) x))) (declare (dynamic-extent #'(setf %f))) :good) :good) gcl-2.7.1/ansi-tests/PaxHeaders/pprint-indent.lsp0000644000000000000000000000013114542551763016764 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.489789171 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-indent.lsp0000644000175000017500000002325414542551763016371 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jul 3 08:50:40 2004 ;;;; Contains: Tests of PPRINT-INDENT (in-package :cl-test) (deftest pprint-indent.1 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-string-output-stream)) (pprint-indent :block 0)))) nil) (deftest pprint-indent.2 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-broadcast-stream)) (pprint-indent :current 0)))) nil) (deftest pprint-indent.3 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) (pprint-indent :current 10 s)))) nil) (deftest pprint-indent.4 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) (pprint-indent :block 1/2 s)))) nil) (deftest pprint-indent.5 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) (pprint-indent :block 0.1 s)))) nil) (deftest pprint-indent.6 (with-standard-io-syntax (let ((*print-pretty* nil)) (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) unless (equal (multiple-value-list (with-open-stream (s (make-string-output-stream)) (pprint-indent :block x s))) '(nil)) collect x))) nil) (deftest pprint-indent.7 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-broadcast-stream)) (pprint-indent :current 0 nil)))) nil) (deftest pprint-indent.8 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (os (make-string-output-stream)) (with-open-stream (is (make-string-input-stream "")) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-indent :current 0 t)))))) nil) ;;; Now test with pprint-logical-block ;;; :current (deftest pprint-indent.9 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|M| :stream os) (pprint-indent :current 3 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "M M") (deftest pprint-indent.10 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|M| :stream os) (pprint-indent :current 1 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "(M M)") (deftest pprint-indent.11 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|M| :stream os) (pprint-indent :current -1 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "(M M)") (deftest pprint-indent.12 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|M| :stream os) (pprint-indent :current -2.0 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) "(M M)") ;;; :block (deftest pprint-indent.13 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block 0 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.13a (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :prefix "(" :suffix ")") (write '|MMM| :stream os) (pprint-indent :block 0 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "(MMM MMMMM)") (deftest pprint-indent.14 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block 1 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.15 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block -1 os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.16 (loop for n in '(3.0s0 3.0f0 3.0d0 3.0l0) unless (string= (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|MMM| :stream os) (pprint-indent :block n os) (pprint-newline :mandatory os) (write '|MMMMM| :stream os))))) "MMM MMMMM") collect n) nil) ;;; *print-pretty* must be true for pprint-indent to have an effect (deftest pprint-indent.17 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|M| :stream os) (let ((*print-pretty* nil)) (pprint-indent :current 3 os)) (pprint-newline :mandatory os) (write '|M| :stream os))))) "M M") (deftest pprint-indent.18 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|)) (write '|M| :stream os) (let ((*print-pretty* nil)) (pprint-indent :block 3 os)) (pprint-newline :mandatory os) (write '|M| :stream os))))) "M M") ;;; indentation interaction with :per-line-prefix (deftest pprint-indent.19 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M| |M|) :per-line-prefix ">>>>") (write '|M| :stream os) (pprint-indent :block 2 os) (write #\Space :stream os) (write '|M| :stream os) (pprint-newline :mandatory os) (write '|M| :stream os))))) ">>>>M M >>>> M") (deftest pprint-indent.20 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M|) :per-line-prefix ">>>>") (write '|M| :stream os) (pprint-indent :block -1 os) (pprint-newline :mandatory os) (write '|M| :stream os))))) ">>>>M >>>>M") (deftest pprint-indent.21 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(|M| |M| |M| |M|) :per-line-prefix ">>>>") (write '|M| :stream os) (pprint-indent :block 3 os) (pprint-newline :mandatory os) (write '|M| :stream os) (pprint-indent :current -2 os) (pprint-newline :mandatory os) (write '|M| :stream os) (pprint-indent :current -5 os) (pprint-newline :mandatory os) (write '|M| :stream os) )))) ">>>>M >>>> M >>>> M >>>>M") ;;; In miser mode, indentation is ignored (deftest pprint-indent.22 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-miser-width* 200) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3) :prefix "(" :suffix ")") (write 1 :stream os) (pprint-indent :current 1 os) (pprint-newline :mandatory os) (write 2 :stream os) (pprint-indent :block 3 os) (pprint-newline :mandatory os) (write 3 :stream os))))) "(1 2 3)") ;;; TERPRI or printing newline characters does not invoke indentation (deftest pprint-indent.23 (with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100) (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3 4)) (pprint-indent :block 2 os) (write 1 :stream os) (terpri os) (write 2 :stream os) (write #\Newline :stream os) (write 3 :stream os) (pprint-newline :mandatory os) (write 4 :stream os))))) "1 2 3 4") ;;; Error cases (deftest pprint-indent.error.1 (signals-error (pprint-indent) program-error) t) (deftest pprint-indent.error.2 (signals-error (pprint-indent :current) program-error) t) (deftest pprint-indent.error.3 (signals-error (pprint-indent :block 0 *standard-output* nil) program-error) t) (deftest pprint-indent.error.4 (loop for x in *mini-universe* when (and (not (member x '(:block :current))) (not (eval `(signals-error (pprint-indent ',x 0) error)))) collect x) nil) (deftest pprint-indent.error.4-unsafe (loop for x in *mini-universe* when (and (not (member x '(:block :current))) (not (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-indent ',x 0)) error)))) collect x) nil) gcl-2.7.1/ansi-tests/PaxHeaders/make-instances-obsolete.lsp0000644000000000000000000000013214542551763020706 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.489789171 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-instances-obsolete.lsp0000644000175000017500000000301714542551763020305 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 08:12:35 2003 ;;;; Contains: Tests of MAKE-INSTANCES-OBSOLETE (in-package :cl-test) (defclass make-instances-obsolete-class-01 () ((a :initarg :a) (b :initarg :b :allocation :class) (c :initarg :c :initform 'abc) (d :initarg :d :type fixnum :initform 0))) (deftest make-instances-obsolete.1 (let* ((class-designator 'make-instances-obsolete-class-01) (class (find-class class-designator)) (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) (values (eqt (class-of obj) class) (map-slot-value obj '(a b c d)) (let ((val (make-instances-obsolete class))) (or (eqt val class-designator) (eqt val class))) (map-slot-value obj '(a b c d)))) t (x y z 17) t (x y z 17)) (deftest make-instances-obsolete.2 (let* ((class-designator 'make-instances-obsolete-class-01) (class (find-class class-designator)) (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) (values (eqt (class-of obj) class) (map-slot-value obj '(a b c d)) (let ((val (make-instances-obsolete class-designator))) (or (eqt val class-designator) (eqt val class))) (map-slot-value obj '(a b c d)))) t (x y z 17) t (x y z 17)) ;;; Error cases (deftest make-instances-obsolete.error.1 (signals-error (make-instances-obsolete) program-error) t) (deftest make-instances-obsolete.error.2 (signals-error (make-instances-obsolete (find-class 'make-instances-obsolete-class-01) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/pathname-device.lsp0000644000000000000000000000013114542551763017223 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.489789171 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname-device.lsp0000644000175000017500000000363614542551763016632 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/pathnames.lsp0000644000000000000000000000013114542551763016151 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.489789171 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathnames.lsp0000644000175000017500000000101014542551763015540 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/delete-package.lsp0000644000000000000000000000013214542551762017024 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.489789171 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/delete-package.lsp0000644000175000017500000001273514542551762016432 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:58 1998 ;;;; Contains: Tests of DELETE-PACKAGE (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) (declare (ignorable p1 p2 p3 s1 s2)) (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 (let ((outer-restarts (compute-restarts))) (handler-bind ((package-error #'(lambda (c) ;; (let ((r (find-restart 'continue c))) (and r (invoke-restart r))) (let ((my-restarts (remove 'abort (set-difference (compute-restarts c) outer-restarts) :key #'restart-name))) (assert my-restarts) (when (find 'continue my-restarts :key #'restart-name) (continue c)) (return t) )))) (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) (deftest delete-package.6 (block done (let ((outer-restarts (compute-restarts))) (safely-delete-package "TEST-20") (handler-bind ((package-error #'(lambda (c) (assert (set-difference (compute-restarts c) outer-restarts)) (return-from done :good)))) (delete-package "TEST-20")))) :good) ;;; Specialized sequences (defmacro def-delete-package-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (list (notnot (delete-package :test1)) (notnot (packagep p)) (package-name p)))) (t t nil))) (def-delete-package-test delete-package.7 (make-array '(5) :initial-contents "TEST1" :element-type 'base-char)) (def-delete-package-test delete-package.8 (make-array '(10) :initial-contents "TEST1XXXXX" :fill-pointer 5 :element-type 'base-char)) (def-delete-package-test delete-package.9 (make-array '(10) :initial-contents "TEST1XXXXX" :fill-pointer 5 :element-type 'character)) (def-delete-package-test delete-package.10 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-delete-package-test delete-package.11 (make-array '(5) :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-delete-package-test delete-package.12 (let* ((etype 'character) (name2 (make-array '(10) :initial-contents "XXXTEST1YY" :element-type etype))) (make-array '(5) :displaced-to name2 :displaced-index-offset 3 :element-type etype))) (def-delete-package-test delete-package.13 (let* ((etype 'base-char) (name2 (make-array '(10) :initial-contents "XXXTEST1YY" :element-type etype))) (make-array '(5) :displaced-to name2 :displaced-index-offset 3 :element-type etype))) ;;; Error tests (deftest delete-package.error.1 (signals-error (delete-package) program-error) t) (deftest delete-package.error.2 (progn (unless (find-package "TEST-DPE2") (make-package "TEST-DPE2" :use nil)) (signals-error (delete-package "TEST-DPE2" nil) program-error)) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-ampersand.lsp0000644000000000000000000000013214542551762017431 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.489789171 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-ampersand.lsp0000644000175000017500000000565014542551762017035 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 23:52:20 2004 ;;;; Contains: Tests of format with ~& directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.&.1 "~0&" nil "") (def-format-test format.&.2 "~&" nil "") (def-format-test format.&.3 "X~&" nil #.(concatenate 'string "X" (string #\Newline))) (def-format-test format.&.4 "X~%~&" nil #.(concatenate 'string "X" (string #\Newline))) (deftest format.&.5 (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for format-string = (format nil "~~~D&" i) for s2 = (format nil format-string) unless (string= s1 s2) collect i) nil) (deftest formatter.&.5 (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for format-string = (format nil "~~~D&" i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn) unless (string= s1 s2) collect i) nil) (deftest format.&.6 (loop for i from 1 to 100 for s1 = (concatenate 'string "X" (make-string i :initial-element #\Newline)) for format-string = (format nil "X~~~D&" i) for s2 = (format nil format-string) unless (string= s1 s2) collect i) nil) (deftest formatter.&.6 (loop for i from 1 to 100 for s1 = (concatenate 'string "X" (make-string i :initial-element #\Newline)) for format-string = (format nil "X~~~D&" i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn) unless (string= s1 s2) collect i) nil) (def-format-test format.&.7 "~v&" (nil) "") (def-format-test format.&.8 "X~v&" (nil) #.(concatenate 'string "X" (string #\Newline))) (deftest format.&.9 (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for s2 = (format nil "~V&" i) unless (string= s1 s2) collect i) nil) (deftest formatter.&.9 (let ((fn (formatter "~V&"))) (loop for i from 1 to 100 for s1 = (make-string (1- i) :initial-element #\Newline) for s2 = (formatter-call-to-string fn i) unless (string= s1 s2) collect i)) nil) (deftest format.&.10 (loop for i from 1 to (min (- call-arguments-limit 3) 100) for s1 = (make-string (1- i) :initial-element #\Newline) for args = (make-list i) for s2 = (apply #'format nil "~#&" args) unless (string= s1 s2) collect i) nil) (deftest formatter.&.10 (let ((fn (formatter "~#&"))) (loop for i from 1 to (min (- call-arguments-limit 3) 100) for s1 = (make-string (1- i) :initial-element #\Newline) for args = (loop for j below i collect j) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream args) args))) unless (string= s1 s2) collect i)) nil) (def-format-test format.&.11 "X~V%" (0) "X") (def-format-test format.&.12 "X~#%" nil "X") (def-format-test format.&.13 "X~#%" ('a 'b 'c) #.(let ((nl (string #\Newline))) (concatenate 'string "X" nl nl nl)) 3) gcl-2.7.1/ansi-tests/PaxHeaders/get-macro-character.lsp0000644000000000000000000000013114542551762020000 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.489789171 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/get-macro-character.lsp0000644000175000017500000000730714542551762017406 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 2 15:54:27 2005 ;;;; Contains: Tests of GET-MACRO-CHARACTER (in-package :cl-test) (compile-and-load "reader-aux.lsp") (def-syntax-test get-macro-character.1 (loop for c across "()';\"`,#" collect (let ((vals (multiple-value-list (get-macro-character c)))) (list (=t (length vals) 2) (or (notnot (functionp (car vals))) (and (symbolp (car vals)) (notnot (fboundp (car vals))))) (notnot (cadr vals))))) ((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t))) (def-syntax-test get-macro-character.2 (loop for c across (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "1234567890!@$%^&*_-+={[}]<>?/~") for (fn non-term-p) = (multiple-value-list (get-macro-character c)) unless (or (null fn) non-term-p) collect (list c fn non-term-p)) nil) (def-syntax-test get-macro-character.3 (loop for rt in (list nil *readtable* (copy-readtable)) collect (loop for c across "()';\"`,#" collect (let ((vals (multiple-value-list (get-macro-character c rt)))) (list (=t (length vals) 2) (or (notnot (functionp (car vals))) (and (symbolp (car vals)) (notnot (fboundp (car vals))))) (notnot (cadr vals)))))) (((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t)) ((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t)) ((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t)))) (def-syntax-test get-macro-character.4 (loop for rt in (list nil *readtable* (copy-readtable)) nconc (loop for c across (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "1234567890!@$%^&*_-+={[}]<>?/~") for (fn non-term-p) = (multiple-value-list (get-macro-character c rt)) unless (or (null fn) non-term-p) collect (list rt c fn non-term-p))) nil) ;;; Copying a readtable preserves the reader macros (def-syntax-test get-macro-character.5 (let ((rt (copy-readtable))) (loop for c across +standard-chars+ for (fn1 ntp1) = (multiple-value-list (get-macro-character c)) for (fn2 ntp2) = (multiple-value-list (get-macro-character c rt)) unless (and (or (not (symbolp fn1)) (not (symbolp fn2)) (eql fn1 fn2)) (if ntp1 ntp2 (not ntp2))) collect (list c fn1 ntp1 fn2 ntp2))) nil) (def-syntax-test get-macro-character.6 (let ((rt (copy-readtable))) (loop for i below (min 65536 char-code-limit) for c = (code-char i) for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) '(nil nil)) for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) '(nil nil)) unless (and (or (not (symbolp fn1)) (not (symbolp fn2)) (eql fn1 fn2)) (if ntp1 ntp2 (not ntp2))) collect (list c fn1 ntp1 fn2 ntp2))) nil) (def-syntax-test get-macro-character.7 (let ((rt (copy-readtable))) (loop for i = (random (min char-code-limit (ash 1 24))) for c = (code-char i) for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) '(nil nil)) for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) '(nil nil)) repeat 10000 unless (and (or (not (symbolp fn1)) (not (symbolp fn2)) (eql fn1 fn2)) (if ntp1 ntp2 (not ntp2))) collect (list c fn1 ntp1 fn2 ntp2))) nil) ;;; Error tests (deftest get-macro-character.error.1 (signals-error (get-macro-character) program-error) t) (deftest get-macro-character.error.2 (signals-error (get-macro-character #\; (copy-readtable) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/printer-control-vars.lsp0000644000000000000000000000013114542551763020303 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.489789171 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/printer-control-vars.lsp0000644000175000017500000000143414542551763017704 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 3 06:25:52 2004 ;;;; Contains: Tests of initial values of printer control variables (in-package :cl-test) (deftest print-base.init.1 *print-base* 10) (deftest print-radix.init.1 *print-radix* nil) (deftest print-case.init.1 *print-case* :upcase) (deftest print-circle.init.1 *print-circle* nil) (deftest print-escape.init.1 (notnot *print-escape*) t) (deftest print-gensym.init.1 (notnot *print-gensym*) t) (deftest print-level.init.1 *print-level* nil) (deftest print-length.init.1 *print-length* nil) (deftest print-lines.init.1 *print-lines* nil) (deftest print-readably.init.1 *print-readably* nil) (deftest print-right-margin.init.1 *print-right-margin* nil) gcl-2.7.1/ansi-tests/PaxHeaders/print-length.lsp0000644000000000000000000000013114542551763016604 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.493789188 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-length.lsp0000644000175000017500000000627614542551763016216 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 27 08:27:37 2004 ;;;; Contains: Tests involving *PRINT-LENGTH* (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-print-test print-length.1 '(1) "(...)" (*print-length* 0)) (def-print-test print-length.2 '(1) "(1)" (*print-length* nil)) (def-print-test print-length.3 '(1) "(1)" (*print-length* 1)) (def-print-test print-length.4 '(1 . 2) "(1 . 2)" (*print-length* 1)) (deftest print-length.5 (let ((x '(|A| |B| |C| |D| |E| |F|))) (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil)) (apply #'values (loop for i from 0 to 8 collect (let ((*print-length* i)) (write-to-string x))))))) "(...)" "(A ...)" "(A B ...)" "(A B C ...)" "(A B C D ...)" "(A B C D E ...)" "(A B C D E F)" "(A B C D E F)" "(A B C D E F)") (deftest print-length.6 (let ((x '(|A| |B| |C| |D| |E| |F| . |G|))) (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil)) (apply #'values (loop for i from 0 to 8 collect (let ((*print-length* i)) (write-to-string x))))))) "(...)" "(A ...)" "(A B ...)" "(A B C ...)" "(A B C D ...)" "(A B C D E ...)" "(A B C D E F . G)" "(A B C D E F . G)" "(A B C D E F . G)") (def-print-test print-length.7 '(1) "(1)" (*print-length* (1+ most-positive-fixnum))) (deftest print-length.8 (let ((x #(|A| |B| |C| |D| |E| |F|))) (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil)) (apply #'values (loop for i from 0 to 8 collect (let ((*print-length* i)) (write-to-string x))))))) "#(...)" "#(A ...)" "#(A B ...)" "#(A B C ...)" "#(A B C D ...)" "#(A B C D E ...)" "#(A B C D E F)" "#(A B C D E F)" "#(A B C D E F)") (def-print-test print-length.9 "A modest sentence with six words." "\"A modest sentence with six words.\"" (*print-length* 0)) (def-print-test print-length.10 #*00110101100011 "#*00110101100011" (*print-length* 0)) (defstruct print-length-struct foo) ;;; The next test tacitly assumes issue STRUCTURE-READ-PRINT-SYNTAX (deftest print-length.11 (let ((result (with-standard-io-syntax (let ((*print-case* :upcase) (*print-escape* nil) (*print-readably* nil) (*print-pretty* nil) (*print-length* nil) (*package* (find-package "CL-TEST")) (s (make-print-length-struct :foo 17))) (apply #'list (loop for i from 0 to 4 collect (let ((*print-length* i)) (write-to-string s)))))))) (if (member result '(("#S(...)" "#S(PRINT-LENGTH-STRUCT ...)" "#S(PRINT-LENGTH-STRUCT :FOO ...)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)") ("#S(PRINT-LENGTH-STRUCT ...)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)" "#S(PRINT-LENGTH-STRUCT :FOO 17)")) :test 'equal) :good result)) :good) gcl-2.7.1/ansi-tests/PaxHeaders/nsubst.lsp0000644000000000000000000000013114542551763015507 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.493789188 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nsubst.lsp0000644000175000017500000001066014542551763015111 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:49:58 2003 ;;;; Contains: Tests of NSUBST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest nsubst.10 (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (1 2 10 x x 4)) (deftest nsubst.11 (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (1 2 10 x x 4)) (defharmless nsubset.test-and-test-not.1 (nsubst 'a 'b (list 'a 'b 'c 'd 'e) :test #'eq :test-not #'eq)) (defharmless nsubset.test-and-test-not.2 (nsubst 'a 'b (list 'a 'b 'c 'd 'e) :test-not #'eq :test #'eq)) ;;; 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)) ;;; Error cases (deftest nsubst.error.1 (signals-error (nsubst) program-error) t) (deftest nsubst.error.2 (signals-error (nsubst 'a) program-error) t) (deftest nsubst.error.3 (signals-error (nsubst 'a 'b) program-error) t) (deftest nsubst.error.4 (signals-error (nsubst 'a 'b nil :foo nil) program-error) t) (deftest nsubst.error.5 (signals-error (nsubst 'a 'b nil :test) program-error) t) (deftest nsubst.error.6 (signals-error (nsubst 'a 'b nil 1) program-error) t) (deftest nsubst.error.7 (signals-error (nsubst 'a 'b nil :bad t :allow-other-keys nil) program-error) t) (deftest nsubst.error.8 (signals-error (nsubst 'a 'b (list 'a 'b) :test #'identity) program-error) t) (deftest nsubst.error.9 (signals-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity) program-error) t) (deftest nsubst.error.10 (signals-error (nsubst 'a 'b (list 'a 'b) :key #'equal) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/values-list.lsp0000644000000000000000000000013214542551763016442 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.493789188 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/values-list.lsp0000644000175000017500000000166614542551763016051 0ustar00cammcamm;-*- 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 (signals-error (values-list) program-error) t) (deftest values-list.error.2 (signals-error (values-list nil nil) program-error) t) (deftest values-list.error.3 (check-type-error #'values-list #'list) nil) (deftest values-list.error.4 (signals-error (values-list '(a b c . d)) type-error) t) (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.7.1/ansi-tests/PaxHeaders/identity.lsp0000644000000000000000000000013114542551762016021 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.493789188 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/identity.lsp0000644000175000017500000000124214542551762015417 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 23:21:11 2002 ;;;; Contains: Tests for IDENTITY (in-package :cl-test) (deftest identity.1 (check-predicate #'(lambda (x) (eqlt x (check-values (identity x))))) nil) (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 (signals-error (identity) program-error) t) (deftest identity.error.2 (signals-error (identity 'a 'a) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ceiling.lsp0000644000000000000000000000013014542551762015601 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.493789188 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ceiling.lsp0000644000175000017500000000734714542551762015214 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 19 06:50:44 2003 ;;;; Contains: Tests of CEILING (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "ceiling-aux.lsp") (deftest ceiling.error.1 (signals-error (ceiling) program-error) t) (deftest ceiling.error.2 (signals-error (ceiling 1.0 1 nil) program-error) t) ;;; (deftest ceiling.1 (ceiling.1-fn) nil) (deftest ceiling.2 (ceiling.2-fn) nil) (deftest ceiling.3 (ceiling.3-fn 2.0s4) nil) (deftest ceiling.4 (ceiling.3-fn 2.0f4) nil) (deftest ceiling.5 (ceiling.3-fn 2.0d4) nil) (deftest ceiling.6 (ceiling.3-fn 2.0l4) nil) (deftest ceiling.7 (ceiling.7-fn) nil) (deftest ceiling.8 (ceiling.8-fn) nil) (deftest ceiling.9 (ceiling.9-fn) nil) (deftest ceiling.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ceiling x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest ceiling.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ceiling (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest ceiling.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q (1+ i)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest ceiling.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ceiling x)) unless (and (eql q i) (eql r (- rrad 1))) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl-2.7.1/ansi-tests/PaxHeaders/pathname-version.lsp0000644000000000000000000000013114542551763017451 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.493789188 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname-version.lsp0000644000175000017500000000166114542551763017054 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/clear-input.lsp0000644000000000000000000000013014542551762016412 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.493789188 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/clear-input.lsp0000644000175000017500000000256714542551762016024 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/call-arguments-limit.lsp0000644000000000000000000000013014542551762020221 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.493789188 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/call-arguments-limit.lsp0000644000175000017500000000123514542551762017622 0ustar00cammcamm;-*- 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))) (equalt (apply #'list args) args)) t) (deftest call-arguments-limit.5 (< call-arguments-limit lambda-parameters-limit) nil) gcl-2.7.1/ansi-tests/PaxHeaders/next-method-p.lsp0000644000000000000000000000013114542551763016662 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.493789188 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/next-method-p.lsp0000644000175000017500000000333114542551763016261 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 31 08:04:45 2003 ;;;; Contains: Tests of NEXT-METHOD-P (in-package :cl-test) (defgeneric nmp-gf-01 (x) (:method ((x integer)) (notnot-mv (next-method-p))) (:method ((x number)) 'foo) (:method ((x symbol)) (next-method-p))) (deftest next-method-p.1 (nmp-gf-01 10) t) (deftest next-method-p.2 (nmp-gf-01 1.2) foo) (deftest next-method-p.3 (nmp-gf-01 'a) nil) (defgeneric nmp-gf-02 (x y) (:method ((x integer) (y symbol)) (notnot-mv (next-method-p))) (:method ((x number) (y (eql nil))) 'foo)) (deftest next-method-p.4 (nmp-gf-02 10 nil) t) (deftest next-method-p.5 (nmp-gf-02 10 'a) nil) (defgeneric nmp-gf-03 (x y) (:method ((x integer) (y symbol)) #'next-method-p) (:method ((x t) (y (eql nil))) (constantly 1))) (deftest next-method-p.6 (notnot-mv (funcall (the function (nmp-gf-03 10 nil)))) t) (deftest next-method-p.7 (funcall (nmp-gf-03 10 'a)) nil) (defgeneric nmp-gf-04 (x y)) (defmethod nmp-gf-04 ((x integer) (y symbol)) #'next-method-p) (defmethod nmp-gf-04 ((x t) (y (eql nil))) (constantly 2)) (deftest next-method-p.8 (notnot-mv (funcall (the function (nmp-gf-04 10 nil)))) t) (deftest next-method-p.9 (funcall (nmp-gf-04 10 'a)) nil) ;; With AROUND methods (defgeneric nmp-gf-05 (x)) (defmethod nmp-gf-05 :around ((x number)) (notnot-mv (next-method-p))) (defmethod nmp-gf-05 ((x integer)) 'foo) (deftest next-method-p.10 (nmp-gf-05 10) t) ;; Need to also test next-method-p in builtin method combinations ;;; Error tests (deftest next-method-p.error.1 (signals-error (progn (eval '(defmethod nmp-gf-06 ((x t)) (next-method-p nil))) (nmp-gf-06 nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/psetf.lsp0000644000000000000000000000013114542551763015312 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.493789188 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/psetf.lsp0000644000175000017500000002112714542551763014714 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:38:30 2003 ;;;; Contains: Tests of PSETF (in-package :cl-test) (deftest psetf.order.1 (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 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)) (deftest psetf.10 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetf *x* 6 *y* 15) *x* *y*)) 0 10 nil 6 15) (deftest psetf.11 (let ((*x* 0) (*y* 10)) (declare (special *x* *y*)) (values *x* *y* (psetf *x* *y* *y* *x*) *x* *y*)) 0 10 nil 10 0) (def-macro-test psetf.error.1 (psetf)) ;;; PSETF is a good testbed for finding conflicts in setf expansions ;;; These tests apply psetf to various accessors (deftest psetf.12 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (car x) 1 (car y) 2) (values x y)) (1 b) (2 d)) (deftest psetf.12a (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (first x) 1 (first y) 2) (values x y)) (1 b) (2 d)) (deftest psetf.13 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (cdr x) 1 (cdr y) 2) (values x y)) (a . 1) (c . 2)) (deftest psetf.13a (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (rest x) 1 (rest y) 2) (values x y)) (a . 1) (c . 2)) (deftest psetf.14 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (cadr x) 1 (cadr y) 2) (values x y)) (a 1) (c 2)) (deftest psetf.15 (let* ((x (list 'a 'b)) (y (list 'c 'd))) (psetf (cddr x) 1 (cddr y) 2) (values x y)) (a b . 1) (c d . 2)) (deftest psetf.16 (let* ((x (list (list 'a))) (y (list (list 'c)))) (psetf (caar x) 1 (caar y) 2) (values x y)) ((1)) ((2))) (deftest psetf.17 (let* ((x (list (list 'a))) (y (list (list 'c)))) (psetf (cdar x) 1 (cdar y) 2) (values x y)) ((a . 1)) ((c . 2))) ;;; TODO: c*r accessors with > 2 a/d ;;; TODO: third,...,tenth (deftest psetf.18 (let* ((x (vector 'a 'b)) (y (vector 'c 'd))) (psetf (aref x 0) 1 (aref y 0) 2) (values x y)) #(1 b) #(2 d)) (deftest psetf.18a (let* ((x (vector 'a 'b)) (y (vector 'c 'd))) (psetf (svref x 0) 1 (svref y 0) 2) (values x y)) #(1 b) #(2 d)) (deftest psetf.19 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100))) (psetf (bit x 1) 0 (bit x 2) 1 (bit y 4) 1 (bit y 0) 0) (values x y)) #*10100 #*01101) (deftest psetf.20 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij"))) (psetf (char x 1) #\X (char y 2) #\Y) (values x y)) "aXcde" "fgYij") (deftest psetf.21 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100))) (psetf (sbit x 1) 0 (sbit x 2) 1 (sbit y 4) 1 (sbit y 0) 0) (values x y)) #*10100 #*01101) (deftest psetf.22 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij"))) (psetf (schar x 1) #\X (schar y 2) #\Y) (values x y)) "aXcde" "fgYij") (deftest psetf.23 (let* ((x (copy-seq '(a b c d e))) (y (copy-seq '(f g h i j)))) (psetf (elt x 1) 'u (elt y 2) 'v) (values x y)) (a u c d e) (f g v i j)) (deftest psetf.24 (let ((x #b110110001) (y #b101001100)) (psetf (ldb (byte 5 1) x) #b10110 (ldb (byte 3 6) y) #b10) (values x y)) #b110101101 #b010001100) (deftest psetf.25 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar))) (psetf (fdefinition f1) fn1 (fdefinition f2) fn2) (values (funcall f1) (funcall f2))) :foo :bar) (deftest psetf.26 (let* ((a1 (make-array '(10) :fill-pointer 5)) (a2 (make-array '(20) :fill-pointer 7))) (psetf (fill-pointer a1) (1+ (fill-pointer a2)) (fill-pointer a2) (1- (fill-pointer a1))) (values (fill-pointer a1) (fill-pointer a2))) 8 4) (deftest psetf.27 (let* ((x (list 'a 'b 'c 'd)) (y (list 'd 'e 'f 'g)) (n1 1) (n2 2) (v1 :foo) (v2 :bar)) (psetf (nth n1 x) v1 (nth n2 y) v2) (values x y)) (a :foo c d) (d e :bar g)) (deftest psetf.28 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar))) (psetf (symbol-function f1) fn1 (symbol-function f2) fn2) (values (funcall f1) (funcall f2))) :foo :bar) (deftest psetf.29 (let* ((s1 (gensym)) (s2 (gensym)) (v1 :foo) (v2 :bar)) (psetf (symbol-value s1) v1 (symbol-value s2) v2) (values (symbol-value s1) (symbol-value s2))) :foo :bar) (deftest psetf.30 (let* ((s1 (gensym)) (s2 (gensym)) (v1 (list :foo 1)) (v2 (list :bar 2))) (psetf (symbol-plist s1) v1 (symbol-plist s2) v2) (values (symbol-plist s1) (symbol-plist s2))) (:foo 1) (:bar 2)) (deftest psetf.31 (let* ((x (list 'a 'b 'c 'd 'e)) (y (list 'f 'g 'h 'i 'j)) (v1 (list 1 2)) (v2 (list 3 4 5)) (p1 1) (p2 2) (l1 (length v1)) (l2 (length v2))) (psetf (subseq x p1 (+ p1 l1)) v1 (subseq y p2 (+ p2 l2)) v2) (values x y)) (a 1 2 d e) (f g 3 4 5)) (deftest psetf.32 (let* ((x (gensym)) (y (gensym)) (k1 :foo) (k2 :bar) (v1 1) (v2 2)) (psetf (get x k1) v1 (get y k2) v2) (values (symbol-plist x) (symbol-plist y))) (:foo 1) (:bar 2)) (deftest psetf.33 (let* ((x nil) (y nil) (k1 :foo) (k2 :bar) (v1 1) (v2 2)) (psetf (getf x k1) v1 (getf y k2) v2) (values x y)) (:foo 1) (:bar 2)) (deftest psetf.34 (let* ((ht1 (make-hash-table)) (ht2 (make-hash-table)) (k1 :foo) (v1 1) (k2 :bar) (v2 2)) (psetf (gethash k1 ht1) v1 (gethash k2 ht2) v2) (values (gethash k1 ht1) (gethash k2 ht2))) 1 2) (deftest psetf.35 (let ((n1 (gensym)) (n2 (gensym)) (n3 (gensym)) (n4 (gensym))) (eval `(defclass ,n1 () ())) (eval `(defclass ,n2 () ())) (psetf (find-class n3) (find-class n1) (find-class n4) (find-class n2)) (values (eqlt (find-class n1) (find-class n3)) (eqlt (find-class n2) (find-class n4)))) t t) (deftest psetf.36 (let ((fn1 (constantly :foo)) (fn2 (constantly :bar)) (n1 (gensym)) (n2 (gensym))) (psetf (macro-function n1) fn1 (macro-function n2) fn2) (values (eval `(,n1)) (eval `(,n2)))) :foo :bar) (deftest psetf.37 (let ((b1 (byte 3 1)) (b2 (byte 4 2)) (x #b1100101011010101) (y #b11010101000110) (m1 #b101010101101101) (m2 #b11110010110101)) (psetf (mask-field b1 x) m1 (mask-field b2 y) m2) (values x y)) #b1100101011011101 #b11010101110110) (deftest psetf.38 (let* ((a1 (make-array '(2 3) :initial-contents '((a b c)(d e f)))) (a2 (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12)))) (i1 2) (i2 5) (v1 'u) (v2 'v)) (psetf (row-major-aref a1 i1) v1 (row-major-aref a2 i2) v2) (values a1 a2)) #2a((a b u)(d e f)) #2a((1 2 3 4)(5 v 7 8)(9 10 11 12))) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest psetf.39 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (psetf (expand-in-current-env (%m x)) y y x) x y))) nil 2 1) (deftest psetf.40 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (psetf x (expand-in-current-env (%m y)) y x) x y))) nil 2 1) ;;; TODO: logical-pathname-translations, readtable-case gcl-2.7.1/ansi-tests/PaxHeaders/nset-difference.lsp0000644000000000000000000000013114542551763017232 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.493789188 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nset-difference.lsp0000644000175000017500000001673214542551763016642 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:44:44 2003 ;;;; Contains: Tests of NSET-DIFFERENCE (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless nset-difference.test-and-test-not.1 (nset-difference (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless nset-difference.test-and-test-not.2 (nset-difference (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (nset-difference) program-error) t) (deftest nset-difference.error.2 (signals-error (nset-difference nil) program-error) t) (deftest nset-difference.error.3 (signals-error (nset-difference nil nil :bad t) program-error) t) (deftest nset-difference.error.4 (signals-error (nset-difference nil nil :key) program-error) t) (deftest nset-difference.error.5 (signals-error (nset-difference nil nil 1 2) program-error) t) (deftest nset-difference.error.6 (signals-error (nset-difference nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nset-difference.error.7 (signals-error (nset-difference (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest nset-difference.error.8 (signals-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest nset-difference.error.9 (signals-error (nset-difference (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest nset-difference.error.10 (signals-error (nset-difference (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest nset-difference.error.11 (signals-error (nset-difference (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest nset-difference.error.12 (signals-error (nset-difference (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nset-difference.error.13 (check-type-error #'(lambda (x) (nset-difference (list 'a 'b) x)) #'listp) nil) (deftest nset-difference.error.14 (check-type-error #'(lambda (x) (nset-difference x (list 'a 'b))) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/proclaim.lsp0000644000000000000000000000013114542551763015777 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.493789188 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/proclaim.lsp0000644000175000017500000000270414542551763015401 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 07:33:53 2005 ;;;; Contains: Tests of PROCLAIM (in-package :cl-test) (deftest proclaim.1 (let ((sym (gensym))) (proclaim `(special ,sym)) (eval `(flet ((%f () ,sym)) (let ((,sym :good)) (%f))))) :good) (deftest proclaim.2 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (proclaim `(,sym)) nil) nil) (deftest proclaim.3 (let ((i 0)) (proclaim (progn (incf i) '(optimize))) i) 1) ;;; Error cases (deftest proclaim.error.1 (signals-error (proclaim) program-error) t) (deftest proclaim.error.2 (signals-error (proclaim '(optimize) nil) program-error) t) (deftest proclaim.error.3 (signals-error (proclaim `(optimize . foo)) error) t) (deftest proclaim.error.4 (signals-error (proclaim `(inline . foo)) error) t) (deftest proclaim.error.5 (signals-error (proclaim `(notinline . foo)) error) t) (deftest proclaim.error.6 (signals-error (proclaim `(type . foo)) error) t) (deftest proclaim.error.7 (signals-error (proclaim `(ftype . foo)) type-error) t) (deftest proclaim.error.8 (signals-error (proclaim '(type integer . foo)) error) t) (deftest proclaim.error.9 (signals-error (proclaim '(integer . foo)) error) t) (deftest proclaim.error.10 (signals-error (proclaim '(declaration . foo)) error) t) (deftest proclaim.error.11 (signals-error (proclaim '(ftype (function (t) t) . foo)) error) t) gcl-2.7.1/ansi-tests/PaxHeaders/with-accessors.lsp0000644000000000000000000000013214542551763017130 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.497789206 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-accessors.lsp0000644000175000017500000000671714542551763016541 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 17:07:29 2003 ;;;; Contains: Tests of WITH-ACCESSORS (in-package :cl-test) (deftest with-accessors.1 (with-accessors () nil) nil) (deftest with-accessors.2 (with-accessors () nil (values))) (deftest with-accessors.3 (with-accessors () nil (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest with-accessors.4 (let (x y z) (with-accessors () (setf x 1) (setf y 5) (setf z 12) (values x y z))) 1 5 12) ;; with-accessors defines an implicit progn, not a tagbody (deftest with-accessors.5 (block done (tagbody (with-accessors nil nil (go 10) 10 (return-from done :bad)) 10 (return-from done :good))) :good) (defclass with-accessors-class-01 () ((a :initarg :a :accessor wa-a) (b :initarg :b :accessor wa-b) (c :initarg :c :accessor wa-c))) (deftest with-accessors.6 (let ((obj (make-instance 'with-accessors-class-01 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values a b c))) x y z) (deftest with-accessors.7 (let ((obj (make-instance 'with-accessors-class-01))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values (setf a 'x) (setf b 'y) (setf c 'z) (map-slot-value obj '(a b c))))) x y z (x y z)) (deftest with-accessors.8 (let ((obj (make-instance 'with-accessors-class-01))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values (setq a 'x) (setq b 'y) (setq c 'z) (map-slot-value obj '(a b c))))) x y z (x y z)) (deftest with-accessors.9 (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (values (incf a 4) (incf b 412) (incf c 75) (map-slot-value obj '(a b c))))) 9 431 387 (9 431 387)) (deftest with-accessors.10 (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (declare (optimize (speed 3) (safety 3))) (values a b c))) 5 19 312) (deftest with-accessors.11 (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) (with-accessors ((a wa-a) (b wa-b) (c wa-c)) obj (declare (optimize (speed 3) (safety 3))) (declare (special *x*)) ;; not used (values a b c))) 5 19 312) ;;; with-accessors on structure accessors (defstruct (with-accessors-struct-02 (:conc-name "WA-2-")) a b c) (deftest with-accessors.12 (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) obj (values a b c))) x y z) (deftest with-accessors.13 (let ((obj (make-with-accessors-struct-02))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) obj (values (setf a 'x) (setf b 'y) (setf c 'z) (wa-2-a obj) (wa-2-b obj) (wa-2-c obj)))) x y z x y z) ;;; Free declaration scope test (deftest with-accessors.14 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-accessors nil (return-from done x) (declare (special x)))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest with-accessors.15 (macrolet ((%m (z) z)) (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) (expand-in-current-env (%m obj)) (values a b c)))) x y z) gcl-2.7.1/ansi-tests/PaxHeaders/find-package.lsp0000644000000000000000000000013214542551762016502 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.497789206 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find-package.lsp0000644000175000017500000000662414542551762016110 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:50:39 1998 ;;;; Contains: Tests for FIND-PACKAGE (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 (progn (set-up-packages) (let ((p (ignore-errors (find-package "A")))) (if (packagep p) t p))) t) (deftest find-package.5 (progn (set-up-packages) (let ((p (ignore-errors (find-package #\A)))) (if (packagep p) t p))) t) (deftest find-package.6 (progn (set-up-packages) (let ((p (ignore-errors (find-package "B")))) (if (packagep p) t p))) t) (deftest find-package.7 (progn (set-up-packages) (let ((p (ignore-errors (find-package #\B)))) (if (packagep p) t p))) t) (deftest find-package.8 (progn (set-up-packages) (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 (progn (set-up-packages) (let ((p (ignore-errors (find-package "A"))) (p2 (ignore-errors (find-package "B")))) (eqt p p2))) nil) (deftest find-package.10 (progn (set-up-packages) (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.12 (let* ((name (make-array '(7) :initial-contents "KEYWORD" :element-type 'base-char)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.13 (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" :fill-pointer 7 :element-type 'base-char)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.14 (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" :fill-pointer 7 :element-type 'character)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.15 (let* ((name0 (make-array '(10) :initial-contents "XYKEYWORDZ" :element-type 'character)) (name (make-array '(7) :displaced-to name0 :displaced-index-offset 2 :element-type 'character)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.16 (let* ((name (make-array '(7) :initial-contents "KEYWORD" :adjustable t :element-type 'base-char)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.17 (let* ((name (make-array '(7) :initial-contents "KEYWORD" :adjustable t :element-type 'character)) (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) ;;; Error tests (deftest find-package.error.1 (signals-error (find-package) program-error) t) (deftest find-package.error.2 (signals-error (find-package "CL" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/clrhash.lsp0000644000000000000000000000013014542551762015613 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.497789206 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/clrhash.lsp0000644000175000017500000000305514542551762015216 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 09:33:40 2003 ;;;; Contains: Tests of CLRHASH (in-package :cl-test) (deftest clrhash.1 (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.2 (let ((table (make-hash-table :test 'eq))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.3 (let ((table (make-hash-table :test 'equal))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.4 (let ((table (make-hash-table :test 'equalp))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) (deftest clrhash.5 (let ((table (make-hash-table :test 'eql))) (setf (gethash 'a table) 'b) (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) (list table)) (hash-table-count table))) 1 t 0) ;;; (deftest clrhash.error.1 (signals-error (clrhash) program-error) t) (deftest clrhash.error.2 (signals-error (clrhash (make-hash-table) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/substitute-if-not.lsp0000644000000000000000000000013114542551763017576 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.497789206 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/substitute-if-not.lsp0000644000175000017500000006526214542551763017210 0ustar00cammcamm;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x) x)) #() #()) (deftest substitute-if-not-vector.2 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest substitute-if-not-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b c d a b c d a b c d)) (deftest substitute-if-not-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b c d a b c d)) ;;; Tests on strings (deftest substitute-if-not-string.1 (let ((x "")) (values (substitute-if-not #\b (is-not-eql-p #\a) x) x)) "" "") (deftest substitute-if-not-string.2 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-not-string.3 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-not-string.4 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-not-string.5 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-not-string.6 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-not-string.7 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-not-string.8 (let ((x "")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-not-string.9 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-not-string.26 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s) "xyz!bcxyz!bc")) (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s :count 1) "xyz!bcxyzabc")) (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyzabc"))) nil) (deftest substitute-if-not-bitstring.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if-not 1 (is-not-eql-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-eql-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)) ;;; Constant folding tests (def-fold-test substitute-if-not.fold.1 (substitute-if-not 'z 'identity '(a nil b))) (def-fold-test substitute-if-not.fold.2 (substitute-if-not 'z 'identity #(a nil b))) (def-fold-test substitute-if-not.fold.3 (substitute-if-not 0 'zerop #*100110)) (def-fold-test substitute-if-not.fold.4 (substitute-if-not #\0 #'digit-char-p "asdaw82213nn1239123dd")) ;;; Error cases (deftest substitute-if-not.error.1 (signals-error (substitute-if-not) program-error) t) (deftest substitute-if-not.error.2 (signals-error (substitute-if-not 'a) program-error) t) (deftest substitute-if-not.error.3 (signals-error (substitute-if-not 'a #'null) program-error) t) (deftest substitute-if-not.error.4 (signals-error (substitute-if-not 'a #'null nil 'bad t) program-error) t) (deftest substitute-if-not.error.5 (signals-error (substitute-if-not 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest substitute-if-not.error.6 (signals-error (substitute-if-not 'a #'null nil :key) program-error) t) (deftest substitute-if-not.error.7 (signals-error (substitute-if-not 'a #'null nil 1 2) program-error) t) (deftest substitute-if-not.error.8 (signals-error (substitute-if-not 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest substitute-if-not.error.9 (signals-error (substitute-if-not 'a #'car (list 'a 'b 'c)) type-error) t) (deftest substitute-if-not.error.10 (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest substitute-if-not.error.11 (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest substitute-if-not.error.12 (check-type-error #'(lambda (x) (substitute-if-not 'a #'not x)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/slot-exists-p.lsp0000644000000000000000000000013214542551763016725 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.497789206 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/slot-exists-p.lsp0000644000175000017500000001167314542551763016333 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 10 09:39:01 2003 ;;;; Contains: Tests of SLOT-EXISTS-P (in-package :cl-test) ;;; This function is also tested incidentally in many other files (defclass slot-exists-p-class-01 () (a (b :allocation :class) (c :allocation :instance))) (deftest slot-exists-p.1 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'a))) t) (deftest slot-exists-p.2 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'b))) t) (deftest slot-exists-p.3 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'c))) t) (deftest slot-exists-p.4 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj 'd)) nil) (deftest slot-exists-p.5 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj (gensym))) nil) (deftest slot-exists-p.6 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj nil)) nil) (deftest slot-exists-p.7 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (slot-exists-p obj t)) nil) ;;; SLOT-EXISTS-P may be called on any object, not just on standard objects (deftest slot-exists-p.8 (let ((slot-name (gensym))) (check-predicate #'(lambda (x) (not (slot-exists-p x slot-name))))) nil) ;;; With various types (defclass slot-exists-p-class-02 () ((a :type t) (b :type nil) (c :type symbol) (d :type cons) (e :type float) (f :type single-float) (g :type short-float) (h :type double-float) (i :type long-float) (j :type character) (k :type base-char) (l :type rational) (m :type ratio) (n :type integer) (o :type fixnum) (p :type complex) (q :type condition))) (deftest slot-exists-p.9 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-02)))) (map-slot-exists-p* obj '(a b c d e f g h i j k l m n o p q))) (t t t t t t t t t t t t t t t t t)) ;;; Inheritance (defclass slot-exists-p-class-03a () (a b)) (defclass slot-exists-p-class-03b () (a c)) (defclass slot-exists-p-class-03c (slot-exists-p-class-03a slot-exists-p-class-03b) (d e)) (deftest slot-exists-p.10 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-03c)))) (map-slot-exists-p* obj '(a b c d e f g))) (t t t t t nil nil)) ;;; SLOT-EXISTS-P is supposed to work on structure objects and condition objects (defstruct slot-exists-p-struct-01 a b c) (deftest slot-exists-p.11 (let ((obj (make-slot-exists-p-struct-01))) (map-slot-exists-p* obj '(a b c z nil))) (t t t nil nil)) (deftest slot-exists-p.12 (let ((obj (make-slot-exists-p-struct-01 :a 1 :b 2 :c 3))) (map-slot-exists-p* obj '(a b c z nil))) (t t t nil nil)) (defstruct (slot-exists-p-struct-02 (:include slot-exists-p-struct-01)) d e) (deftest slot-exists-p.13 (let ((obj (make-slot-exists-p-struct-02))) (map-slot-exists-p* obj '(a b c d e f z nil))) (t t t t t nil nil nil)) (deftest slot-exists-p.14 (let ((obj (make-slot-exists-p-struct-02 :a 1 :b 3 :e 5))) (map-slot-exists-p* obj '(a b c d e f z nil))) (t t t t t nil nil nil)) ;;; SLOT-EXISTS-P is supposed to work on condition objects, too ;;; (after all, they are objects, and they have slots) (define-condition slot-exists-p-condition-01 () ((a) (b) (c))) (deftest slot-exists-p.15 (let ((obj (make-condition 'slot-exists-p-condition-01))) (map-slot-exists-p* obj (list 'a 'b 'c (gensym)))) (t t t nil)) (define-condition slot-exists-p-condition-02 (slot-exists-p-condition-01) ((a) (d) (e))) (deftest slot-exists-p.16 (let ((obj (make-condition 'slot-exists-p-condition-02))) (map-slot-exists-p* obj (list 'a 'b 'c 'd 'e (gensym)))) (t t t t t nil)) ;;; Order of evaluation tests (deftest slot-exists-p.order.1 (let ((i 0) x y) (values (slot-exists-p (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) (gensym))) i x y)) nil 2 1 2) (deftest slot-exists-p.order.2 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) (i 0) x y) (values (notnot (slot-exists-p (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a))) i x y)) t 2 1 2) (deftest slot-exists-p.order.3 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) (i 0) x y) (values (notnot (slot-exists-p (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'b))) i x y)) t 2 1 2) ;;; Errors tests (deftest slot-exists-p.error.1 (signals-error (slot-exists-p) program-error) t) (deftest slot-exists-p.error.2 (signals-error (slot-exists-p 'a) program-error) t) (deftest slot-exists-p.error.3 (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01)) program-error) t) (deftest slot-exists-p.error.4 (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01) 'a nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-18.lsp0000644000000000000000000000013214542551762016336 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.497789206 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-18.lsp0000644000175000017500000001556214542551762015745 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/read-suppress.lsp0000644000000000000000000000013114542551763016766 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.497789206 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-suppress.lsp0000644000175000017500000002666714542551763016406 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 15 13:55:27 2005 ;;;; Contains: Tests of reading with *READ-SUPPRESS* bound to true (in-package :cl-test) (compile-and-load "reader-aux.lsp") (defmacro def-read-suppress-test (name string) `(def-syntax-test ,name (let ((*read-suppress* t)) (read-from-string ,string)) nil ,(length string))) (def-read-suppress-test read-suppress.1 "NONEXISTENT-PACKAGE::FOO") (def-read-suppress-test read-suppress.2 ":") (def-read-suppress-test read-suppress.3 "::") (def-read-suppress-test read-suppress.4 ":::") (def-read-suppress-test read-suppress.5 "123.45") ;; (def-read-suppress-test read-suppress.6 ".") (def-read-suppress-test read-suppress.7 "..") (def-read-suppress-test read-suppress.8 "...") (def-read-suppress-test read-suppress.9 "(1 2)") (def-read-suppress-test read-suppress.10 "(1 . 2)") (def-read-suppress-test read-suppress.11 "(1 .. 2 . 3)") (def-read-suppress-test read-suppress.12 "(...)") (defparameter *non-macro-chars* "1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ-=+_~!@$%^&*{}[]<>/?.") (declaim (type simple-base-string *non-macro-chars*)) (defmacro def-random-suppress-test (name &key (chars '*non-macro-chars*) (reps 1000) (maxlen 8) (count 10) (prefix "") (suffix "")) `(def-syntax-test ,name (let* ((chars ,chars) (prefix ,prefix) (suffix ,suffix) (*read-suppress* t) (count 0) (maxlen ,maxlen) (reps ,reps) (maxcount ,count)) (loop for n = (1+ (random maxlen)) for s = (concatenate 'string prefix (loop repeat n collect (random-from-seq chars)) suffix) for vals = (multiple-value-list (handler-case (read-from-string s) (reader-error (rc) rc))) repeat reps unless (equal vals (list nil (length s))) collect (progn (when (> (incf count) maxcount) (loop-finish)) (list n s vals)))) nil)) (def-random-suppress-test read-suppress.13) (def-random-suppress-test read-suppress.14 :prefix "(" :suffix ")") (def-random-suppress-test read-suppress.15 :prefix "#(" :suffix ")") (def-random-suppress-test read-suppress.16 :chars "0123456789.eEfFsSdDlL+-") (def-read-suppress-test read-suppress.sharp-slash.1 "#\\boguscharname") (def-read-suppress-test read-suppress.sharp-slash.2 "#\\:x") (def-read-suppress-test read-suppress.sharp-slash.3 "#\\::::") (def-read-suppress-test read-suppress.sharp-slash.4 "#\\123") (def-read-suppress-test read-suppress.sharp-slash.5 "#0\\ ") (def-read-suppress-test read-suppress.sharp-slash.6 "#100000000\\Space") (def-read-suppress-test read-suppress.sharp-quote.1 "#'foo") (def-read-suppress-test read-suppress.sharp-quote.2 "#'1") (def-read-suppress-test read-suppress.sharp-quote.3 "#'(setf bar)") (def-read-suppress-test read-suppress.sharp-quote.5 "#'.") (def-read-suppress-test read-suppress.sharp-quote.6 "#'1.2.3") (def-read-suppress-test read-suppress.sharp-quote.7 "#0'F") (def-read-suppress-test read-suppress.sharp-quote.8 "#1000000'F") (def-read-suppress-test read-suppress.sharp-left-paren.1 "#()") (def-read-suppress-test read-suppress.sharp-left-paren.2 "#(A)") (def-read-suppress-test read-suppress.sharp-left-paren.3 "#(A B)") (def-read-suppress-test read-suppress.sharp-left-paren.4 "#0()") (def-read-suppress-test read-suppress.sharp-left-paren.5 "#0(A)") (def-read-suppress-test read-suppress.sharp-left-paren.6 "#1(A)") (def-read-suppress-test read-suppress.sharp-left-paren.7 "#1(A B C D E)") (def-read-suppress-test read-suppress.sharp-left-paren.8 "#4(A B C D E)") (def-read-suppress-test read-suppress.sharp-left-paren.9 "#10(A B C D E)") (def-read-suppress-test read-suppress.sharp-left-paren.10 "#100()") (def-read-suppress-test read-suppress.sharp-left-paren.11 "#10000000000000()") (def-read-suppress-test read-suppress.sharp-left-paren.12 "#10000000000000(A)") (def-read-suppress-test read-suppress.sharp-asterisk.1 "#*") (def-read-suppress-test read-suppress.sharp-asterisk.2 "#0*") (def-read-suppress-test read-suppress.sharp-asterisk.3 "#*1") (def-read-suppress-test read-suppress.sharp-asterisk.4 "#*0111001") (def-read-suppress-test read-suppress.sharp-asterisk.5 "#*73298723497132") (def-read-suppress-test read-suppress.sharp-asterisk.6 "#*abcdefghijklmnopqrstuvwxyz") (def-read-suppress-test read-suppress.sharp-asterisk.7 "#*ABCDEFGHIJKLMNOPQRSTUVWXYZ") (def-read-suppress-test read-suppress.sharp-asterisk.8 "#*:") (def-read-suppress-test read-suppress.sharp-asterisk.9 "#*::::") (def-read-suppress-test read-suppress.sharp-asterisk.10 "#1*") (def-read-suppress-test read-suppress.sharp-asterisk.11 "#10000*") (def-read-suppress-test read-suppress.sharp-asterisk.12 "#10000000000000*") (def-read-suppress-test read-suppress.sharp-asterisk.13 "#4*001101001") (def-read-suppress-test read-suppress.sharp-asterisk.14 "#2*") (def-read-suppress-test read-suppress.sharp-colon.1 "#:1") (def-read-suppress-test read-suppress.sharp-colon.2 "#:foo") (def-read-suppress-test read-suppress.sharp-colon.3 "#0:1/2") (def-read-suppress-test read-suppress.sharp-colon.4 "#10:-2") (def-read-suppress-test read-suppress.sharp-colon.5 "#100000000000:x") (def-read-suppress-test read-suppress.sharp-colon.6 "#3:foo") (def-read-suppress-test read-suppress.sharp-colon.7 "#::") (def-read-suppress-test read-suppress.sharp-colon.8 "#:123") (def-read-suppress-test read-suppress.sharp-colon.9 "#:.") (def-read-suppress-test read-suppress.sharp-dot.1 "#.1") (def-read-suppress-test read-suppress.sharp-dot.2 "#.#:foo") (def-read-suppress-test read-suppress.sharp-dot.3 "#.(throw 'foo nil)") (def-read-suppress-test read-suppress.sharp-dot.4 "#0.1") (def-read-suppress-test read-suppress.sharp-dot.5 "#10.1") (def-read-suppress-test read-suppress.sharp-dot.6 "#1000000000000000.1") (def-read-suppress-test read-suppress.sharp-b.1 "#b0") (def-read-suppress-test read-suppress.sharp-b.2 "#B1") (def-read-suppress-test read-suppress.sharp-b.3 "#BX") (def-read-suppress-test read-suppress.sharp-b.4 "#b.") (def-read-suppress-test read-suppress.sharp-b.5 "#0b0") (def-read-suppress-test read-suppress.sharp-b.6 "#1B1") (def-read-suppress-test read-suppress.sharp-b.7 "#100b010") (def-read-suppress-test read-suppress.sharp-b.8 "#1000000000000b010") (def-read-suppress-test read-suppress.sharp-b.9 "#B101/100") (def-read-suppress-test read-suppress.sharp-b.10 "#b101/100/11") (def-read-suppress-test read-suppress.sharp-o.1 "#o0") (def-read-suppress-test read-suppress.sharp-o.2 "#O1") (def-read-suppress-test read-suppress.sharp-o.3 "#OX") (def-read-suppress-test read-suppress.sharp-o.4 "#o.") (def-read-suppress-test read-suppress.sharp-o.5 "#od6") (def-read-suppress-test read-suppress.sharp-o.6 "#1O9") (def-read-suppress-test read-suppress.sharp-o.7 "#100O010") (def-read-suppress-test read-suppress.sharp-o.8 "#1000000000000o27423") (def-read-suppress-test read-suppress.sharp-o.9 "#O123/457") (def-read-suppress-test read-suppress.sharp-o.10 "#o12/17/21") (def-read-suppress-test read-suppress.sharp-c.1 "#c(0 0)") (def-read-suppress-test read-suppress.sharp-c.2 "#C(1.0 1.0)") (def-read-suppress-test read-suppress.sharp-c.3 "#cFOO") (def-read-suppress-test read-suppress.sharp-c.4 "#c1") (def-read-suppress-test read-suppress.sharp-c.5 "#C(1 2 3)") (def-read-suppress-test read-suppress.sharp-c.6 "#c.") (def-read-suppress-test read-suppress.sharp-c.7 "#c()") (def-read-suppress-test read-suppress.sharp-c.8 "#c(1)") (def-read-suppress-test read-suppress.sharp-c.9 "#C(1 . 2)") (def-read-suppress-test read-suppress.sharp-c.10 "#c(1 2 3)") (def-read-suppress-test read-suppress.sharp-c.11 "#0c(1 2)") (def-read-suppress-test read-suppress.sharp-c.12 "#1C(1 2)") (def-read-suppress-test read-suppress.sharp-c.13 "#10c(1 2)") (def-read-suppress-test read-suppress.sharp-c.14 "#123456789c(1 2)") (def-read-suppress-test read-suppress.sharp-c.15 "#c(..)") (def-read-suppress-test read-suppress.sharp-x.1 "#x0") (def-read-suppress-test read-suppress.sharp-x.2 "#X1") (def-read-suppress-test read-suppress.sharp-x.3 "#XX") (def-read-suppress-test read-suppress.sharp-x.4 "#x.") (def-read-suppress-test read-suppress.sharp-x.5 "#xy6") (def-read-suppress-test read-suppress.sharp-x.6 "#1X9") (def-read-suppress-test read-suppress.sharp-x.7 "#100X010") (def-read-suppress-test read-suppress.sharp-x.8 "#1000000000000x2af23") (def-read-suppress-test read-suppress.sharp-x.9 "#X123/DE7") (def-read-suppress-test read-suppress.sharp-x.10 "#x12/17/21") (def-read-suppress-test read-suppress.sharp-r.1 "#2r1101") (def-read-suppress-test read-suppress.sharp-r.2 "#10R9871") (def-read-suppress-test read-suppress.sharp-r.3 "#36r721zwoqnASLDKJA22") (def-read-suppress-test read-suppress.sharp-r.4 "#r.") (def-read-suppress-test read-suppress.sharp-r.5 "#2r379ze") (def-read-suppress-test read-suppress.sharp-r.6 "#0r0") (def-read-suppress-test read-suppress.sharp-r.7 "#1r0") (def-read-suppress-test read-suppress.sharp-r.8 "#100r0A") (def-read-suppress-test read-suppress.sharp-r.9 "#1000000000000r0A") (def-read-suppress-test read-suppress.sharp-r.10 "#2r!@#$%^&*_-+={}[]:<>.?/") (def-read-suppress-test read-suppress.sharp-a.1 "#a()") (def-read-suppress-test read-suppress.sharp-a.2 "#2a((a)(b c))") (def-read-suppress-test read-suppress.sharp-a.3 "#a1") (def-read-suppress-test read-suppress.sharp-a.4 "#1a1") (def-read-suppress-test read-suppress.sharp-a.5 "#10a(a b c)") (def-read-suppress-test read-suppress.sharp-a.6 "#100a(a b c)") (def-read-suppress-test read-suppress.sharp-a.7 "#10000000000000a(a b c)") (def-read-suppress-test read-suppress.sharp-a.8 "#a..") (def-read-suppress-test read-suppress.sharp-a.9 "#a(...)") (def-read-suppress-test read-suppress.sharp-s.1 "#s()") (def-read-suppress-test read-suppress.sharp-s.2 "#S(invalid-sname)") (def-read-suppress-test read-suppress.sharp-s.3 "#s(..)") (def-read-suppress-test read-suppress.sharp-s.4 "#S(foo bar)") (def-read-suppress-test read-suppress.sharp-s.5 "#0s()") (def-read-suppress-test read-suppress.sharp-s.6 "#1S()") (def-read-suppress-test read-suppress.sharp-s.7 "#10s()") (def-read-suppress-test read-suppress.sharp-s.8 "#271S()") (def-read-suppress-test read-suppress.sharp-s.9 "#712897459812s()") (def-read-suppress-test read-suppress.sharp-p.1 "#p\"\"") (def-read-suppress-test read-suppress.sharp-p.2 "#P123") (def-read-suppress-test read-suppress.sharp-p.3 "#p1/3") (def-read-suppress-test read-suppress.sharp-p.4 "#0P\"\"") (def-read-suppress-test read-suppress.sharp-p.5 "#1p\"\"") (def-read-suppress-test read-suppress.sharp-p.6 "#100P\"\"") (def-read-suppress-test read-suppress.sharp-p.7 "#1234567890p\"\"") (def-read-suppress-test read-suppress.sharp-equal.1 "#=nil") (def-read-suppress-test read-suppress.sharp-equal.2 "#1=nil") (def-read-suppress-test read-suppress.sharp-equal.3 "#100=nil") (def-read-suppress-test read-suppress.sharp-equal.4 "(#1=nil #1=nil)") (def-read-suppress-test read-suppress.sharp-sharp.1 "##") (def-read-suppress-test read-suppress.sharp-sharp.2 "#1#") (def-read-suppress-test read-suppress.sharp-sharp.3 "#100#") (def-read-suppress-test read-suppress.sharp-sharp.4 "#123456789#") ;;; Error cases (def-syntax-test read-suppress.error.1 (signals-error (let ((*read-suppress* t)) (read-from-string "')")) reader-error) t) (def-syntax-test read-suppress.error.2 (signals-error (let ((*read-suppress* t)) (read-from-string "#<")) reader-error) t) (def-syntax-test read-suppress.error.3 (signals-error (let ((*read-suppress* t)) (read-from-string "# ")) reader-error) t) (def-syntax-test read-suppress.error.4 (signals-error (let ((*read-suppress* t)) (read-from-string "#)")) reader-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/packages-19.lsp0000644000000000000000000000013114542551763016176 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.497789206 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-19.lsp0000644000175000017500000000272514542551763015603 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/structures-04.lsp0000644000000000000000000000013214542551763016636 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.497789206 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/structures-04.lsp0000644000175000017500000000564414542551763016245 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 19 20:07:40 2003 ;;;; Contains: More tests of structures (in-package :cl-test) ;;; I realized I had forgotten to test slot override in :include ;;; clauses in defstruct. (defstruct struct-include-01a a (b 0)) (defstruct (struct-include-01b (:include struct-include-01a (a 100) (b 'x))) (c 200) d) (deftest struct-include.1 (let ((obj (make-struct-include-01b))) (values (typep* obj 'struct-include-01a) (typep* obj 'struct-include-01b) (struct-include-01a-a obj) (struct-include-01a-b obj) (struct-include-01b-a obj) (struct-include-01b-b obj) (struct-include-01b-c obj))) t t 100 x 100 x 200) (deftest struct-include.2 (let ((obj (make-struct-include-01b :a 1 :b 2 :c 3 :d 4))) (values (typep* obj 'struct-include-01a) (typep* obj 'struct-include-01b) (struct-include-01a-a obj) (struct-include-01a-b obj) (struct-include-01b-a obj) (struct-include-01b-b obj) (struct-include-01b-c obj) (struct-include-01b-d obj) )) t t 1 2 1 2 3 4) (defstruct struct-include-02a (a 0 :type number)) (defstruct (struct-include-02b (:include struct-include-02a (a 10 :type integer)))) (deftest struct-include.3 (let ((obj (make-struct-include-02b))) (values (typep* obj 'struct-include-02a) (typep* obj 'struct-include-02b) (struct-include-02a-a obj) (struct-include-02b-a obj))) t t 10 10) (deftest struct-include.4 (let ((obj (make-struct-include-02a))) (values (typep* obj 'struct-include-02a) (typep* obj 'struct-include-02b) (struct-include-02a-a obj))) t nil 0) (deftest struct-include.5 (let ((obj (make-struct-include-02b :a 100))) (values (typep* obj 'struct-include-02a) (typep* obj 'struct-include-02b) (struct-include-02a-a obj) (struct-include-02b-a obj))) t t 100 100) (defstruct struct-include-03a (a 0 :type number)) (defstruct (struct-include-03b (:include struct-include-03a (a)))) (deftest struct-include.5a (let ((obj (make-struct-include-03b :a 100))) (values (typep* obj 'struct-include-03a) (typep* obj 'struct-include-03b) (struct-include-03a-a obj) (struct-include-03b-a obj))) t t 100 100) (defstruct struct-include-04a a b) (defstruct (struct-include-04b (:include struct-include-04a (a 0 :read-only t)))) (deftest struct-include.6 (let ((obj (make-struct-include-04b))) (values (typep* obj 'struct-include-04a) (typep* obj 'struct-include-04b) (struct-include-04a-a obj) (struct-include-04b-a obj))) t t 0 0) (deftest struct-include.7 (let ((obj (make-struct-include-04b :a 1 :b 2))) (values (typep* obj 'struct-include-04a) (typep* obj 'struct-include-04b) (struct-include-04a-a obj) (struct-include-04b-a obj) (struct-include-04a-b obj) (struct-include-04b-b obj))) t t 1 1 2 2) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-07.lsp0000644000000000000000000000013114542551763020772 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.497789206 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-07.lsp0000644000175000017500000001063014542551763020371 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 13 17:03:52 2005 ;;;; Contains: Random type prop tests, part 7 (strings) (in-package :cl-test) (def-type-prop-test simple-string-p 'simple-string-p '(t) 1) (def-type-prop-test char 'char (list 'string (index-type-for-dim 0)) 2) (def-type-prop-test schar 'schar (list 'simple-string (index-type-for-dim 0)) 2) (def-type-prop-test string 'string '((or string symbol character)) 1) (def-type-prop-test string-upcase 'string-upcase '(string) 1) (def-type-prop-test string-downcase 'string-downcase '(string) 1) (def-type-prop-test string-capitalize 'string-capitalize '(string) 1) (def-type-prop-test string-trim.1 'string-trim '(string string) 2) (def-type-prop-test string-trim.2 'string-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) 2) (def-type-prop-test string-left-trim.1 'string-left-trim '(string string) 2) (def-type-prop-test string-left-trim.2 'string-left-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) 2) (def-type-prop-test string-right-trim.1 'string-right-trim '(string string) 2) (def-type-prop-test string-right-trim.2 'string-right-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) 2) (defmacro def-string-comparison-type-prop-test (op) (flet ((%makename (n) (intern (format nil "~A.~A" op n) :cl-test))) `(progn (def-type-prop-test ,(%makename 1) ',op '(string string) 2) (def-type-prop-test ,(%makename 2) ',op `(string string (eql :start1) ,#'index-type-for-v1) 4) (def-type-prop-test ,(%makename 3) ',op `(string string (eql :start2) ,#'index-type-for-v2) 4) (def-type-prop-test ,(%makename 4) ',op `(string string (eql :end1) ,#'end-type-for-v1) 4) (def-type-prop-test ,(%makename 5) ',op `(string string (eql :end2) ,#'end-type-for-v2) 4) (def-type-prop-test ,(%makename 6) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :end1) ,#'end-type-for-v1) 6) (def-type-prop-test ,(%makename 7) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :end2) ,#'end-type-for-v2) 6) (def-type-prop-test ,(%makename 8) ',op `(string string (eql :start2) ,#'index-type-for-v2 (eql :end1) ,#'end-type-for-v1) 6) (def-type-prop-test ,(%makename 9) ',op `(string string (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2) 6) (def-type-prop-test ,(%makename 10) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :start2) ,#'index-type-for-v2 (eql :end1) ,#'end-type-for-v1) 8) (def-type-prop-test ,(%makename 11) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2) 8) (def-type-prop-test ,(%makename 12) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :end2) ,#'end-type-for-v2 (eql :end1) ,#'end-type-for-v1) 8) (def-type-prop-test ,(%makename 13) ',op `(string string (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2 (eql :end1) ,#'end-type-for-v1) 8) (def-type-prop-test ,(%makename 14) ',op `(string string (eql :start1) ,#'index-type-for-v1 (eql :start2) ,#'index-type-for-v2 (eql :end2) ,#'end-type-for-v2 (eql :end1) ,#'end-type-for-v1) 10) ))) (def-string-comparison-type-prop-test string=) (def-string-comparison-type-prop-test string/=) (def-string-comparison-type-prop-test string<) (def-string-comparison-type-prop-test string<=) (def-string-comparison-type-prop-test string>) (def-string-comparison-type-prop-test string>=) (def-string-comparison-type-prop-test string-equal) (def-string-comparison-type-prop-test string-not-equal) (def-string-comparison-type-prop-test string-lessp) (def-string-comparison-type-prop-test string-greaterp) (def-string-comparison-type-prop-test string-not-lessp) (def-string-comparison-type-prop-test string-not-greaterp) (def-type-prop-test stringp 'stringp '(t) 1) (def-type-prop-test make-string.1 'make-string '((integer 0 100) (eql :initial-element) character) 3) (def-type-prop-test make-string.2 'make-string `((integer 0 100) (eql :initial-element) character (eql :element-type) ,#'(lambda (&rest args) `(eql (and character ,(make-random-type-containing (third args)))))) 5) gcl-2.7.1/ansi-tests/PaxHeaders/funcall.lsp0000644000000000000000000000013214542551762015615 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.497789206 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/funcall.lsp0000644000175000017500000000422114542551762015212 0ustar00cammcamm;-*- 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 (signals-error (funcall 'quote 1) undefined-function :name quote) t) (deftest funcall.error.2 (signals-error (funcall 'progn 1) undefined-function :name progn) t) ;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when ;;; called on a symbol with a global definition as a macro (deftest funcall.error.3 (signals-error (funcall 'defconstant '(defconstant x 10)) undefined-function :name defconstant) t) (deftest funcall.error.4 (signals-error (funcall) program-error) t) (deftest funcall.error.5 (signals-error (funcall #'cons) program-error) t) (deftest funcall.error.6 (signals-error (funcall #'cons 1) program-error) t) (deftest funcall.error.7 (signals-type-error x 'a (funcall #'car x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/apropos.lsp0000644000000000000000000000013214542551762015654 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.501789223 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/apropos.lsp0000644000175000017500000000540114542551762015252 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 16:17:47 2004 ;;;; Contains: Tests for APROPOS (in-package :cl-test) (deftest apropos.1 (loop for n from 10 for x = (coerce (loop repeat n collect (random-from-seq +standard-chars+)) 'string) unless (apropos-list x) return (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos x)))))) "") (deftest apropos.2 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR"))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.3 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" (find-package "CL")))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.4 (let ((result nil)) (do-special-strings (s "CAR" t) (setq result (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos s)))))) (assert (search "CAR" result :test #'string-equal)))) t) (deftest apropos.5 (let ((result nil) (pkg (find-package "COMMON-LISP"))) (do-special-strings (s "APROPOS" t) (setq result (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos s pkg)))))) (assert (search "APROPOS" result :test #'string-equal)))) t) (deftest apropos.6 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" "CL"))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.7 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" :|CL|))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.8 (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" nil))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.9 (macrolet ((%m (z) z)) (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos (expand-in-current-env (%m "CAR"))))))))) (notnot (search "CAR" s :test #'string-equal)))) t) (deftest apropos.10 (macrolet ((%m (z) z)) (let ((s (with-output-to-string (*standard-output*) (assert (null (multiple-value-list (apropos "CAR" (expand-in-current-env (%m nil))))))))) (notnot (search "CAR" s :test #'string-equal)))) t) ;;; Error tests (deftest apropos.error.1 (signals-error (apropos) program-error) t) (deftest apropos.error.2 (signals-error (apropos "SJLJALKSJDKLJASKLDJKLAJDLKJA" (find-package "CL") nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/with-output-to-string.lsp0000644000000000000000000000013214542551763020427 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.501789223 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-output-to-string.lsp0000644000175000017500000000627214542551763020034 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/loop8.lsp0000644000000000000000000000013214542551763015233 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.501789223 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop8.lsp0000644000175000017500000000577114542551763014643 0ustar00cammcamm;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.8.24 (macrolet ((%m (z) z)) (loop with x = (expand-in-current-env (%m 1)) do (return x))) 1) ;;; 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 (signals-error (loop with a = 1 and a = 2 return a) program-error) t) (deftest loop.8.error.2 (signals-error (loop with a = 1 with a = 2 return a) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-14.lsp0000644000000000000000000000013214542551762016332 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.501789223 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-14.lsp0000644000175000017500000001511514542551762015733 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/logandc2.lsp0000644000000000000000000000013214542551763015663 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.501789223 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logandc2.lsp0000644000175000017500000000333214542551763015262 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 05:52:31 2003 ;;;; Contains: Tests of LOGANDC2 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logandc2.error.1 (check-type-error #'(lambda (x) (logandc2 x 0)) #'integerp) nil) (deftest logandc2.error.2 (check-type-error #'(lambda (x) (logandc2 0 x)) #'integerp) nil) (deftest logandc2.error.3 (signals-error (logandc2) program-error) t) (deftest logandc2.error.4 (signals-error (logandc2 0) program-error) t) (deftest logandc2.error.5 (signals-error (logandc2 1 2 3) program-error) t) ;;; Non-error tests (deftest logandc2.1 (logandc2 0 0) 0) (deftest logandc2.2 (logandc2 -1 0) -1) (deftest logandc2.3 (logandc2 (1+ most-positive-fixnum) 0) #.(1+ most-positive-fixnum)) (deftest logandc2.4 (loop for x in *integers* always (and (eql x (logandc2 x 0)) (eql 0 (logandc2 x x)) (eql x (logandc2 x (lognot x))) (eql (lognot x) (logandc2 (lognot x) x)))) t) (deftest logandc2.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logandc2 x xc)) collect x) nil) (deftest logandc2.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logandc2 x y) repeat 1000 unless (and (if (and (< x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (and (not (logbitp i y)) (logbitp i x)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logandc2.order.1 (let ((i 0) a b) (values (logandc2 (progn (setf a (incf i)) -1) (progn (setf b (incf i)) 0)) i a b)) -1 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/simple-bit-vector.lsp0000644000000000000000000000013214542551763017537 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.501789223 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-bit-vector.lsp0000644000175000017500000000267414542551763017146 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/signum.lsp0000644000000000000000000000013214542551763015474 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.501789223 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/signum.lsp0000644000175000017500000000436114542551763015076 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 22:29:09 2003 ;;;; Contains: Tests of SIGNUM (in-package :cl-test) (deftest signum.error.1 (signals-error (signum) program-error) t) (deftest signum.error.2 (signals-error (signum 1 1) program-error) t) (deftest signum.error.3 (signals-error (signum 1 nil) program-error) t) (deftest signum.1 (signum 0) 0) (deftest signum.2 (signum 123) 1) (deftest signum.3 (signum -123123) -1) (deftest signum.4 (loop for i in *rationals* for s = (signum i) unless (cond ((zerop i) (eql s 0)) ((plusp i) (eql s 1)) (t (eql s -1))) collect (list i s)) nil) (deftest signum.5 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for one = (float 1 x) for y = (float 13122 x) for s1 = (signum x) for s2 = (signum y) for s3 = (signum (- y)) unless (and (eql s1 x) (eql s2 one) (eql s3 (- one))) collect (list x one y s1 s2 s3)) nil) (deftest signum.6 (loop for tp in '(short-float single-float double-float long-float) for z = (coerce 0 tp) for mz = (- z) nconc (loop for x in (list z mz) nconc (loop for y in (list z mz) for c = (complex z mz) for s = (signum c) unless (eql c s) collect (list c s)))) nil) (deftest signum.7 (loop for tp in '(short-float single-float double-float long-float) for z = (coerce 0 tp) for one = (coerce 1 tp) for onem = (coerce -1 tp) for c1 = (complex one z) for c2 = (complex onem z) for c3 = (complex z one) for c4 = (complex z onem) unless (eql c1 (signum c1)) collect (list c1 (signum c1)) unless (eql c2 (signum c2)) collect (list c2 (signum c2)) unless (eql c3 (signum c3)) collect (list c3 (signum c3)) unless (eql c4 (signum c4)) collect (list c4 (signum c4))) nil) (deftest signum.8 (let* ((c (complex 0 1)) (s (signum c))) (or (eqlt c s) (eqlt s #c(0.0 1.0)))) t) (deftest signum.9 (let* ((c (complex 0 -1)) (s (signum c))) (or (eqlt c s) (eqlt s #c(0.0 -1.0)))) t) (deftest signum.10 (let* ((c (complex 3/5 4/5)) (s (signum c))) (or (eqlt c s) (eqlt s (complex (float 3/5) (float 4/5))))) t) (deftest signum.11 (let ((i 0)) (values (signum (the (integer 1 1) (incf i))) i)) 1 1) gcl-2.7.1/ansi-tests/PaxHeaders/row-major-aref.lsp0000644000000000000000000000013214542551763017022 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.501789223 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/row-major-aref.lsp0000644000175000017500000000526014542551763016423 0ustar00cammcamm;-*- 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 (signals-error (row-major-aref) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/tanh.lsp0000644000000000000000000000013114542551763015123 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.501789223 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/tanh.lsp0000644000175000017500000000356514542551763014533 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:16:35 2004 ;;;; Contains: Tests of TANH (in-package :cl-test) (deftest tanh.1 (let ((result (tanh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest tanh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (tanh zero)) (list zero)) collect type) nil) (deftest tanh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (tanh zero)) (list zero)) collect type) nil) (deftest tanh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (tanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest tanh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (tanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest tanh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (tanh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest tanh.error.1 (signals-error (tanh) program-error) t) (deftest tanh.error.2 (signals-error (tanh 1.0 1.0) program-error) t) (deftest tanh.error.3 (check-type-error #'tanh #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/pathname.lsp0000644000000000000000000000013114542551763015766 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.501789223 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname.lsp0000644000175000017500000000405414542551763015370 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/disassemble.lsp0000644000000000000000000000013214542551762016464 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.505789241 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/disassemble.lsp0000644000175000017500000000454514542551762016072 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 18 20:47:58 2003 ;;;; Contains: Tests of DISASSEMBLE (in-package :cl-test) (defun disassemble-it (fn) (let (val) (values (notnot (stringp (with-output-to-string (*standard-output*) (setf val (disassemble fn))))) val))) (deftest disassemble.1 (disassemble-it 'car) t nil) (deftest disassemble.2 (disassemble-it (symbol-function 'car)) t nil) (deftest disassemble.3 (disassemble-it '(lambda (x y) (cons y x))) t nil) (deftest disassemble.4 (disassemble-it (eval '(function (lambda (x y) (cons x y))))) t nil) (deftest disassemble.5 (disassemble-it (funcall (compile nil '(lambda () (let ((x 0)) #'(lambda () (incf x))))))) t nil) (deftest disassemble.6 (let ((name 'disassemble.fn.1)) (fmakunbound name) (eval `(defun ,name (x) x)) (disassemble-it name)) t nil) (deftest disassemble.7 (let ((name 'disassemble.fn.2)) (fmakunbound name) (eval `(defun ,name (x) x)) (compile name) (disassemble-it name)) t nil) (deftest disassemble.8 (progn (eval '(defun (setf disassemble-example-fn) (val arg) (setf (car arg) val))) (disassemble-it '(setf disassemble-example-fn))) t nil) (deftest disassemble.9 (progn (eval '(defgeneric disassemble-example-fn2 (x y z))) (disassemble-it 'disassemble-example-fn2)) t nil) (deftest disassemble.10 (progn (eval '(defgeneric disassemble-example-fn3 (x y z))) (eval '(defmethod disassemble-example-fn3 ((x t)(y t)(z t)) (list x y z))) (disassemble-it 'disassemble-example-fn3)) t nil) (deftest disassemble.11 (let ((fn 'disassemble-example-fn4)) (when (fboundp fn) (fmakunbound fn)) (eval `(defun ,fn (x) x)) (let ((is-compiled? (typep (symbol-function fn) 'compiled-function))) (multiple-value-call #'values (disassemble-it fn) (if is-compiled? (notnot (typep (symbol-function fn) 'compiled-function)) (not (typep (symbol-function fn) 'compiled-function)))))) t nil t) ;;; Error tests (deftest disassemble.error.1 (signals-error (disassemble) program-error) t) (deftest disassemble.error.2 (signals-error (disassemble 'car nil) program-error) t) (deftest disassemble.error.3 (check-type-error #'disassemble (typef '(or function symbol (cons (eql setf) (cons symbol null))))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/loop12.lsp0000644000000000000000000000013214542551763015306 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.505789241 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop12.lsp0000644000175000017500000001064014542551763014705 0ustar00cammcamm;-*- 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 (signals-error (loop for i from 1 to 10 collect i always (< i 20)) program-error) t) (deftest loop.12.error.50a (signals-error (loop for i from 1 to 10 always (< i 20) collect i) program-error) t) (deftest loop.12.error.51 (signals-error (loop for i from 1 to 10 collect i never (> i 20)) program-error) t) (deftest loop.12.error.51a (signals-error (loop for i from 1 to 10 never (> i 20) collect i) program-error) t) (deftest loop.12.error.52 (signals-error (loop for i from 1 to 10 collect i thereis (> i 20)) program-error) t) (deftest loop.12.error.52a (signals-error (loop for i from 1 to 10 thereis (> i 20) collect i) program-error) t) ;;; 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.12.56 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) always (expand-in-current-env (%m (< i 10))))) t) (deftest loop.12.57 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) always (expand-in-current-env (%m t)))) t) (deftest loop.12.58 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) never (expand-in-current-env (%m (>= i 10))))) t) (deftest loop.12.59 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) never (expand-in-current-env (%m t)))) nil) (deftest loop.12.60 (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) thereis (expand-in-current-env (%m (and (>= i 2) (+ i 1)))))) 3) gcl-2.7.1/ansi-tests/PaxHeaders/prin1.lsp0000644000000000000000000000013114542551763015222 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.505789241 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/prin1.lsp0000644000175000017500000000154614542551763014627 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:33:40 2004 ;;;; Contains: Tests of PRIN1 (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest prin1.1 (random-prin1-test 1000) nil) (deftest prin1.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (prin1 2 t))))) "2") (deftest prin1.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (prin1 3 nil))) "3") ;;; Error tests (deftest prin1.error.1 (signals-error (with-output-to-string (*standard-output*) (prin1)) program-error) t) (deftest prin1.error.2 (signals-error (with-output-to-string (s) (prin1 nil s nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/nth.lsp0000644000000000000000000000013114542551763014762 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.505789241 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nth.lsp0000644000175000017500000000224214542551763014361 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:33:23 2003 ;;;; Contains: Tests of NTH (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (nth) program-error) t) (deftest nth.error.2 (signals-error (nth 0) program-error) t) (deftest nth.error.3 (signals-error (nth 1 '(a b c) nil) program-error) t) (deftest nth.error.4 (signals-error (nth 0 '(a b c) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/defvar.lsp0000644000000000000000000000013214542551762015440 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.505789241 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defvar.lsp0000644000175000017500000000346214542551762015043 0ustar00cammcamm;-*- 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 ;;; (signals-error (defvar) program-error) ;;; t) ;;; ;;; (deftest defvar.error.2 ;;; (signals-error (defvar *ignored-defvar-name* nil "documentation" ;;; "illegal extra argument") ;;; program-error) ;;; t) (deftest defvar.error.1 (signals-error (funcall (macro-function 'defvar)) program-error) t) (deftest defvar.error.2 (signals-error (funcall (macro-function 'defvar) '(defvar *nonexistent-variable* nil)) program-error) t) (deftest defvar.error.3 (signals-error (funcall (macro-function 'defvar) '(defvar *nonexistent-variable* nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-05.lsp0000644000000000000000000000013114542551763020770 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.505789241 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-05.lsp0000644000175000017500000006544314542551763020403 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Mar 8 20:31:08 2005 ;;;; Contains: Random type prop tests, part 5 (Cons) (in-package :cl-test) (def-type-prop-test list.1 'list nil 1 :rest-type 't :maxargs 10) (def-type-prop-test list.2 '(lambda (x) (car (list x))) '(t) 1) (def-type-prop-test list.3 '(lambda (x y) (cdr (list x y))) '(t t) 2) (def-type-prop-test list.4 '(lambda (x y z) (cadr (list x y z))) '(t t t) 3) (def-type-prop-test list.5 '(lambda (x) (let ((z (list x))) (declare (dynamic-extent z)) (car z))) '(t) 1) (def-type-prop-test list* 'list* () 1 :rest-type t :maxargs 10) (def-type-prop-test null 'null '(t) 1) (def-type-prop-test cons.1 'cons '(t t) 2) (def-type-prop-test cons.2 '(lambda (x y) (car (cons y x))) '(t t) 2) (def-type-prop-test cons.3 '(lambda (x y) (cdr (cons x y))) '(t t) 2) (def-type-prop-test consp 'consp '(t) 1) (def-type-prop-test atom 'atom '(t) 1) (def-type-prop-test rplaca 'rplaca '(cons t) 2 :replicate '(t nil)) (def-type-prop-test rplacd 'rplacd '(cons t) 2 :replicate '(t nil)) (def-type-prop-test car 'car '((cons t t)) 1) (def-type-prop-test first 'first '((cons t t)) 1) (def-type-prop-test cdr 'cdr '((cons t t)) 1) (def-type-prop-test rest 'rest '((cons t t)) 1) (def-type-prop-test caar 'caar '((cons (cons t t) t)) 1) (def-type-prop-test cdar 'cdar '((cons (cons t t) t)) 1) (def-type-prop-test cadr 'cadr '((cons t (cons t t))) 1) (def-type-prop-test second 'second '((cons t (cons t t))) 1) (def-type-prop-test cddr 'cddr '((cons t (cons t t))) 1) (def-type-prop-test caaar 'caaar '((cons (cons (cons t t) t) t)) 1) (def-type-prop-test cdaar 'cdaar '((cons (cons (cons t t) t) t)) 1) (def-type-prop-test cadar 'cadar '((cons (cons t (cons t t)) t)) 1) (def-type-prop-test cddar 'cddar '((cons (cons t (cons t t)) t)) 1) (def-type-prop-test caadr 'caadr '((cons t (cons (cons t t) t))) 1) (def-type-prop-test cdadr 'cdadr '((cons t (cons (cons t t) t))) 1) (def-type-prop-test caddr 'caddr '((cons t (cons t (cons t t)))) 1) (def-type-prop-test third 'third '((cons t (cons t (cons t t)))) 1) (def-type-prop-test cdddr 'cdddr '((cons t (cons t (cons t t)))) 1) (def-type-prop-test caaaar'caaaar '((cons (cons (cons (cons t t) t) t) t)) 1) (def-type-prop-test cdaaar 'cdaaar '((cons (cons (cons (cons t t) t) t) t)) 1) (def-type-prop-test cadaar 'cadaar '((cons (cons (cons t (cons t t)) t) t)) 1) (def-type-prop-test cddaar 'cddaar '((cons (cons (cons t (cons t t)) t) t)) 1) (def-type-prop-test caadar 'caadar '((cons (cons t (cons (cons t t) t)) t)) 1) (def-type-prop-test cdadar 'cdadar '((cons (cons t (cons (cons t t) t)) t)) 1) (def-type-prop-test caddar 'caddar '((cons (cons t (cons t (cons t t))) t)) 1) (def-type-prop-test cdddar 'cdddar '((cons (cons t (cons t (cons t t))) t)) 1) (def-type-prop-test caaadr 'caaadr '((cons t (cons (cons (cons t t) t) t))) 1) (def-type-prop-test cdaadr 'cdaadr '((cons t (cons (cons (cons t t) t) t))) 1) (def-type-prop-test cadadr 'cadadr '((cons t (cons (cons t (cons t t)) t))) 1) (def-type-prop-test cddadr 'cddadr '((cons t (cons (cons t (cons t t)) t))) 1) (def-type-prop-test caaddr 'caaddr '((cons t (cons t (cons (cons t t) t)))) 1) (def-type-prop-test cdaddr 'cdaddr '((cons t (cons t (cons (cons t t) t)))) 1) (def-type-prop-test cadddr 'cadddr '((cons t (cons t (cons t (cons t t))))) 1) (def-type-prop-test fourth 'fourth '((cons t (cons t (cons t (cons t t))))) 1) (def-type-prop-test cddddr 'cddddr '((cons t (cons t (cons t (cons t t))))) 1) (def-type-prop-test fifth 'fifth '((cons t (cons t (cons t (cons t (cons t t)))))) 1) (def-type-prop-test sixth 'sixth '((cons t (cons t (cons t (cons t (cons t (cons t t))))))) 1) (def-type-prop-test seventh 'seventh '((cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))) 1) (def-type-prop-test eighth 'eighth '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))) 1) (def-type-prop-test ninth 'ninth '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))))) 1) (def-type-prop-test tenth 'tenth '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))))) 1) (def-type-prop-test pop '(lambda (x) (list (pop x) x)) '((cons t t)) 1) (def-type-prop-test push '(lambda (x y) (list (push x y) x y)) '(t t) 2) (def-type-prop-test copy-tree.1 'copy-tree '((cons t t)) 1) (def-type-prop-test copy-tree.2 'copy-tree '((cons (cons t t) (cons t t))) 1) (def-type-prop-test copy-tree.3 'copy-tree '((cons t (cons (cons t (cons t t)) t))) 1) (def-type-prop-test copy-tree.4 'copy-tree '(list) 1) (def-type-prop-test sublis.1 'sublis '((cons (cons symbol t) null) list) 2) (def-type-prop-test sublis.2 'sublis '((cons (cons (integer 0 7) t) null) list) 2) (def-type-prop-test sublis.3 'sublis '(null list) 2) (def-type-prop-test sublis.4 'sublis `((cons (cons boolean t) null) list (eql :key) (or null (eql not) (eql ,#'not))) 4) (def-type-prop-test sublis.5 'sublis `((cons (cons t t) null) list (eql :test) (or (eql equal) (eql ,#'equal))) 4) (def-type-prop-test sublis.6 'sublis `((cons (cons t t) null) list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) (def-type-prop-test subst.1 'subst '(t t t) 3) (def-type-prop-test subst.2 'subst '(t t (cons t t)) 3) (def-type-prop-test subst.3 'subst '(t t list) 3) (def-type-prop-test subst.4 'subst '(t t (cons (cons t t) (cons t t))) 3) (def-type-prop-test subst.5 'subst `(boolean t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test subst.6 'subst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5) (def-type-prop-test subst.7 'subst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5) (def-type-prop-test subst.8 'subst `(t t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not)) (eql :test) (or (eql equal) (eql ,#'equal))) 7) (def-type-prop-test nsubst.1 'nsubst '(t t t) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.2 'nsubst '(t t (cons t t)) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.3 'nsubst '(t t list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.4 'nsubst '(t t (cons (cons t t) (cons t t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.5 'nsubst `(boolean t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.6 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.7 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.8 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :key) (or null (eql not) (eql ,#'not)) (eql :test) (or (eql equal) (eql ,#'equal))) 7 :replicate '(nil nil t nil nil nil nil)) (def-type-prop-test subst-if.1 'subst-if `(t (or (eql not) (eql ,#'not)) list) 3) (def-type-prop-test subst-if.2 'subst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) (def-type-prop-test subst-if.3 'subst-if `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test nsubst-if.1 'nsubst-if `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if.2 'nsubst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if.3 'nsubst-if `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test subst-if-not.1 'subst-if-not `(t (or (eql not) (eql ,#'not)) list) 3) (def-type-prop-test subst-if-not.2 'subst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) (def-type-prop-test subst-if-not.3 'subst-if-not `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test nsubst-if-not.1 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if-not.2 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if-not.3 'nsubst-if-not `(t (eql identity) (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) (eql :key) (or null (eql not) (eql ,#'not))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test tree-equal.1 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x))))) 2) (def-type-prop-test tree-equal.2 'tree-equal (list 'list #'(lambda (x) `(or list (eql ,(copy-tree t))))) 2) (def-type-prop-test tree-equal.3 'tree-equal (list '(cons t t) #'(lambda (x) `(or (cons t t) (eql ,(copy-tree x)))) '(eql :test) `(or (eql equal) (eql ,#'equal))) 4) (def-type-prop-test tree-equal.4 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x)))) '(eql :test-not) '(eql eql)) 4) (def-type-prop-test copy-list.1 'copy-list '(list) 1) (def-type-prop-test copy-list.2 'copy-list '((cons t t)) 1) (def-type-prop-test copy-list.3 'copy-list '((cons t (cons t (or t (cons t (or t (cons t t))))))) 1) (def-type-prop-test list-length.1 'list-length '(list) 1) (def-type-prop-test list-length.2 'list-length '((cons t list)) 1) (def-type-prop-test listp 'listp '(t) 1) (def-type-prop-test make-list.1 'make-list '((integer 0 100)) 1) (def-type-prop-test make-list.2 '(lambda (x) (length (make-list x))) '((integer 0 100)) 1) (def-type-prop-test make-list.3 'make-list '((integer 0 100) (eql :initial-element) t) 3) (def-type-prop-test nth.1 'nth '((integer 0 12) list) 2) (def-type-prop-test endp.1 'endp '((or null (cons t t))) 1) (def-type-prop-test append.1 'append nil 1 :maxargs 10 :rest-type 'list) (def-type-prop-test append.2 'append '(list t) 2) (def-type-prop-test append.3 'append '(list list t) 3) (def-type-prop-test append.4 'append '(list list list t) 4) (def-type-prop-test nconc.1 'nconc '(list) 1) (def-type-prop-test nconc.2 'nconc '(list list) 2 :replicate '(t nil)) (def-type-prop-test nconc.3 'nconc '(list list list) 3 :replicate '(t t nil)) (def-type-prop-test nconc.4 'nconc '(list list list list) 4 :replicate '(t t t nil)) (def-type-prop-test revappend 'revappend '(list t) 2) (def-type-prop-test nreconc 'nreconc '(list t) 2 :replicate '(t nil)) (def-type-prop-test butlast.1 'butlast '(list) 1) (def-type-prop-test butlast.2 'butlast '(list (integer 0 20)) 2) (def-type-prop-test nbutlast.1 'nbutlast '(list) 1 :replicate '(t)) (def-type-prop-test nbutlast.2 'nbutlast '(list (integer 0 20)) 2 :replicate '(t nil)) (def-type-prop-test last.1 'last '(list) 1) (def-type-prop-test last.2 'last '(list (integer 0 15)) 2) (def-type-prop-test last.3 'last '((cons t (or t (cons t (or t (cons t t)))))) 1) (def-type-prop-test last.4 'last '((cons t (or t (cons t (or t (cons t t))))) (integer 0 5)) 2) (def-type-prop-test ldiff.1 'ldiff '(list t) 2) (def-type-prop-test ldiff.2 'ldiff (list 'list #'(lambda (x) (if (consp x) `(or t (eql ,(nthcdr (random (length x)) x))) t))) 2) (def-type-prop-test tailp.1 'tailp '(t list) 2) (def-type-prop-test tailp.2 'tailp (list t #'(lambda (x) (make-list-type (1+ (random 10)) `(eql ,x)))) 2) (def-type-prop-test nthcdr 'nthcdr '((integer 0 20) list) 2) (def-type-prop-test member.1 'member '(t list) 2) (def-type-prop-test member.2 'member (list t #'(lambda (x) (make-list-type (random 5) `(cons (eql ,x) ,(make-list-type (random 5)))))) 2) (def-type-prop-test member.3 'member `(t list (eql :key) (or (eql not) (eql ,#'not))) 4) (def-type-prop-test member.4 'member `(t list (eql :test) (or (eql equalp) (eql ,#'equalp))) 4) (def-type-prop-test member.5 'member `(t list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) (def-type-prop-test member.6 'member `(t list (eql :allow-other-keys) (and t (not null)) (eql :foo) t) 6) (def-type-prop-test member-if.1 'member-if `((or (eql symbolp) (eql ,#'symbolp)) list) 2) (def-type-prop-test member-if.2 'member-if (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) 2) (def-type-prop-test member-if.3 'member-if (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) '(eql :key)`(or (eql 1-) (eql ,#'1-))) 4) (def-type-prop-test member-if-not.1 'member-if-not `((or (eql symbolp) (eql ,#'symbolp)) list) 2) (def-type-prop-test member-if-not.2 'member-if-not (list '(eql plusp) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) 2) (def-type-prop-test member-if-not.3 'member-if-not (list '(eql plusp) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) '(eql :key) `(or (eql 1-) (eql ,#'1-))) 4) (def-type-prop-test member-if-not.4 'member-if-not `((eql identity) list (eql :allow-other-keys) (and t (not null)) (member :foo :bar #:xyz) t) 6) (def-type-prop-test mapc.1 'mapc '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapc.2 'mapc `((eql ,#'values)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcar.1 'mapcar '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcar.2 'mapcar `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test maplist.1 'maplist '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test maplist.2 'maplist `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapl.1 'mapl '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapl.2 'mapl `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcan.1 'mapcan '((eql list)) 2 :rest-type 'list :maxargs 10) (def-type-prop-test mapcon.1 'mapcon '((eql copy-list) list) 2) (def-type-prop-test acons 'acons (list t t #'(lambda (x y) (make-list-type (random 5) 'null '(or null (cons t t))))) 3) (def-type-prop-test assoc.1 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) (def-type-prop-test assoc.2 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t))))) 2) (def-type-prop-test assoc.3 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t)))) '(eql :key) `(or (eql not) (eql ,#'not))) 4) (def-type-prop-test assoc.4 'assoc (list 'real #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons real t) (cons (eql ,x) t)))) `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) 4) (def-type-prop-test assoc-if.1 'assoc-if (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test assoc-if.2 'assoc-if (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons real t))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test assoc-if-not.1 'assoc-if-not (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test assoc-if-not.2 'assoc-if-not (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons real t))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test copy-alist 'copy-alist (list #'(lambda () (make-list-type (random 10) 'null '(or null (cons t t))))) 1) (def-type-prop-test pairlis.1 'pairlis (list 'list #'(lambda (x) (make-list-type (length x) 'null t))) 2) (def-type-prop-test pairlis.2 'pairlis (list 'list #'(lambda (x) (make-list-type (length x) 'null t)) #'(lambda (x y) (make-list-type (random 6) 'null '(or null (cons t t))))) 3) (def-type-prop-test rassoc.1 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) (def-type-prop-test rassoc.2 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x)))))) 2) (def-type-prop-test rassoc.3 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x))))) '(eql :key) `(or (eql not) (eql ,#'not))) 4) (def-type-prop-test rassoc.4 'rassoc (list 'real #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t real) (cons t (eql ,x))))) `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) 4) (def-type-prop-test rassoc-if.1 'rassoc-if (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test rassoc-if.2 'rassoc-if (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons t real))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test rassoc-if-not.1 'rassoc-if-not (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test rassoc-if-not.2 'rassoc-if-not (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) (make-list-type (random 8) 'null '(or null (cons t real))) '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) ;;; We don't use numbers or characters as indicators, since the test is EQ, ;;; which is not well-behaved on these types. (def-type-prop-test get-properties.1 'get-properties (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) 'list) 2) (def-type-prop-test get-properties.2 'get-properties (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) #'(lambda (plist) (let ((len (length plist))) (if (= len 0) '(cons t null) (let ((ind (elt plist (* 2 (random (floor len 2)))))) `(cons (eql ,ind) null)))))) 2) (def-type-prop-test getf.1 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) t) 2) (def-type-prop-test getf.2 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) #'(lambda (plist) (let ((len (length plist))) (if (= len 0) t (let ((ind (elt plist (* 2 (random (floor len 2)))))) `(eql ,ind)))))) 2) (def-type-prop-test getf.3 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) t t) 3) (def-type-prop-test intersection.1 'intersection '(list list) 2 :test #'same-set-p) (def-type-prop-test intersection.2 'intersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p) (def-type-prop-test intersection.3 'intersection (list #'(lambda () (make-list-type (random 10) 'null 'integer)) #'(lambda (x) (make-list-type (random 10) 'null 'integer)) '(eql :key) `(member 1+ ,#'1+)) 4 :test #'same-set-p) (def-type-prop-test intersection.4 'intersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :key) `(member car ,#'car)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car))) (def-type-prop-test intersection.5 'intersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :test) `(member equal ,#'equal)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car))) (def-type-prop-test nintersection.1 'nintersection '(list list) 2 :test #'same-set-p :replicate '(t t)) (def-type-prop-test nintersection.2 'nintersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p :replicate '(t t nil nil)) (def-type-prop-test nintersection.3 'nintersection (list #'(lambda () (make-list-type (random 10) 'null 'integer)) #'(lambda (x) (make-list-type (random 10) 'null 'integer)) '(eql :key) `(member 1+ ,#'1+)) 4 :test #'same-set-p :replicate '(t t nil nil)) (def-type-prop-test nintersection.4 'nintersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :key) `(member car ,#'car)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car)) :replicate '(t t nil nil)) (def-type-prop-test nintersection.5 'nintersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) '(eql :test) `(member equal ,#'equal)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car)) :replicate '(t t nil nil)) (def-type-prop-test adjoin.1 'adjoin '(t list) 2) (def-type-prop-test adjoin.2 'adjoin '((integer 0 1) list) 2) (def-type-prop-test adjoin.3 'adjoin `((integer 0 10) (cons number (cons number (cons number null))) (eql :test) (or (eql =) (eql ,#'=))) 4) (def-type-prop-test adjoin.4 'adjoin `(number (cons number (cons number (cons number (cons number null)))) (eql :test-not) (or (eql /=) (eql ,#'/=))) 4) (def-type-prop-test adjoin.5 'adjoin `(number (cons number (cons number (cons number (cons number null)))) (eql :key) (or (member 1+ 1- ,#'1+ ,#'1-))) 4) (def-type-prop-test pushnew.1 '(lambda (x y) (list (pushnew x y) y)) '(t list) 2) (def-type-prop-test pushnew.2 '(lambda (x y) (list (pushnew x y) y)) '((integer 0 1) list) 2) (def-type-prop-test pushnew.3 '(lambda (x y) (list (pushnew x y :test #'=) y)) `((integer 0 10) (cons number (cons number (cons number null)))) 2) (def-type-prop-test pushnew.4 '(lambda (x y) (list (pushnew x y :test-not #'/=) y)) `((integer 0 10) (cons number (cons number (cons number null)))) 2) (def-type-prop-test pushnew.5 '(lambda (x y) (list (pushnew x y :key #'1+) y)) `(number (cons number (cons number (cons number (cons number null))))) 2) (def-type-prop-test set-difference.1 'set-difference '(list list) 2) (def-type-prop-test set-difference.2 'set-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2) (def-type-prop-test set-difference.3 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4) (def-type-prop-test set-difference.4 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4) (def-type-prop-test set-difference.5 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4) (def-type-prop-test nset-difference.1 'nset-difference '(list list) 2 :replicate '(t t)) (def-type-prop-test nset-difference.2 'nset-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2 :replicate '(t t)) (def-type-prop-test nset-difference.3 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-difference.4 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-difference.5 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4 :replicate '(t t nil nil)) (def-type-prop-test set-exclusive-or.1 'set-exclusive-or '(list list) 2) (def-type-prop-test set-exclusive-or.2 'set-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2) (def-type-prop-test set-exclusive-or.3 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4) (def-type-prop-test set-exclusive-or.4 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4) (def-type-prop-test set-exclusive-or.5 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4) (def-type-prop-test nset-exclusive-or.1 'nset-exclusive-or '(list list) 2 :replicate '(t t)) (def-type-prop-test nset-exclusive-or.2 'nset-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2 :replicate '(t t)) (def-type-prop-test nset-exclusive-or.3 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test) (member = ,#'=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-exclusive-or.4 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) (eql :test-not) (member /= ,#'/=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-exclusive-or.5 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4 :replicate '(t t nil nil)) (def-type-prop-test subsetp.1 'subsetp '(list list) 2) (def-type-prop-test subsetp.2 'subsetp '((cons integer null) (cons integer (cons integer (cons integer (cons integer null))))) 2) gcl-2.7.1/ansi-tests/PaxHeaders/defclass-aux.lsp0000644000000000000000000000013214542551762016550 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.505789241 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defclass-aux.lsp0000644000175000017500000002417414542551762016156 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 24 03:40:24 2003 ;;;; Contains: Auxiliary functions for testing CLOS (in-package :cl-test) (defun make-defclass-test-name (&rest args) (intern (apply #'concatenate 'string (mapcar #'string args)) (find-package :cl-test))) (defparameter *defclass-slot-readers* nil) (defparameter *defclass-slot-writers* nil) (defparameter *defclass-slot-accessors* nil) (defstruct my-class (name nil :type symbol) (direct-superclass-names nil :type list) (slots nil :type list) (default-initargs nil :type list) (metaclass 'standard-class :type symbol) (documentation nil :type (or null string)) ;; Internal fields (preds nil :type list) (succs nil :type list) (count 0 :type integer) (index nil) (min-pred-index 1000000) ) (defstruct my-slot (name nil :type symbol) (has-initform nil :type boolean) initform (initargs nil :type list) (documentation nil :type (or null string)) (readers nil :type list) (writers nil :type list) (accessors nil :type list) (allocation :instance :type (member :instance :class)) (type t) ) (defparameter *my-classes* (make-hash-table) "Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS to their my-class objects.") (defun find-my-class (class-name) (gethash class-name *my-classes*)) ;;; This macro will assume that all the superclasses have already ;;; been defined. Tests will be written with defclass itself ;;; to test forward referenced superclasses (defmacro defclass-with-tests (&whole args class-name superclasses slot-specifiers &rest class-options) (assert (typep class-name '(and (not null) symbol))) (assert (listp superclasses)) (assert (every #'(lambda (x) (typep x '(and (not null) symbol))) superclasses)) (assert (listp slot-specifiers)) (assert (every #'(lambda (s) (or (symbolp s) (and (consp s) (symbolp (car s))))) slot-specifiers)) (assert (every #'(lambda (x) (and (consp x) (member (car x) '(:default-initargs :documentation :metaclass)))) class-options)) (assert (eql (length class-options) (length (remove-duplicates class-options)))) (let* ((default-initargs (rest (assoc :default-initargs class-options))) (metaclass (or (second (assoc :metaclass class-options)) 'standard-class)) (doc (second (assoc :documentation class-options))) (slot-names (loop for slot-spec in slot-specifiers collect (cond ((symbolp slot-spec) slot-spec) (t (assert (consp slot-spec)) (assert (symbolp (car slot-spec))) (car slot-spec))))) (slot-options (loop for slot-spec in slot-specifiers collect (if (consp slot-spec) (cdr slot-spec) nil))) (readers (loop for slot-option in slot-options append (collect-properties slot-option :reader))) (writers (loop for slot-option in slot-options append (collect-properties slot-option :writer))) (accessors (loop for slot-option in slot-options append (collect-properties slot-option :accessor))) (allocations (loop for slot-option in slot-options collect (or (get slot-option :allocation) :instance))) (initargs (loop for slot-option in slot-options collect (collect-properties slot-option :initarg))) (types (loop for slot-option in slot-options collect (collect-properties slot-option :type))) (initforms (loop for slot-option in slot-options collect (collect-properties slot-option :initform))) (class-var-name (intern (concatenate 'string "*CLASS-" (symbol-name class-name) "-RETURNED-BY-DEFCLASS*") (find-package :cl-test))) ) (declare (ignorable readers writers accessors allocations initargs types initforms default-initargs doc)) (assert (loop for e in types always (< (length e) 2))) (assert (loop for e in initforms always (< (length e) 2))) (setf *defclass-slot-readers* (append readers *defclass-slot-readers*)) (setf *defclass-slot-writers* (append writers *defclass-slot-writers*)) (setf *defclass-slot-accessors* (append accessors *defclass-slot-accessors*)) ;;; Store away information about the class and its slots ;;; in a my-class object and associated my-slot objects. (let* ((my-slots (loop for name in slot-names for slot-option in slot-options for readers = (collect-properties slot-option :reader) for writers = (collect-properties slot-option :writer) for accessors = (collect-properties slot-option :accessor) for documentation = (getf slot-option :documentation) for initarg-list in initargs for type-list in types for initform-list in initforms for allocation in allocations collect (make-my-slot :name name :has-initform (notnot initform-list) :initform (first initform-list) :documentation documentation :readers readers :writers writers :accessors accessors :type (if type-list (first type-list) t) ))) (my-class-obj (make-my-class :name class-name :direct-superclass-names superclasses :default-initargs default-initargs :documentation doc :metaclass metaclass :slots my-slots))) (setf (gethash class-name *my-classes*) my-class-obj)) `(progn (declaim (special ,class-var-name)) (report-and-ignore-errors (setq ,class-var-name (defclass ,@(cdr args)))) (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS") (eqt (find-class ',class-name) ,class-var-name) t) (deftest ,(make-defclass-test-name class-name "-IS-IN-ITS-METACLASS") (notnot-mv (typep (find-class ',class-name) ',metaclass)) t) ,@(when (eq metaclass 'standard-class) `((deftest ,(make-defclass-test-name class-name "S-ARE-STANDARD-OBJECTS") (subtypep* ',class-name 'standard-object) t t))) ,@(loop for slot-name in slot-names collect `(deftest ,(make-defclass-test-name class-name "-HAS-SLOT-NAMED-" slot-name) (notnot-mv (slot-exists-p (make-instance ',class-name) ',slot-name)) t)) (deftest ,(make-defclass-test-name class-name "-ALLOCATE-INSTANCE") (defclass-allocate-instance-test ',class-name ',slot-names) nil) ))) (defun defclass-allocate-instance-test (class-name slot-names) (let* ((class (find-class class-name)) (instance (allocate-instance class))) (append (unless (eql (class-of instance) class) (list (list 'not-instance-of class-name))) (loop for slot in slot-names when (slot-boundp instance slot) collect (list 'is-bound slot)) (loop for slot in slot-names unless (equal (multiple-value-list (notnot-mv (slot-exists-p instance slot))) '(t)) collect (list 'does-not-exist slot)) (let ((bad-slot '#:foo)) (when (slot-exists-p instance bad-slot) (list (list 'should-not-exist bad-slot)))) ))) (defmacro generate-slot-tests () "Generate generic tests from the read/writer/accessor functions for slots from defclass-with-tests." (let ((funs (remove-duplicates (append *defclass-slot-readers* *defclass-slot-writers* *defclass-slot-accessors*)))) `(progn (deftest class-readers/writers/accessors-are-generic-functions (loop for sym in ',funs unless (typep (symbol-function sym) 'generic-function) collect sym) nil) (deftest class-accessors-have-generic-setf-functions (append ,@(loop for sym in *defclass-slot-accessors* collect `(and (not (typep (function (setf ,sym)) 'generic-function)) '(,sym)))) nil)))) (defun my-compute-class-precedence-list (class-name) "Compute the class precdence list for classes defined using DEFCLASS-WITH-TESTS." (let ((class-names nil) (class-names-to-consider (list class-name)) classes) ;; Find all classes (loop while class-names-to-consider do (let ((name (pop class-names-to-consider))) (unless (member name class-names) (push name class-names) (let ((my-class (find-my-class name))) (assert my-class) (setq class-names-to-consider (append (my-class-direct-superclass-names my-class) class-names-to-consider)))))) (setq class-names (reverse class-names)) (assert (eq class-name (first class-names))) ;; class-names now contains class-name (which occurs first) and ;; the names of all its superclasses except T (setq classes (mapcar #'find-my-class class-names)) ;; Walk the classes and set the predecessor links in the ;; class precedence DAG (loop for c in classes for dsns = (my-class-direct-superclass-names c) do (let ((pred c)) (loop for superclass-name in dsns for superclass = (find-my-class superclass-name) do (push pred (my-class-preds superclass)) do (pushnew superclass (my-class-succs pred)) do (incf (my-class-count superclass)) do (setq pred superclass)))) ;; The list candidates will contain all the classes ;; for which the count is zero. These are the candidates ;; for selection as the next class in the class precedence list (let ((candidates (loop for c in classes when (zerop (my-class-count c)) collect c)) (n 0) (result nil)) (assert (equal candidates (list (first classes)))) (loop while candidates do (let* ((next (first candidates)) (min-pred-index (my-class-min-pred-index next))) (loop for c in (rest candidates) for c-min-pred-index = (my-class-min-pred-index c) do (cond ((< c-min-pred-index min-pred-index) (setq next c min-pred-index c-min-pred-index)) (t (assert (not (= c-min-pred-index min-pred-index)))))) (setq candidates (remove next candidates)) (setf (my-class-index next) (incf n)) (push next result) (loop for succ in (my-class-succs next) do (decf (my-class-count succ)) do (setf (my-class-min-pred-index succ) (min (my-class-min-pred-index succ) n)) do (when (zerop (my-class-count succ)) (push succ candidates))))) (assert (eql (length result) (length classes))) (setq result (reverse result)) (mapcar #'my-class-name result)))) gcl-2.7.1/ansi-tests/PaxHeaders/trace.lsp0000644000000000000000000000013114542551763015267 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.505789241 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/trace.lsp0000644000175000017500000001122014542551763014662 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 19:53:11 2004 ;;;; Contains: Tests of TRACE, UNTRACE (in-package :cl-test) (defun function-to-trace (x) (car x)) (defun another-function-to-trace (x) (cdr x)) (defun (setf function-to-trace) (val arg) (setf (car arg) val)) (declaim (notinline function-to-trace another-function-to-trace (setf function-to-trace))) (deftest trace.1 (progn (untrace) ;; ensure it's not traced (with-output-to-string (*trace-output*) (assert (eql (function-to-trace '(a)) 'a)))) "") (deftest trace.2 (progn (trace function-to-trace) (equal "" (with-output-to-string (*trace-output*) (assert (eql (function-to-trace '(b)) 'b))))) nil) (deftest trace.3 (progn (untrace) (trace function-to-trace) (prog1 (trace) (untrace) (assert (null (trace))))) (function-to-trace)) (deftest trace.4 (progn (untrace) (trace function-to-trace) (handler-bind ((warning #'muffle-warning)) (trace function-to-trace)) (prog1 (trace) (untrace) (assert (null (trace))))) (function-to-trace)) (deftest trace.5 (progn (untrace) (trace (setf function-to-trace)) (prog1 (trace) (untrace) (assert (null (trace))))) ((setf function-to-trace))) (deftest trace.6 (progn (untrace) (trace (setf function-to-trace)) (handler-bind ((warning #'muffle-warning)) (trace (setf function-to-trace))) (prog1 (trace) (untrace) (assert (null (trace))))) ((setf function-to-trace))) (deftest trace.7 (progn (untrace) (with-output-to-string (*trace-output*) (let ((x (list nil))) (assert (eql (setf (function-to-trace x) 'a) 'a)) (assert (equal x '(a)))))) "") (deftest trace.8 (progn (untrace) (trace (setf function-to-trace)) (equal "" (with-output-to-string (*trace-output*) (let ((x (list nil))) (assert (eql (setf (function-to-trace x) 'a) 'a)) (assert (equal x '(a))))))) nil) (deftest trace.9 (progn (untrace) (trace function-to-trace another-function-to-trace) (assert (not (equal "" (with-output-to-string (*trace-output*) (assert (eql (function-to-trace '(b)) 'b)))))) (assert (not (equal "" (with-output-to-string (*trace-output*) (assert (eql (another-function-to-trace '(c . d)) 'd)))))) (prog1 (sort (copy-list (trace)) #'(lambda (k1 k2) (string< (symbol-name k1) (symbol-name k2)))) (untrace))) (another-function-to-trace function-to-trace)) (deftest trace.10 (progn (untrace) (assert (null (trace))) (trace function-to-trace) (untrace function-to-trace) (assert (null (trace))) (handler-bind ((warning #'muffle-warning)) (untrace function-to-trace)) (assert (null (trace))) nil) nil) (deftest trace.11 (progn (untrace) (trace function-to-trace another-function-to-trace) (untrace function-to-trace another-function-to-trace) (trace)) nil) ;;; Tracing a generic function (declaim (notinline generic-function-to-trace)) (deftest trace.12 (progn (untrace) (eval '(defgeneric generic-function-to-trace (x y))) (trace generic-function-to-trace) (prog1 (trace) (untrace))) (generic-function-to-trace)) (deftest trace.13 (progn (untrace) (eval '(defgeneric generic-function-to-trace (x y))) (trace generic-function-to-trace) (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil)) (prog1 (trace) (untrace))) (generic-function-to-trace)) (deftest trace.14 (progn (untrace) (eval '(defgeneric generic-function-to-trace (x y))) (trace generic-function-to-trace) (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil)) (assert (not (equal (with-output-to-string (*trace-output*) (assert (null (generic-function-to-trace 'a 'b)))) ""))) (prog1 (trace) (untrace generic-function-to-trace) (assert (null (trace))))) (generic-function-to-trace)) (declaim (notinline generic-function-to-trace2)) (deftest trace.15 (progn (untrace) (let* ((gf (eval '(defgeneric generic-function-to-trace2 (x y)))) (m (eval '(defmethod generic-function-to-trace2 ((x integer)(y integer)) :foo)))) (eval '(defmethod generic-function-to-trace2 ((x symbol)(y symbol)) :bar)) (assert (eql (generic-function-to-trace2 1 2) :foo)) (assert (eql (generic-function-to-trace2 'a 'b) :bar)) (trace generic-function-to-trace2) (assert (equal (trace) '(generic-function-to-trace2))) (remove-method gf m) (prog1 (trace) (untrace)))) (generic-function-to-trace2)) gcl-2.7.1/ansi-tests/PaxHeaders/read-preserving-whitespace.lsp0000644000000000000000000000013114542551763021420 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.505789241 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-preserving-whitespace.lsp0000644000175000017500000001056514542551763021026 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 08:54:28 2005 ;;;; Contains: Tests of READ-PRESERVING-WHITESPACE (in-package :cl-test) ;;; Input stream designators (deftest read-preserving-whitespace.1 (block done (with-input-from-string (is "1 2 3") (with-output-to-string (os) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (return-from done (read-preserving-whitespace t)))))) 1) (deftest read-preserving-whitespace.2 (with-input-from-string (*standard-input* "1 2 3") (read-preserving-whitespace nil)) 1) (deftest read-preserving-whitespace.3 (with-input-from-string (*standard-input* "1 2 3") (read-preserving-whitespace)) 1) (deftest read-preserving-whitespace.4 (with-input-from-string (s "1 2 3") (read-preserving-whitespace s)) 1) ;;; eof handling (deftest read-preserving-whitespace.5 (with-input-from-string (s "") (read-preserving-whitespace s nil)) nil) (deftest read-preserving-whitespace.6 (with-input-from-string (s "") (read-preserving-whitespace s nil 'foo)) foo) (deftest read-preserving-whitespace.7 (with-input-from-string (s "1") (read-preserving-whitespace s)) 1) (deftest read-preserving-whitespace.8 (let ((*package* (find-package "CL-TEST"))) (with-input-from-string (s "X") (read-preserving-whitespace s))) |X|) (deftest read-preserving-whitespace.9 (with-input-from-string (s "1.2") (read-preserving-whitespace s)) 1.2) (deftest read-preserving-whitespace.10 (with-input-from-string (s "1.0s0") (read-preserving-whitespace s)) 1.0s0) (deftest read-preserving-whitespace.11 (with-input-from-string (s "1.0f0") (read-preserving-whitespace s)) 1.0f0) (deftest read-preserving-whitespace.12 (with-input-from-string (s "1.0d0") (read-preserving-whitespace s)) 1.0d0) (deftest read-preserving-whitespace.13 (with-input-from-string (s "1.0l0") (read-preserving-whitespace s)) 1.0l0) (deftest read-preserving-whitespace.14 (with-input-from-string (s "()") (read-preserving-whitespace s)) nil) (deftest read-preserving-whitespace.15 (with-input-from-string (s "(1 2 3)") (read-preserving-whitespace s)) (1 2 3)) ;;; Throwing away whitespace chars (deftest read-preserving-whitespace.16 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read-preserving-whitespace s) :|ABC|)) (read-char s))) #\Space) (deftest read-preserving-whitespace.17 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read-preserving-whitespace s) :|ABC|)) (read-char s))) #\Space) (deftest read-preserving-whitespace.18 (with-standard-io-syntax (with-input-from-string (s ":ABC(") (assert (eq (read-preserving-whitespace s) :|ABC|)) (read-char s))) #\() ;;; eof value (deftest read-preserving-whitespace.19 (with-input-from-string (s "") (read-preserving-whitespace s nil 'foo)) foo) ;;; Error tests (deftest read-preserving-whitespace.error.1 (signals-error (with-input-from-string (s "") (read-preserving-whitespace s)) end-of-file) t) (deftest read-preserving-whitespace.error.2 (signals-error (with-input-from-string (s "") (read-preserving-whitespace s)) stream-error) t) (deftest read-preserving-whitespace.error.3 (signals-error (with-input-from-string (s "") (read-preserving-whitespace s t)) stream-error) t) (deftest read-preserving-whitespace.error.4 (signals-error (with-input-from-string (s "(") (read-preserving-whitespace s nil)) end-of-file) t) (deftest read-preserving-whitespace.error.5 (signals-error (with-input-from-string (s "(") (read-preserving-whitespace s t)) end-of-file) t) (deftest read-preserving-whitespace.error.6 (signals-error (with-input-from-string (s "#(") (read-preserving-whitespace s t)) end-of-file) t) (deftest read-preserving-whitespace.error.7 (signals-error (with-input-from-string (s "#S(") (read-preserving-whitespace s t)) end-of-file) t) ;;; Note -- cannot easily test calls with RECURSIVE-P set to T. These have to be ;;; done from read-preserving-whitespaceer macro functions so that READ-PRESERVING-WHITESPACE ;;; is not called without having any requisite dynamic environment created ;;; around the call. (deftest read-preserving-whitespace.error.8 (signals-error (with-input-from-string (s "1 2 3") (read-preserving-whitespace s nil nil nil nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/find-class.lsp0000644000000000000000000000013214542551762016214 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.505789241 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find-class.lsp0000644000175000017500000001677314542551762015630 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu May 29 07:15:06 2003 ;;;; Contains: Tests of FIND-CLASS ;; find-class is also tested in numerous other places. (in-package :cl-test) (deftest find-class.1 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name) (find-class name)) collect name) nil) (deftest find-class.2 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name t) (find-class name)) collect name) nil) (deftest find-class.3 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name nil) (find-class name)) collect name) nil) (deftest find-class.4 (handler-case (progn (eval '(find-class (gensym))) :bad) (error () :good)) :good) (deftest find-class.5 (handler-case (progn (eval '(find-class (gensym) t)) :bad) (error () :good)) :good) (deftest find-class.6 (find-class (gensym) nil) nil) (deftest find-class.7 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name t nil) (find-class name)) collect name) nil) (deftest find-class.8 (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name nil nil) (find-class name)) collect name) nil) (deftest find-class.9 (macrolet ((%m (&environment env) (let ((result (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name nil env) (find-class name)) collect name))) `',result))) (%m)) nil) (deftest find-class.10 (macrolet ((%m (&environment env) (let ((result (loop for name in *cl-types-that-are-classes-symbols* unless (eq (find-class name t env) (find-class name)) collect name))) `',result))) (%m)) nil) (deftest find-class.11 (handler-case (progn (eval '(find-class (gensym) 'a nil)) :bad) (error () :good)) :good) (deftest find-class.12 (find-class (gensym) nil nil) nil) (deftest find-class.13 (macrolet ((%m (&environment env) `',(find-class (gensym) nil env))) (%m)) nil) (deftest find-class.14 (handler-case (progn (eval '(macrolet ((%m (&environment env) `',(find-class (gensym) 17 env))) (%m))) :bad) (error () :good)) :good) ;;; Need tests of assignment to (FIND-CLASS ...) ;;; Add tests of: ;;; Setting class to itself ;;; Changing class to a different class ;;; Changing to NIL (and that the class object stays around) ;;; Check that find-class is affected by the assignment, and ;;; class-name is not. (deftest find-class.15 (progn (setf (find-class 'find-class-class-01) nil) (let* ((class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01) class1))) (values (eqt class class1) (eqt class class2) (class-name class) ))) t t find-class-class-01) (deftest find-class.16 (progn (setf (find-class 'find-class-class-01 nil) nil) (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error (let* ((i 0) (class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01 (incf i)) class1))) (values i (eqt class class1) (eqt class class2)))) 1 t t) (deftest find-class.17 (macrolet ((%m (&environment env) `',(progn (setf (find-class 'find-class-class-01) nil) (let* ((i 0) x y z (class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class (progn (setf x (incf i)) 'find-class-class-01) (setf y (incf i)) (progn (setf z (incf i)) env))) (class2 (setf (find-class 'find-class-class-01) class1))) (list (eqt class class1) (eqt class class2) i x y z ))))) (%m)) (t t 3 1 2 3)) (deftest find-class.18 (progn (setf (find-class 'find-class-class-01) nil) (let* ((class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01) nil)) (class3 (find-class 'find-class-class-01 nil))) (values (eqt class class1) (eqt class class2) class2 (class-name class) class3))) t nil nil find-class-class-01 nil) (deftest find-class.19 (progn (setf (find-class 'find-class-class-01 nil) nil) (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error (let* ((class (eval '(defclass find-class-class-01 () ()))) (class1 (find-class 'find-class-class-01)) (class2 (setf (find-class 'find-class-class-01 t nil) class1))) (values (eqt class class1) (eqt class class2)))) t t) ;; Change to a different class (deftest find-class.20 (progn (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (class2 (eval '(defclass find-class-class-02 () ())))) (setf (find-class 'find-class-class-01) class2) (let* ((new-class1 (find-class 'find-class-class-01 nil)) (new-class2 (find-class 'find-class-class-02))) (values (eqt class1 class2) (eqt class2 new-class1) (eqt class2 new-class2) (class-name class2))))) nil t t find-class-class-02) (deftest find-class.21 (progn (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (class2 (eval '(defclass find-class-class-02 () ())))) (psetf (find-class 'find-class-class-01) class2 (find-class 'find-class-class-02) class1) (let* ((new-class1 (find-class 'find-class-class-01 nil)) (new-class2 (find-class 'find-class-class-02))) (values (eqt class1 class2) (eqt class2 new-class1) (eqt class1 new-class2) (class-name new-class1) (class-name new-class2) )))) nil t t find-class-class-02 find-class-class-01) ;;; Effect on method dispatch (deftest find-class.22 (progn (setf (find-class 'find-class-class-01) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (fn (eval '(defgeneric find-class-gf-01 (x) (:method ((x find-class-class-01)) :good) (:method ((x t)) nil)))) (obj (make-instance class1))) (assert (typep fn 'function)) (locally (declare (type function fn)) (values (funcall fn nil) (funcall fn obj) (setf (find-class 'find-class-class-01) nil) (funcall fn nil) (funcall fn obj))))) nil :good nil nil :good) (deftest find-class.23 (progn (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) (class2 (eval '(defclass find-class-class-02 (find-class-class-01) ()))) (fn (eval '(defgeneric find-class-gf-02 (x) (:method ((x find-class-class-01)) 1) (:method ((x find-class-class-02)) 2) (:method ((x t)) t)))) (obj1 (make-instance class1)) (obj2 (make-instance class2))) (assert (typep fn 'function)) (locally (declare (type function fn)) (values (funcall fn nil) (funcall fn obj1) (funcall fn obj2) (setf (find-class 'find-class-class-01) nil) (funcall fn nil) (funcall fn obj1) (funcall fn obj2))))) t 1 2 nil t 1 2) ;;; Error tests (deftest find-class.error.1 (signals-error (find-class) program-error) t) (deftest find-class.error.2 (signals-error (find-class 'symbol nil nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/defmethod.lsp0000644000000000000000000000013214542551762016130 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.505789241 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defmethod.lsp0000644000175000017500000001545414542551762015537 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 9 07:02:53 2005 ;;;; Contains: Separate tests for DEFMETHOD (in-package :cl-test) (deftest defmethod.1 (let ((sym (gensym))) (values (typep* (eval `(defmethod ,sym (x) (list x))) 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.2 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer)) (list x))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.3 (let* ((sym (gensym)) (method (eval `(let ((x 0)) (defmethod ,sym ((x (eql (incf x)))) (list x)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 1))) t t (1) (1)) (deftest defmethod.4 (let* ((sym (gensym)) (method (eval `(defmethod (setf ,sym) ((x t) (y cons)) (setf (car y) x))))) (values (typep* method 'standard-method) (fboundp sym) (typep* (fdefinition `(setf ,sym)) 'standard-generic-function) (let ((x (cons 1 2))) (list (funcall (fdefinition `(setf ,sym)) 3 x) x)))) t nil t (3 (3 . 2))) (deftest defmethod.5 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer)) (return-from ,sym (list x)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.6 (let* ((sym (gensym)) (method (eval `(defmethod (setf ,sym) ((x t) (y cons)) (return-from ,sym (setf (car y) x)))))) (values (typep* method 'standard-method) (fboundp sym) (typep* (fdefinition `(setf ,sym)) 'standard-generic-function) (let ((x (cons 1 2))) (list (funcall (fdefinition `(setf ,sym)) 3 x) x)))) t nil t (3 (3 . 2))) (deftest defmethod.7 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &aux (y (list x))) y)))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1))) t t (1)) (deftest defmethod.8 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &key z) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 :z 3) (funcall sym 4 :allow-other-keys nil) (funcall sym 5 :allow-other-keys t :bogus 17) (funcall sym 6 :allow-other-keys t :allow-other-keys nil :bogus 17) )) t t (1 nil) (2 3) (4 nil) (5 nil) (6 nil)) (deftest defmethod.9 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &key (z :missing)) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 :z 3) (funcall sym 4 :allow-other-keys nil) )) t t (1 :missing) (2 3) (4 :missing)) (deftest defmethod.10 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &key (z :missing z-p)) (list x z (notnot z-p)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 :z 3) (funcall sym 4 :allow-other-keys nil) )) t t (1 :missing nil) (2 3 t) (4 :missing nil)) (deftest defmethod.11 (let* ((sym (gensym)) (method (eval `(defmethod ,sym ((x integer) &rest z) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) (funcall sym 1) (funcall sym 2 3) )) t t (1 nil) (2 (3))) ;;; Error cases ;;; Lambda liss not congruent (deftest defmethod.error.1 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y))) (eval `(signals-error (defmethod ,sym ((x t)) x) error))) t) (deftest defmethod.error.2 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y))) (eval `(signals-error (defmethod ,sym ((x t) (y t) (z t)) (list x y z)) error))) t) (deftest defmethod.error.3 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y &optional z))) (eval `(signals-error (defmethod ,sym ((x t) (y t) (z t)) (list x y z)) error))) t) (deftest defmethod.error.4 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y &optional z))) (eval `(signals-error (defmethod ,sym ((x t) (y t) &optional) (list x y)) error))) t) (deftest defmethod.error.5 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y &optional z))) (eval `(signals-error (defmethod ,sym ((x t) (y t) &optional z w) (list x y z w)) error))) t) (deftest defmethod.error.6 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &rest z))) (eval `(signals-error (defmethod ,sym ((x t)) (list x)) error))) t) (deftest defmethod.error.7 (let ((sym (gensym))) (eval `(defgeneric ,sym (x))) (eval `(signals-error (defmethod ,sym ((x t) &rest z) (list x z)) error))) t) (deftest defmethod.error.8 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &key z))) (eval `(signals-error (defmethod ,sym ((x t)) (list x)) error))) t) (deftest defmethod.error.9 (let ((sym (gensym))) (eval `(defgeneric ,sym (x))) (eval `(signals-error (defmethod ,sym ((x t) &key z) (list x z)) error))) t) (deftest defmethod.error.10 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &key z))) (eval `(signals-error (defmethod ,sym ((x t) &key) x) error))) t) (deftest defmethod.error.11 (let ((sym (gensym))) (eval `(defgeneric ,sym (x &key))) (eval `(signals-error (defmethod ,sym ((x t)) x) error))) t) (deftest defmethod.error.12 (let ((sym (gensym))) (eval `(defgeneric ,sym (x))) (eval `(signals-error (defmethod ,sym ((x t) &key) x) error))) t) ;;; Calling the implicitly defined generic function (deftest defmethod.error.13 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t)) x))) (values (eval `(signals-error (,sym) program-error)) (eval `(signals-error (,sym 1 2) program-error)))) t t) (deftest defmethod.error.14 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key) x))) (values (eval `(signals-error (,sym) program-error)) (eval `(signals-error (,sym 1 2) program-error)) (eval `(signals-error (,sym 1 :bogus t) program-error)) (eval `(signals-error (,sym 1 :allow-other-keys nil :allow-other-keys t :bogus t) program-error)))) t t t t) (deftest defmethod.error.15 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key y) x))) (values (eval `(signals-error (,sym 1 :bogus t) program-error)) (eval `(signals-error (,sym 1 :y) program-error)) (eval `(signals-error (,sym 1 3 nil) program-error)))) t t t) gcl-2.7.1/ansi-tests/PaxHeaders/ignore.lsp0000644000000000000000000000013114542551762015453 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.505789241 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ignore.lsp0000644000175000017500000000133414542551762015053 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 07:59:24 2005 ;;;; Contains: Tests of the IGNORE declarations (in-package :cl-test) (deftest ignore.1 (let ((x 'foo)) (declare (ignore x))) nil) (deftest ignore.2 (let ((x 'foo)) (declare (ignore x)) x) foo) (deftest ignore.3 (flet ((%f () 'foo)) (declare (ignore (function %f)))) nil) (deftest ignore.4 (flet ((%f () 'foo)) (declare (ignore (function %f))) (%f)) foo) (deftest ignore.5 (flet (((setf %f) (x y) (setf (car y) x))) (declare (ignore (function (setf %f)))) :good) :good) (deftest ignore.6 (labels (((setf %f) (x y) (setf (car y) x))) (declare (ignore (function (setf %f)))) :good) :good) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-08.lsp0000644000000000000000000000013114542551763020773 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.505789241 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-08.lsp0000644000175000017500000002322314542551763020374 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 13 18:31:57 2005 ;;;; Contains: Random type prop tests, part 8 (sequences) (in-package :cl-test) (def-type-prop-test copy-seq 'copy-seq '((or vector list)) 1) (def-type-prop-test elt 'elt (list '(or vector list) #'(lambda (x) (let ((len (length x))) (and (> len 0) `(integer 0 (,len)))))) 2) (defmacro rfill (x y &rest other-args) `(fill ,y ,x ,@other-args)) (def-type-prop-test fill.1 'rfill (list t #'make-random-sequence-type-containing) 2 :replicate '(nil t)) (def-type-prop-test fill.2 'rfill (list 'integer #'make-random-sequence-type-containing) 2 :replicate '(nil t)) (def-type-prop-test fill.3 'rfill (list 'character #'make-random-sequence-type-containing) 2 :replicate '(nil t)) (def-type-prop-test fill.4 'rfill (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4 :replicate '(nil t nil nil)) (def-type-prop-test fill.5 'rfill (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len)))) 4 :replicate '(nil t nil nil)) (def-type-prop-test fill.6 'rfill (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (v s k1) (declare (ignore v k1)) (let ((len (length s))) `(integer 0 ,len))) '(eql :end) #'(lambda (v s k1 start k2) (declare (ignore v k1 k2)) (let ((len (length s))) `(integer ,start ,len)))) 6 :replicate '(nil t nil nil nil nil)) ;;; make-sequence tests here (def-type-prop-test subseq.1 'subseq (list 'sequence #'(lambda (s) `(integer 0 ,(length s)))) 2) (def-type-prop-test subseq.2 'subseq (list 'sequence #'(lambda (s) `(integer 0 ,(length s))) #'(lambda (s start) `(integer ,start ,(length s)))) 3) ;;; map tests here (def-type-prop-test map.1 'map (list '(member list vector) '(member list #.#'list) '(or list vector)) 3) (def-type-prop-test map.2 'map (list '(member list vector) '(member list #.#'list) '(or list vector) '(or list vector)) 4) (def-type-prop-test map.3 'map (list '(member list vector) '(member list #.#'list) '(or list vector) '(or list vector) '(or list vector)) 5) (def-type-prop-test map.4 'map (list '(member list vector (vector (unsigned-byte 32))) '(member 1+ #.#'1+) `(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i))))) 3) (def-type-prop-test map.5 'map (list `(member ,@(loop for i from 1 to 32 collect `(vector (unsigned-byte ,i)))) '(member 1+ #.#'1+) #'(lambda (type fun) (declare (ignore fun)) (let ((i (cadadr type))) `(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2)))))))) 3) ;;; map-into tests here (def-type-prop-test map-into.1 'map-into (list '(or list (vector t)) '(member list #.#'list) '(or list vector)) 3 :replicate '(t nil nil)) (def-type-prop-test map-into.2 'map-into (list '(or list (vector t)) '(member list #.#'list) '(or list vector) '(or list vector)) 4 :replicate '(t nil nil nil)) ;;; reduce tests here (def-type-prop-test count.1 'count '(t sequence) 2) (def-type-prop-test count.2 'count (list t #'make-random-sequence-type-containing) 2) (def-type-prop-test count.3 'count (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (x s k1) (declare (ignore x k1)) `(integer 0 ,(length s)))) 4) (def-type-prop-test count.4 'count (list t #'make-random-sequence-type-containing '(eql :end) #'(lambda (x s k1) (declare (ignore x k1)) `(integer 0 ,(length s)))) 4) (def-type-prop-test count.5 'count (list t #'make-random-sequence-type-containing '(eql :start) #'(lambda (x s k1) (declare (ignore x k1)) `(integer 0 ,(length s))) '(eql :end) #'(lambda (x s k1 start k2) (declare (ignore x k1 k2)) `(integer ,start ,(length s)))) 6) (def-type-prop-test count.6 'count (list '(or short-float single-float double-float long-float) #'(lambda (f) `(vector (or ,(typecase f (short-float 'short-float) (single-float 'single-float) (double-float 'double-float) (long-float 'long-float) (t 'float)) (eql ,f))))) 2) (def-type-prop-test count.7 'count '(bit (vector bit)) 2) (def-type-prop-test count.8 'count '((unsigned-byte 2) (vector (unsigned-byte 2))) 2) (def-type-prop-test count.9 'count '((unsigned-byte 4) (vector (unsigned-byte 4))) 2) (def-type-prop-test count.10 'count '((unsigned-byte 8) (vector (unsigned-byte 8))) 2) ;;; count-if tests (def-type-prop-test count-if.1 'count-if (list (let ((funs '(numberp rationalp realp floatp complexp symbolp identity null functionp listp consp arrayp vectorp simple-vector-p stringp simple-string-p bit-vector-p simple-bit-vector-p))) `(member ,@funs ,@(mapcar #'symbol-function funs))) '(or list vector)) 2) (def-type-prop-test count-if.2 'count-if (list (let ((funs '(numberp rationalp realp floatp complexp symbolp identity null functionp listp consp arrayp vectorp simple-vector-p stringp simple-string-p bit-vector-p simple-bit-vector-p))) `(member ,@funs ,@(mapcar #'symbol-function funs))) '(or list vector) '(eql :key) (let ((key-funs '(identity not null))) `(member ,@key-funs ,@(mapcar #'symbol-function key-funs)))) 4) ;;; Put count-if-not tests here (def-type-prop-test length.1 'length '(sequence) 1) (def-type-prop-test reverse.1 'reverse '(sequence) 1) (def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t)) (def-type-prop-test sort.1 'sort `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.2 'sort `((or (vector (unsigned-byte 2)) (vector (unsigned-byte 3)) (vector (unsigned-byte 4)) (vector (unsigned-byte 5)) (vector (unsigned-byte 6)) (vector (unsigned-byte 7)) (vector (unsigned-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.3 'sort `((or (vector (unsigned-byte 10)) (vector (unsigned-byte 13)) (vector (unsigned-byte 15)) (vector (unsigned-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.4 'sort `((or (vector (unsigned-byte 20)) (vector (unsigned-byte 24)) (vector (unsigned-byte 28)) (vector (unsigned-byte 31)) (vector (unsigned-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.5 'sort `((or (vector (signed-byte 2)) (vector (signed-byte 3)) (vector (signed-byte 4)) (vector (signed-byte 5)) (vector (signed-byte 6)) (vector (signed-byte 7)) (vector (signed-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.6 'sort `((or (vector (signed-byte 10)) (vector (signed-byte 13)) (vector (signed-byte 15)) (vector (signed-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.7 'sort `((or (vector (signed-byte 20)) (vector (signed-byte 24)) (vector (signed-byte 28)) (vector (signed-byte 31)) (vector (signed-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.8 'sort `((or (vector short-float) (vector single-float) (vector double-float) (vector long-float)) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) ;;; Stable sort (def-type-prop-test stable-sort.1 'stable-sort `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.2 'stable-sort `((or (vector (unsigned-byte 2)) (vector (unsigned-byte 3)) (vector (unsigned-byte 4)) (vector (unsigned-byte 5)) (vector (unsigned-byte 6)) (vector (unsigned-byte 7)) (vector (unsigned-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.3 'stable-sort `((or (vector (unsigned-byte 10)) (vector (unsigned-byte 13)) (vector (unsigned-byte 15)) (vector (unsigned-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.4 'stable-sort `((or (vector (unsigned-byte 20)) (vector (unsigned-byte 24)) (vector (unsigned-byte 28)) (vector (unsigned-byte 31)) (vector (unsigned-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.5 'stable-sort `((or (vector (signed-byte 2)) (vector (signed-byte 3)) (vector (signed-byte 4)) (vector (signed-byte 5)) (vector (signed-byte 6)) (vector (signed-byte 7)) (vector (signed-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.6 'stable-sort `((or (vector (signed-byte 10)) (vector (signed-byte 13)) (vector (signed-byte 15)) (vector (signed-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.7 'stable-sort `((or (vector (signed-byte 20)) (vector (signed-byte 24)) (vector (signed-byte 28)) (vector (signed-byte 31)) (vector (signed-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.8 'stable-sort `((or (vector short-float) (vector single-float) (vector double-float) (vector long-float)) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.9 'stable-sort `((vector (cons (integer 0 4) (eql nil))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=) (eql :key) (member car ,#'car)) 4 :replicate '(t nil nil nil) :test #'equalp-and-eql-elements) gcl-2.7.1/ansi-tests/PaxHeaders/loop9.lsp0000644000000000000000000000013214542551763015234 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.509789259 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop9.lsp0000644000175000017500000001320214542551763014630 0ustar00cammcamm;-*- 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 (signals-error (loop with foo = '(a b) for x in '(c d) collect x into foo finally (return foo)) program-error) t) (deftest loop.9.11 (signals-error (loop with foo = '(a b) for x in '(c d) collecting x into foo finally (return foo)) program-error) t) (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 (signals-error (loop with foo = '(a b) for x in '(c d) append (list x) into foo finally (return foo)) program-error) t) (deftest loop.9.28 (signals-error (loop with foo = '(a b) for x in '(c d) appending (list x) into foo finally (return foo)) program-error) t) ;;; 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 (signals-error (loop with foo = '(a b) for x in '(c d) nconc (list x) into foo finally (return foo)) program-error) t) (deftest loop.9.38 (signals-error (loop with foo = '(a b) for x in '(c d) nconcing (list x) into foo finally (return foo)) program-error) t) ;;; 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.9.43 (macrolet ((%m (z) z)) (loop for x in '(1 2 3) collect (expand-in-current-env (%m (- x))))) (-1 -2 -3)) (deftest loop.9.44 (macrolet ((%m (z) z)) (loop for x in '(1 2 3) collecting (expand-in-current-env (%m (list x))))) ((1) (2) (3))) (deftest loop.9.45 (macrolet ((%m (z) z)) (loop for x in '(a b c) collect (expand-in-current-env (%m (list x))) into foo finally (return (reverse foo)))) ((c) (b) (a))) (deftest loop.9.46 (macrolet ((%m (z) z)) (loop for x in '((a b) (c d) (e f g) () (i)) append (expand-in-current-env (%m x)))) (a b c d e f g i)) (deftest loop.9.47 (macrolet ((%m (z) z)) (loop for x in '((a b) (c d) (e f g) () (i)) nconc (expand-in-current-env (%m (copy-seq x))))) (a b c d e f g i)) gcl-2.7.1/ansi-tests/PaxHeaders/boole.lsp0000644000000000000000000000013014542551762015267 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.509789259 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/boole.lsp0000644000175000017500000000773514542551762014703 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 8 20:21:19 2003 ;;;; Contains: Tests of BOOLE and associated constants (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (defparameter *boole-val-names* '(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)) (defparameter *boole-vals* (list 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)) (defparameter *boole-fns* (list #'(lambda (x y) (declare (ignore y)) x) #'(lambda (x y) (declare (ignore x)) y) #'logand #'logandc1 #'logandc2 #'(lambda (x y) (declare (ignore y)) (lognot x)) #'(lambda (x y) (declare (ignore x)) (lognot y)) (constantly 0) #'logeqv #'logior #'lognand #'lognor #'logorc1 #'logorc2 (constantly -1) #'logxor)) (deftest boole.error.1 (signals-error (boole) program-error) t) (deftest boole.error.2 (signals-error (boole boole-1) program-error) t) (deftest boole.error.3 (signals-error (boole boole-1 1) program-error) t) (deftest boole.error.4 (signals-error (boole boole-1 1 2 nil) program-error) t) (deftest boole.error.5 (let ((bad (loop for i from 1 until (not (member i *boole-vals*))))) (eval `(signals-type-error x ',bad (boole x 1 1)))) t) (deftest boole.error.6 (loop for n in *boole-val-names* unless (eval `(signals-type-error x nil (boole ,n nil 1))) collect n) nil) (deftest boole.error.7 (loop for n in *boole-val-names* unless (eval `(signals-type-error x nil (boole ,n 1 nil))) collect n) nil) (deftest boole.1 (loop for v in *boole-vals* for fn of-type function in *boole-fns* for n in *boole-val-names* nconc (loop for x = (random-fixnum) for y = (random-fixnum) for result1 = (funcall (the function fn) x y) for vals = (multiple-value-list (boole v x y)) for result2 = (car vals) repeat 100 unless (and (= (length vals) 1) (eql result1 result2)) collect (list n x y result1 result2))) nil) (deftest boole.2 (loop for v in *boole-vals* for fn of-type function in *boole-fns* for n in *boole-val-names* nconc (loop for x = (random-from-interval 1000000000000000) for y = (random-from-interval 1000000000000000) for result1 = (funcall (the function fn) x y) for vals = (multiple-value-list (boole v x y)) for result2 = (car vals) repeat 100 unless (and (= (length vals) 1) (eql result1 result2)) collect (list n x y result1 result2))) nil) (deftest boole.3 (loop for n in *boole-val-names* for fn of-type function in *boole-fns* for fn2 = (compile nil `(lambda (x y) (declare (type fixnum x y)) (boole ,n x y))) nconc (loop for x = (random-fixnum) for y = (random-fixnum) for result1 = (funcall (the function fn) x y) for vals = (multiple-value-list (funcall fn2 x y)) for result2 = (car vals) repeat 100 unless (and (= (length vals) 1) (eql result1 result2)) collect (list n x y result1 result2))) nil) (deftest boole.4 (macrolet ((%m (z) z)) (values (boole (expand-in-current-env (%m boole-and)) #b11001100 #b01011010) (boole boole-and (expand-in-current-env (%m #b11001100)) #b01011010) (boole boole-and #b11001100 (expand-in-current-env (%m #b01011010))))) #b01001000 #b01001000 #b01001000) ;;; Order of evaluation (deftest boole.order.1 (let ((i 0) a b c) (values (boole (progn (setf a (incf i)) boole-and) (progn (setf b (incf i)) #b1101) (progn (setf c (incf i)) #b11001)) i a b c)) #b1001 3 1 2 3) ;;; Constants are constants (deftest boole.constants.1 (eqlt (length *boole-vals*) (length (remove-duplicates *boole-vals*))) t) (deftest boole.constants.2 (remove-if #'constantp *boole-val-names*) nil) (deftest boole.constants.3 (remove-if #'boundp *boole-val-names*) nil) gcl-2.7.1/ansi-tests/PaxHeaders/format-p.lsp0000644000000000000000000000013214542551762015716 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.509789259 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-p.lsp0000644000175000017500000000337114542551762015320 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 17 21:32:45 2004 ;;;; Contains: Tests of the ~P format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.p.1 "~p" (1) "") (def-format-test format.p.2 "~P" (2) "s") (def-format-test format.p.3 "~p" (0) "s") (def-format-test format.p.4 "~P" (1.0) "s") (deftest format.p.5 (loop for x in *universe* for s = (format nil "~p" x) unless (or (eql x 1) (string= s "s")) collect (list x s)) nil) (deftest formatter.p.5 (let ((fn (formatter "~p"))) (loop for x in *universe* for s = (formatter-call-to-string fn x) unless (or (eql x 1) (string= s "s")) collect (list x s))) nil) ;;; :p (def-format-test format.p.6 "~D cat~:P" (1) "1 cat") (def-format-test format.p.7 "~D cat~:p" (2) "2 cats") (def-format-test format.p.8 "~D cat~:P" (0) "0 cats") (def-format-test format.p.9 "~D cat~:p" ("No") "No cats") ;;; :@p (def-format-test format.p.10 "~D penn~:@P" (1) "1 penny") (def-format-test format.p.11 "~D penn~:@p" (2) "2 pennies") (def-format-test format.p.12 "~D penn~@:P" (0) "0 pennies") (def-format-test format.p.13 "~D penn~@:p" ("No") "No pennies") ;;; @p (def-format-test format.p.14 "~@p" (1) "y") (def-format-test format.p.15 "~@P" (2) "ies") (def-format-test format.p.16 "~@p" (0) "ies") (def-format-test format.p.17 "~@P" (1.0) "ies") (deftest format.p.18 (loop for x in *universe* for s = (format nil "~@p" x) unless (or (eql x 1) (string= s "ies")) collect (list x s)) nil) (deftest formatter.p.18 (let ((fn (formatter "~@P"))) (loop for x in *universe* for s = (formatter-call-to-string fn x) unless (or (eql x 1) (string= s "ies")) collect (list x s))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/load-structures.lsp0000644000000000000000000000013214772071557017335 xustar0030 mtime=1743287151.722907503 30 atime=1744294960.509789259 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-structures.lsp0000644000175000017500000000023614772071557016734 0ustar00cammcamm;;; Tests of structures (load "structure-00.lsp") (load "structures-01.lsp") (load "structures-02.lsp") (load "structures-03.lsp") (load "structures-04.lsp")gcl-2.7.1/ansi-tests/PaxHeaders/ftruncate.lsp0000644000000000000000000000013214542551762016164 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.509789259 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ftruncate.lsp0000644000175000017500000000733214542551762015567 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:36:35 2003 ;;;; Contains: Tests of FTRUNCATE (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "ftruncate-aux.lsp") ;;; Error tests (deftest ftruncate.error.1 (signals-error (ftruncate) program-error) t) (deftest ftruncate.error.2 (signals-error (ftruncate 1.0 1 nil) program-error) t) ;;; Non-error tests (deftest ftruncate.1 (ftruncate.1-fn) nil) (deftest ftruncate.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ftruncate x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ftruncate.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (ftruncate (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ftruncate.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce i 'long-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ftruncate.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ftruncate x)) unless (and (eql q (coerce (1- i) 'long-float)) (eql r rrad)) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl-2.7.1/ansi-tests/PaxHeaders/ccase.lsp0000644000000000000000000000013014542551762015245 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.509789259 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ccase.lsp0000644000175000017500000000733614542551762014656 0ustar00cammcamm;-*- 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 (signals-type-error x 1 (ccase x)) t) (deftest ccase.3 (signals-type-error x 1 (ccase x (a 1) (b 2) (c 3))) t) ;;; It is legal to use T or OTHERWISE as key designators ;;; in CCASE forms. They have no special meaning here. (deftest ccase.4 (signals-type-error x 1 (ccase x (t nil))) t) (deftest ccase.5 (signals-type-error x 1 (ccase x (otherwise nil))) t) (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 (signals-type-error x nil (ccase x (nil 'a))) t) (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 (signals-type-error x t (ccase x (a 10))) t) (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 (signals-type-error x 'otherwise (ccase x ((t) 10))) t) (deftest ccase.16 (signals-type-error x t (ccase x ((otherwise) 10))) t) (deftest ccase.17 (signals-type-error x 'a (ccase x (b 0) (c 1) (otherwise 2))) t) (deftest ccase.19 (signals-type-error x 'a (ccase x (b 0) (c 1) ((t) 2))) t) (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) ;;; No implicit tagbody (deftest ccase.32 (block done (tagbody (let ((x 'a)) (ccase x (a (go 10) 10 (return-from done 'bad)))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest ccase.33 (let ((x :b)) (macrolet ((%m (z) z)) (ccase (expand-in-current-env (%m x)) (:a :bad1) (:b :good) (:c :bad2)))) :good) ;;; (deftest ccase.error.1 ;;; (signals-error (ccase) program-error) ;;; t) (deftest ccase.error.1 (signals-error (funcall (macro-function 'ccase)) program-error) t) (deftest ccase.error.2 (signals-error (funcall (macro-function 'ccase) '(ccase t)) program-error) t) (deftest ccase.error.3 (signals-error (funcall (macro-function 'ccase) '(ccase t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/rplacd.lsp0000644000000000000000000000013214542551763015437 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.509789259 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rplacd.lsp0000644000175000017500000000174314542551763015042 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:30:28 2003 ;;;; Contains: Tests of RPLACD (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;; rplacd on a non-cons is a type error (deftest rplacd.error.1 (check-type-error #'(lambda (x) (rplacd x 1)) #'consp) nil) (deftest rplacd.error.2 (signals-error (rplacd) program-error) t) (deftest rplacd.error.3 (signals-error (rplacd (cons 'a 'b)) program-error) t) (deftest rplacd.error.4 (signals-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage) program-error) t) (deftest rplacd.error.6 (signals-error (locally (rplacd 'a 1) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/pathname-name.lsp0000644000000000000000000000013114542551763016704 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.509789259 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname-name.lsp0000644000175000017500000000352014542551763016303 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/mapcan.lsp0000644000000000000000000000013114542551763015430 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.509789259 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/mapcan.lsp0000644000175000017500000000504314542551763015031 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:22:46 2003 ;;;; Contains: Tests of MAPCAN (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (check-type-error #'(lambda (x) (mapcan #'identity x)) #'listp) nil) (deftest mapcan.error.2 (signals-error (mapcan) program-error) t) (deftest mapcan.error.3 (signals-error (mapcan #'append) program-error) t) (deftest mapcan.error.4 (signals-error (locally (mapcan #'identity 1) t) type-error) t) (deftest mapcan.error.5 (signals-error (mapcan #'car '(a b c)) type-error) t) (deftest mapcan.error.6 (signals-error (mapcan #'cons '(a b c)) program-error) t) (deftest mapcan.error.7 (signals-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapcan.error.8 (signals-error (mapcan #'identity (list* (list 1) (list 2) 3)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cosh.lsp0000644000000000000000000000013214542551762015125 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.509789259 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cosh.lsp0000644000175000017500000000371114542551762014525 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 06:54:15 2004 ;;;; Contains: Tests of COSH (in-package :cl-test) (deftest cosh.1 (let ((result (cosh 0))) (or (eqlt result 1) (eqlt result 1.0))) t) (deftest cosh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (equal (multiple-value-list (cosh zero)) (list one)) collect type) nil) (deftest cosh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) for one = (coerce 1 `(complex ,type)) unless (equal (multiple-value-list (cosh zero)) (list one)) collect type) nil) (deftest cosh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (cosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest cosh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (cosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest cosh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (cosh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest cosh.error.1 (signals-error (cosh) program-error) t) (deftest cosh.error.2 (signals-error (cosh 1.0 1.0) program-error) t) (deftest cosh.error.3 (check-type-error #'cosh #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/load-packages.lsp0000644000000000000000000000013214772071554016665 xustar0030 mtime=1743287148.982904859 30 atime=1744294960.509789259 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-packages.lsp0000644000175000017500000000177314772071554016273 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 00:32:56 2002 ;;;; Contains: Loader for files containing package tests (compile-and-load "packages-00.lsp") (load "find-symbol.lsp") (load "find-all-symbols.lsp") (load "find-package.lsp") (load "list-all-packages.lsp") (load "package-name.lsp") (load "package-nicknames.lsp") (load "intern.lsp") (load "export.lsp") (load "rename-package.lsp") (load "shadow.lsp") (load "shadowing-import.lsp") (load "delete-package.lsp") (load "make-package.lsp") (load "with-package-iterator.lsp") (load "unexport.lsp") (load "unintern.lsp") (load "in-package.lsp") (load "unuse-package.lsp") (load "use-package.lsp") (load "defpackage.lsp") (load "do-symbols.lsp") (load "do-external-symbols.lsp") (load "do-all-symbols.lsp") (load "packagep.lsp") (load "package-error.lsp") (load "package-error-package.lsp") (load "keyword.lsp") (load "package-shadowing-symbols.lsp") (load "package-use-list.lsp") (load "package-used-by-list.lsp") (load "import.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/write-line.lsp0000644000000000000000000000013214542551763016251 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.513789276 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/write-line.lsp0000644000175000017500000000747114542551763015660 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/prog.lsp0000644000000000000000000000013114542551763015140 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.513789276 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/prog.lsp0000644000175000017500000000544514542551763014547 0ustar00cammcamm;-*- 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) (deftest prog.11 (let ((x :bad)) (declare (special x)) (let ((x :good)) (prog ((y x)) (declare (special x)) (return y)))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog.12 (macrolet ((%m (z) z)) (prog ((x (expand-in-current-env (%m :good)))) (return x))) :good) (def-macro-test prog.error.1 (prog nil)) ;;; 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) (deftest prog*.11 (let ((x :bad)) (declare (special x)) (let ((x :good)) (prog* ((y x)) (declare (special x)) (return y)))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog*.12 (macrolet ((%m (z) z)) (prog* ((x (expand-in-current-env (%m :good)))) (return x))) :good) (def-macro-test prog*.error.1 (prog* nil)) gcl-2.7.1/ansi-tests/PaxHeaders/cxr.lsp0000644000000000000000000000013214542551762014765 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.513789276 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cxr.lsp0000644000175000017500000002560214542551762014370 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:28:38 2003 ;;;; Contains: Tests of C*R functions (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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 car.1 (car '(a)) a) (deftest car-nil (car nil) nil) (deftest car.error.1 (check-type-error #'car #'listp) nil) (deftest car.error.2 (signals-error (locally (car 'a) t) type-error) t) (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.error.1 (check-type-error #'cdr #'listp) nil) (deftest cdr.error.2 (signals-error (locally (cdr 'a) t) type-error) t) ;;; Error checking of c*r functions (deftest caar.error.1 (signals-error (caar 'a) type-error) t) (deftest caar.error.2 (signals-error (caar '(a)) type-error) t) (deftest cadr.error.1 (signals-error (cadr 'a) type-error) t) (deftest cadr.error.2 (signals-error (cadr '(a . b)) type-error) t) (deftest cdar.error.1 (signals-error (cdar 'a) type-error) t) (deftest cdar.error.2 (signals-error (cdar '(a . b)) type-error) t) (deftest cddr.error.1 (signals-error (cddr 'a) type-error) t) (deftest cddr.error.2 (signals-error (cddr '(a . b)) type-error) t) (deftest caaar.error.1 (signals-error (caaar 'a) type-error) t) (deftest caaar.error.2 (signals-error (caaar '(a)) type-error) t) (deftest caaar.error.3 (signals-error (caaar '((a))) type-error) t) (deftest caadr.error.1 (signals-error (caadr 'a) type-error) t) (deftest caadr.error.2 (signals-error (caadr '(a . b)) type-error) t) (deftest caadr.error.3 (signals-error (caadr '(a . (b))) type-error) t) (deftest cadar.error.1 (signals-error (cadar 'a) type-error) t) (deftest cadar.error.2 (signals-error (cadar '(a . b)) type-error) t) (deftest cadar.error.3 (signals-error (cadar '((a . c) . b)) type-error) t) (deftest caddr.error.1 (signals-error (caddr 'a) type-error) t) (deftest caddr.error.2 (signals-error (caddr '(a . b)) type-error) t) (deftest caddr.error.3 (signals-error (caddr '(a c . b)) type-error) t) (deftest cdaar.error.1 (signals-error (cdaar 'a) type-error) t) (deftest cdaar.error.2 (signals-error (cdaar '(a)) type-error) t) (deftest cdaar.error.3 (signals-error (cdaar '((a . b))) type-error) t) (deftest cdadr.error.1 (signals-error (cdadr 'a) type-error) t) (deftest cdadr.error.2 (signals-error (cdadr '(a . b)) type-error) t) (deftest cdadr.error.3 (signals-error (cdadr '(a b . c)) type-error) t) (deftest cddar.error.1 (signals-error (cddar 'a) type-error) t) (deftest cddar.error.2 (signals-error (cddar '(a . b)) type-error) t) (deftest cddar.error.3 (signals-error (cddar '((a . b) . b)) type-error) t) (deftest cdddr.error.1 (signals-error (cdddr 'a) type-error) t) (deftest cdddr.error.2 (signals-error (cdddr '(a . b)) type-error) t) (deftest cdddr.error.3 (signals-error (cdddr '(a c . b)) type-error) t) ;; (deftest caaaar.error.1 (signals-error (caaaar 'a) type-error) t) (deftest caaaar.error.2 (signals-error (caaaar '(a)) type-error) t) (deftest caaaar.error.3 (signals-error (caaaar '((a))) type-error) t) (deftest caaaar.error.4 (signals-error (caaaar '(((a)))) type-error) t) (deftest caaadr.error.1 (signals-error (caaadr 'a) type-error) t) (deftest caaadr.error.2 (signals-error (caaadr '(a . b)) type-error) t) (deftest caaadr.error.3 (signals-error (caaadr '(a . (b))) type-error) t) (deftest caaadr.error.4 (signals-error (caaadr '(a . ((b)))) type-error) t) (deftest caadar.error.1 (signals-error (caadar 'a) type-error) t) (deftest caadar.error.2 (signals-error (caadar '(a . b)) type-error) t) (deftest caadar.error.3 (signals-error (caadar '((a . c) . b)) type-error) t) (deftest caadar.error.4 (signals-error (caadar '((a . (c)) . b)) type-error) t) (deftest caaddr.error.1 (signals-error (caaddr 'a) type-error) t) (deftest caaddr.error.2 (signals-error (caaddr '(a . b)) type-error) t) (deftest caaddr.error.3 (signals-error (caaddr '(a c . b)) type-error) t) (deftest caaddr.error.4 (signals-error (caaddr '(a c . (b))) type-error) t) (deftest cadaar.error.1 (signals-error (cadaar 'a) type-error) t) (deftest cadaar.error.2 (signals-error (cadaar '(a)) type-error) t) (deftest cadaar.error.3 (signals-error (cadaar '((a . b))) type-error) t) (deftest cadaar.error.4 (signals-error (cadaar '((a . (b)))) type-error) t) (deftest cadadr.error.1 (signals-error (cadadr 'a) type-error) t) (deftest cadadr.error.2 (signals-error (cadadr '(a . b)) type-error) t) (deftest cadadr.error.3 (signals-error (cadadr '(a b . c)) type-error) t) (deftest cadadr.error.4 (signals-error (cadadr '(a (b . e) . c)) type-error) t) (deftest caddar.error.1 (signals-error (caddar 'a) type-error) t) (deftest caddar.error.2 (signals-error (caddar '(a . b)) type-error) t) (deftest caddar.error.3 (signals-error (caddar '((a . b) . b)) type-error) t) (deftest caddar.error.4 (signals-error (caddar '((a b . c) . b)) type-error) t) (deftest cadddr.error.1 (signals-error (cadddr 'a) type-error) t) (deftest cadddr.error.2 (signals-error (cadddr '(a . b)) type-error) t) (deftest cadddr.error.3 (signals-error (cadddr '(a c . b)) type-error) t) (deftest cadddr.error.4 (signals-error (cadddr '(a c e . b)) type-error) t) (deftest cdaaar.error.1 (signals-error (cdaaar 'a) type-error) t) (deftest cdaaar.error.2 (signals-error (cdaaar '(a)) type-error) t) (deftest cdaaar.error.3 (signals-error (cdaaar '((a))) type-error) t) (deftest cdaaar.error.4 (signals-error (cdaaar '(((a . b)))) type-error) t) (deftest cdaadr.error.1 (signals-error (cdaadr 'a) type-error) t) (deftest cdaadr.error.2 (signals-error (cdaadr '(a . b)) type-error) t) (deftest cdaadr.error.3 (signals-error (cdaadr '(a . (b))) type-error) t) (deftest cdaadr.error.4 (signals-error (cdaadr '(a . ((b . c)))) type-error) t) (deftest cdadar.error.1 (signals-error (cdadar 'a) type-error) t) (deftest cdadar.error.2 (signals-error (cdadar '(a . b)) type-error) t) (deftest cdadar.error.3 (signals-error (cdadar '((a . c) . b)) type-error) t) (deftest cdadar.error.4 (signals-error (cdadar '((a . (c . d)) . b)) type-error) t) (deftest cdaddr.error.1 (signals-error (cdaddr 'a) type-error) t) (deftest cdaddr.error.2 (signals-error (cdaddr '(a . b)) type-error) t) (deftest cdaddr.error.3 (signals-error (cdaddr '(a c . b)) type-error) t) (deftest cdaddr.error.4 (signals-error (cdaddr '(a c b . d)) type-error) t) (deftest cddaar.error.1 (signals-error (cddaar 'a) type-error) t) (deftest cddaar.error.2 (signals-error (cddaar '(a)) type-error) t) (deftest cddaar.error.3 (signals-error (cddaar '((a . b))) type-error) t) (deftest cddaar.error.4 (signals-error (cddaar '((a . (b)))) type-error) t) (deftest cddadr.error.1 (signals-error (cddadr 'a) type-error) t) (deftest cddadr.error.2 (signals-error (cddadr '(a . b)) type-error) t) (deftest cddadr.error.3 (signals-error (cddadr '(a b . c)) type-error) t) (deftest cddadr.error.4 (signals-error (cddadr '(a (b . e) . c)) type-error) t) (deftest cdddar.error.1 (signals-error (cdddar 'a) type-error) t) (deftest cdddar.error.2 (signals-error (cdddar '(a . b)) type-error) t) (deftest cdddar.error.3 (signals-error (cdddar '((a . b) . b)) type-error) t) (deftest cdddar.error.4 (signals-error (cdddar '((a b . c) . b)) type-error) t) (deftest cddddr.error.1 (signals-error (cddddr 'a) type-error) t) (deftest cddddr.error.2 (signals-error (cddddr '(a . b)) type-error) t) (deftest cddddr.error.3 (signals-error (cddddr '(a c . b)) type-error) t) (deftest cddddr.error.4 (signals-error (cddddr '(a c e . b)) type-error) t) ;;; Need to add 'locally' wrapped forms of these ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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) (equalt 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.7.1/ansi-tests/PaxHeaders/make-concatenated-stream.lsp0000644000000000000000000000013214542551763021026 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.513789276 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-concatenated-stream.lsp0000644000175000017500000002015514542551763020427 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/round-aux.lsp0000644000000000000000000000013214542551763016114 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.513789276 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/round-aux.lsp0000644000175000017500000000547514542551763015525 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 14:21:07 2003 ;;;; Contains: Aux. functions for testing ROUND (in-package :cl-test) (defun round.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (<= (- (/ d 2)) r (/ d 2))) unless (or (not (= (abs r) (/ d 2))) (evenp q)) collect (list n d q r n2))) (defun round.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= (- (/ d 2)) r (/ d 2)) (or (not (= (abs r) (/ d 2))) (evenp q)) (= n n2)) collect (list n d q r n2))) (defun round.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (round n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (<= -1/2 r 1/2) (or (not (= (abs r) 1/2)) (evenp q)) ) collect (list n q r n2))) (defun round.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (round n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (<= -1/2 r 1/2) (or (not (= (abs r) 1/2)) (evenp q)) ) collect (list n q r n2))) (defun round.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= (/ d 2) r (- (/ d 2))) (or (not (= (abs r) (- (/ d 2)))) (evenp q)) (= n n2)) collect (list n q d r n2))) (defun round.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (round n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= (/ d 2) r (- (/ d 2))) (or (not (= (abs r) (- (/ d 2)))) (evenp q)) (= n n2)) collect (list n q d r n2))) gcl-2.7.1/ansi-tests/PaxHeaders/shadow.lsp0000644000000000000000000000013214542551763015457 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.513789276 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/shadow.lsp0000644000175000017500000001701714542551763015063 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:20 1998 ;;;; Contains: Tests of SHADOW (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" :use nil) (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" :use nil) (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" :use nil) (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 :use nil) (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 :use nil) (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 :use nil) (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 :use nil) (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)) ;;; Specialized string tests (deftest shadow.8 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G :use nil) (let* ((name (make-array '(1) :initial-contents "X" :element-type 'base-char)) (s1 (intern name :G))) (shadow name :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)) (deftest shadow.9 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G :use nil) (let* ((name (make-array '(3) :initial-contents "XYZ" :fill-pointer 1 :element-type 'character)) (s1 (intern name :G))) (shadow name :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)) (deftest shadow.10 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G :use nil) (let* ((name (make-array '(1) :initial-contents "X" :adjustable t :element-type 'base-char)) (s1 (intern name :G))) (shadow name :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)) (deftest shadow.error.1 (signals-error (shadow) program-error) t) (deftest shadow.error.2 (signals-error (shadow "X" "CL-USER" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/notevery.lsp0000644000000000000000000000013114542551763016044 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.513789276 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/notevery.lsp0000644000175000017500000001712714542551763015453 0ustar00cammcamm;-*- 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) ;;; Other specialized sequences (deftest notevery.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'zerop v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest notevery.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'zerop v))) '(t t t t t nil nil nil nil nil))) collect i) nil) (deftest notevery.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notevery #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (not (notevery #'alpha-char-p v)) (setf (aref v 2) #\0) (not (notevery #'alpha-char-p v)))) t #\0 nil) ;;; Displaced vectors (deftest notevery.23 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (not (notevery #'evenp v1)) (not (notevery 'evenp v2)))) nil t) (deftest notevery.24 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (notevery 'evenp v1) (not (notevery #'evenp v2)))) collect i) nil) (deftest notevery.25 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (notevery 'evenp v1) (not (notevery #'evenp v2)))) collect i) nil) (deftest notevery.26 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (not (notevery 'alpha-char-p s2)))) (nil nil t t nil nil nil)) (deftest notevery.27 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (not (notevery 'alpha-char-p s2)))) (nil nil t t nil nil nil)) ;;; adjustable vectors (deftest notevery.28 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (not (notevery #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (not (notevery #'plusp v))))) t nil) (deftest notevery.29 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (not (notevery #'plusp v)) (progn (adjust-array v '(11) :initial-element -1) (not (notevery #'plusp v))))) t t) ;;; Float, complex vectors (deftest notevery.30 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) when (notevery #'plusp v) collect (list type v)) nil) (deftest notevery.31 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(6) :element-type type :fill-pointer 5 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) when (notevery #'plusp v) collect (list type v)) nil) (deftest notevery.32 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) when (notevery #'complexp v) collect (list type v)) 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 (check-type-error #'(lambda (x) (notevery x '(a b c))) (typef '(or symbol function))) nil) (deftest notevery.error.4 (check-type-error #'(lambda (x) (notevery #'null x)) #'sequencep) nil) (deftest notevery.error.7 (check-type-error #'(lambda (x) (notevery #'eql () x)) #'sequencep) nil) (deftest notevery.error.8 (signals-error (notevery) program-error) t) (deftest notevery.error.9 (signals-error (notevery #'null) program-error) t) (deftest notevery.error.10 (signals-error (locally (notevery 1 '(a b c)) t) type-error) t) (deftest notevery.error.11 (signals-error (notevery #'cons '(a b c)) program-error) t) (deftest notevery.error.12 (signals-error (notevery #'cons '(a b c) '(1 2 4) '(g h j)) program-error) t) (deftest notevery.error.13 (signals-error (notevery #'car '(a b c)) type-error) t)gcl-2.7.1/ansi-tests/PaxHeaders/parse-integer.lsp0000644000000000000000000000013114542551763016736 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.513789276 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/parse-integer.lsp0000644000175000017500000001664514542551763016351 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 10:24:13 2003 ;;;; Contains: Tests of PARSE-INTEGER (in-package :cl-test) (deftest parse-integer.error.1 (signals-error (parse-integer) program-error) t) (deftest parse-integer.error.2 (signals-error (parse-integer "123" :bogus) program-error) t) (deftest parse-integer.error.3 (signals-error (parse-integer "123" :bogus 'foo) program-error) t) (deftest parse-integer.error.4 (signals-error (parse-integer "") parse-error) t) (deftest parse-integer.error.5 (loop for x across +standard-chars+ unless (or (digit-char-p x) (eval `(signals-error (parse-integer ,(string x)) parse-error))) collect x) nil) (deftest parse-integer.error.5a (signals-error (parse-integer "") parse-error) t) (deftest parse-integer.error.6 (signals-error (parse-integer "1234a") parse-error) t) (deftest parse-integer.error.7 (signals-error (parse-integer "-") parse-error) t) (deftest parse-integer.error.8 (signals-error (parse-integer "+") parse-error) t) (deftest parse-integer.error.9 (signals-error (parse-integer "--10") parse-error) t) (deftest parse-integer.error.10 (signals-error (parse-integer "++10") parse-error) t) (deftest parse-integer.error.11 (signals-error (parse-integer "10.") parse-error) t) (deftest parse-integer.error.12 (signals-error (parse-integer "#O123") parse-error) t) (deftest parse-integer.error.13 (signals-error (parse-integer "#B0100") parse-error) t) (deftest parse-integer.error.14 (signals-error (parse-integer "#X0100") parse-error) t) (deftest parse-integer.error.15 (signals-error (parse-integer "#3R0100") parse-error) t) ;;; (deftest parse-integer.1 (parse-integer "123") 123 3) (deftest parse-integer.2 (parse-integer " 123") 123 4) (deftest parse-integer.3 (parse-integer " 12345678901234567890 ") 12345678901234567890 27) (deftest parse-integer.4 (parse-integer (concatenate 'string (string #\Newline) "17" (string #\Newline))) 17 4) (deftest parse-integer.5 (let ((c (name-char "Tab"))) (if c (parse-integer (concatenate 'string (string c) "6381" (string c))) (values 6381 6))) 6381 6) (deftest parse-integer.6 (let ((c (name-char "Linefeed"))) (if c (parse-integer (concatenate 'string (string c) "-123712" (string c))) (values -123712 9))) -123712 9) (deftest parse-integer.7 (let ((c (name-char "Page"))) (if c (parse-integer (concatenate 'string (string c) "0" (string c))) (values 0 3))) 0 3) (deftest parse-integer.8 (let ((c (name-char "Return"))) (if c (parse-integer (concatenate 'string (string c) "999" (string c))) (values 999 5))) 999 5) (deftest parse-integer.9 (parse-integer "-0") 0 2) (deftest parse-integer.10 (parse-integer "+0") 0 2) (deftest parse-integer.11 (parse-integer "-00") 0 3) (deftest parse-integer.12 (parse-integer "+000") 0 4) (deftest parse-integer.13 (parse-integer "00010") 10 5) (deftest parse-integer.14 (parse-integer "10110" :radix 2) 22 5) (deftest parse-integer.15 (parse-integer "1021" :radix 3) 34 4) (deftest parse-integer.16 (loop for radix from 2 to 36 for c across "123456789abcdefghijklmnopqrstuvwxyz" for s = (concatenate 'string (string c) "0") for vals = (multiple-value-list (parse-integer s :radix radix)) for (val pos) = vals always (and (= (length vals) 2) (= pos 2) (= val (* radix (1- radix))))) t) (deftest parse-integer.17 (parse-integer "10A" :junk-allowed t) 10 2) (deftest parse-integer.18 (parse-integer "10" :junk-allowed t) 10 2) (deftest parse-integer.19 (parse-integer "ABCDE" :junk-allowed t) nil 0) (deftest parse-integer.20 (parse-integer "" :junk-allowed t) nil 0) (deftest parse-integer.21 :notes (:nil-vectors-are-strings) (parse-integer (make-array 0 :element-type nil) :junk-allowed t) nil 0) (deftest parse-integer.22 (parse-integer "a1234b" :start 2 :end 4) 23 4) (deftest parse-integer.23 (parse-integer "a1234b" :start 2 :end 4 :end nil) 23 4) (deftest parse-integer.24 (parse-integer "a1234b" :start 2 :end 4 :start 1) 23 4) (deftest parse-integer.25 (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys nil) 23 4) (deftest parse-integer.26 (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys t :foo nil) 23 4) (deftest parse-integer.27 (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys t :allow-other-keys nil :foo nil) 23 4) (deftest parse-integer.28 (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 :element-type 'base-char))) (values s2 (length s2) (equalpt "123" s2) (multiple-value-list (parse-integer s2)))) "123" 3 t (123 3)) (deftest parse-integer.28a (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'character)) (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 :element-type 'character))) (values s2 (length s2) (equalpt "123" s2) (multiple-value-list (parse-integer s2)))) "123" 3 t (123 3)) (deftest parse-integer.29 (let ((s (make-array 10 :initial-contents "1234567890" :fill-pointer 3 :element-type 'base-char))) (values (length s) (multiple-value-list (parse-integer s)))) 3 (123 3)) (deftest parse-integer.29a (let ((s (make-array 10 :initial-contents "1234567890" :fill-pointer 3 :element-type 'character))) (values (length s) (multiple-value-list (parse-integer s)))) 3 (123 3)) (deftest parse-integer.30 (let ((s (make-array 10 :initial-contents "1234567890" :adjustable t :element-type 'base-char))) (values (length s) (multiple-value-list (parse-integer s)) (progn (adjust-array s 3 :element-type 'base-char) (multiple-value-list (parse-integer s))))) 10 (1234567890 10) (123 3)) (deftest parse-integer.30a (let ((s (make-array 10 :initial-contents "1234567890" :adjustable t :element-type 'character))) (values (length s) (multiple-value-list (parse-integer s)) (progn (adjust-array s 3 :element-type 'character) (multiple-value-list (parse-integer s))))) 10 (1234567890 10) (123 3)) (deftest parse-integer.31 (parse-integer "1234" :start 1) 234 4) (deftest parse-integer.32 (parse-integer "1234" :start 1 :end nil) 234 4) (deftest parse-integer.33 (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 :element-type 'base-char)) (s3 (make-array 2 :displaced-to s2 :displaced-index-offset 1 :element-type 'base-char))) (values s3 (length s3) (equalpt "23" s3) (multiple-value-list (parse-integer s3)))) "23" 2 t (23 2)) (deftest parse-integer.34 (parse-integer "1234" :end 3) 123 3) (deftest parse-integer.35 (parse-integer "1234" :end 3 :end 1) 123 3) (deftest parse-integer.36 (parse-integer "1234" :end nil :end 3) 1234 4) ;;; Order of evaluation tests (deftest parse-integer.order.1 (let ((i 0) a b c d e) (values (multiple-value-list (parse-integer (progn (setf a (incf i)) "10001") :radix (progn (setf b (incf i)) 2) :start (progn (setf c (incf i)) 0) :end (progn (setf d (incf i)) 5) :junk-allowed (progn (setf e (incf i)) nil))) i a b c d e)) (17 5) 5 1 2 3 4 5) gcl-2.7.1/ansi-tests/PaxHeaders/macrolet.lsp0000644000000000000000000000013214542551763016000 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.513789276 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/macrolet.lsp0000644000175000017500000002262714542551763015407 0ustar00cammcamm;-*- 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 = `(ignore-errors (macrolet ((,s () ''a)) (,s))) unless (eq (eval form) 'a) collect s) nil) (deftest macrolet.17 (macrolet ((%m (&key (a t)) `(quote ,a))) (%m :a nil)) nil) (deftest macrolet.18 (macrolet ((%m (&key (a t a-p)) `(quote (,a ,(notnot a-p))))) (%m :a nil)) (nil t)) (deftest macrolet.19 (macrolet ((%m (x &optional y) `(quote (,x ,y)))) (values (%m 1) (%m 2 3))) (1 nil) (2 3)) (deftest macrolet.20 (macrolet ((%m (x &optional (y 'a)) `(quote (,x ,y)))) (values (%m 1) (%m 2 3))) (1 a) (2 3)) ;;; Note -- the supplied-p parameter in a macrolet &optional ;;; is required to be T (not just true) if the parameter is present. ;;; See section 3.4.4.1.2 (deftest macrolet.21 (macrolet ((%m (x &optional (y 'a y-p)) `(quote (,x ,y ,y-p)))) (values (%m 1) (%m 2 3))) (1 a nil) (2 3 t)) (deftest macrolet.22 (macrolet ((%m (x &optional ((y z) '(2 3))) `(quote (,x ,y ,z)))) (values (%m a) (%m a (b c)))) (a 2 3) (a b c)) (deftest macrolet.22a (macrolet ((%m (x &optional ((y z) '(2 3) y-z-p)) `(quote (,x ,y ,z ,y-z-p)))) (values (%m a) (%m a (b c)))) (a 2 3 nil) (a b c t)) (deftest macrolet.23 (macrolet ((%m (&rest y) `(quote ,y))) (%m 1 2 3)) (1 2 3)) ;;; According to 3.4.4.1.2, the entity following &rest is ;;; 'a destructuring pattern that matches the rest of the list.' (deftest macrolet.24 (macrolet ((%m (&rest (x y z)) `(quote (,x ,y ,z)))) (%m 1 2 3)) (1 2 3)) (deftest macrolet.25 (macrolet ((%m (&body (x y z)) `(quote (,x ,y ,z)))) (%m 1 2 3)) (1 2 3)) ;;; More key parameters (deftest macrolet.26 (macrolet ((%m (&key ((:a b))) `(quote ,b))) (values (%m) (%m :a x))) nil x) (deftest macrolet.27 (macrolet ((%m (&key ((:a (b c)))) `(quote (,c ,b)))) (%m :a (1 2))) (2 1)) (deftest macrolet.28 (macrolet ((%m (&key ((:a (b c)) '(3 4))) `(quote (,c ,b)))) (values (%m :a (1 2)) (%m :a (1 2) :a (10 11)) (%m))) (2 1) (2 1) (4 3)) (deftest macrolet.29 (macrolet ((%m (&key a (b a)) `(quote (,a ,b)))) (values (%m) (%m :a 1) (%m :b 2) (%m :a 3 :b 4) (%m :b 5 :a 6) (%m :a 7 :a 8) (%m :a 9 :b nil) (%m :a 10 :b nil :b 11))) (nil nil) (1 1) (nil 2) (3 4) (6 5) (7 7) (9 nil) (10 nil)) (deftest macrolet.30 (macrolet ((%m ((&key a) &key (b a)) `(quote (,a ,b)))) (values (%m ()) (%m (:a 1)) (%m () :b 2) (%m (:a 3) :b 4) (%m (:a 7 :a 8)) (%m (:a 9) :b nil) (%m (:a 10) :b nil :b 11))) (nil nil) (1 1) (nil 2) (3 4) (7 7) (9 nil) (10 nil)) (deftest macrolet.31 (macrolet ((%m (&key ((:a (b c)) '(3 4) a-p)) `(quote (,(notnot a-p) ,c ,b)))) (values (%m :a (1 2)) (%m :a (1 2) :a (10 11)) (%m))) (t 2 1) (t 2 1) (nil 4 3)) ;;; Allow-other-keys tests (deftest macrolet.32 (macrolet ((%m (&key a b c) `(quote (,a ,b ,c)))) (values (%m :allow-other-keys nil) (%m :a 1 :allow-other-keys nil) (%m :allow-other-keys t) (%m :allow-other-keys t :allow-other-keys nil :foo t) (%m :allow-other-keys t :c 1 :b 2 :a 3) (%m :allow-other-keys nil :c 1 :b 2 :a 3))) (nil nil nil) (1 nil nil) (nil nil nil) (nil nil nil) (3 2 1) (3 2 1)) (deftest macrolet.33 (macrolet ((%m (&key allow-other-keys) `(quote ,allow-other-keys))) (values (%m) (%m :allow-other-keys nil) (%m :allow-other-keys t :foo t))) nil nil t) (deftest macrolet.34 (macrolet ((%m (&key &allow-other-keys) :good)) (values (%m) (%m :foo t) (%m :allow-other-keys nil :foo t))) :good :good :good) (deftest macrolet.35 (macrolet ((%m (&key a b &allow-other-keys) `(quote (,a ,b)))) (values (%m :a 1) (%m :foo t :b 2) (%m :allow-other-keys nil :a 1 :foo t :b 2))) (1 nil) (nil 2) (1 2)) ;;; &whole is followed by a destructuring pattern (see 3.4.4.1.2) (deftest macrolet.36 (macrolet ((%m (&whole (m a b) c d) `(quote (,m ,a ,b ,c ,d)))) (%m 1 2)) (%m 1 2 1 2)) ;;; Macro names are shadowed by local functions (deftest macrolet.37 (macrolet ((%f () :bad)) (flet ((%f () :good)) (%f))) :good) ;;; The &environment parameter is bound first (deftest macrolet.38 (macrolet ((foo () 1)) (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env) x)) (%f))) 1) ;;; Test for bug that showed up in sbcl (deftest macrolet.39 (macrolet ((%m (()) :good)) (%m ())) :good) ;;; Test that macrolets accept declarations (deftest macrolet.40 (macrolet ((%x () t)) (declare (optimize))) nil) (deftest macrolet.41 (macrolet ((%x () t)) (declare (optimize)) (declare (notinline identity))) nil) (deftest macrolet.42 (macrolet ((%x () t)) (declare (optimize)) (%x)) t) (deftest macrolet.43 (let ((*x-in-macrolet.43* nil)) (declare (special *x-in-macrolet.43*)) (let ((*f* #'(lambda () *x-in-macrolet.43*))) (declare (special *f*)) (eval `(macrolet ((%m (*x-in-macrolet.43*) (declare (special *f*)) (funcall *f*))) (%m t))))) nil) (deftest macrolet.44 (let ((*x-in-macrolet.44* nil)) (declare (special *x-in-macrolet.44*)) (let ((*f* #'(lambda () *x-in-macrolet.44*))) (declare (special *f*)) (eval `(macrolet ((%m (*x-in-macrolet.44*) (declare (special *f* *x-in-macrolet.44*)) (funcall *f*))) (%m t))))) t) (deftest macrolet.45 (let ((*x-in-macrolet.45* nil)) (declare (special *x-in-macrolet.45*)) (let ((*f* #'(lambda () *x-in-macrolet.45*))) (declare (special *f*)) (eval `(macrolet ((%m ((*x-in-macrolet.45*)) (declare (special *f* *x-in-macrolet.45*)) (funcall *f*))) (%m (t)))))) t) ;;; Macros are expanded in the appropriate environment (deftest macrolet.46 (macrolet ((%m (z) z)) (macrolet () (expand-in-current-env (%m :good)))) :good) ;;; Free declarations in macrolet (deftest macrolet.47 (let ((x :good)) (declare (special x)) (let ((x :bad)) (macrolet () (declare (special x)) x))) :good) (deftest macrolet.48 (let ((x :good)) (let ((y :bad)) (macrolet () (declare (ignore y)) x))) :good) (deftest macrolet.49 (let ((x :good)) (let ((y :bad)) (macrolet () (declare (ignorable y)) x))) :good) ;;; TODO: more special declarations for other macrolet arguments gcl-2.7.1/ansi-tests/PaxHeaders/finish-output.lsp0000644000000000000000000000013214542551762017007 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.513789276 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/finish-output.lsp0000644000175000017500000000226414542551762016411 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/string-comparisons.lsp0000644000000000000000000000013214542551763020033 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.513789276 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-comparisons.lsp0000644000175000017500000006477714542551763017456 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:32:41 2002 ;;;; Contains: Tests of string comparison functions (in-package :cl-test) (compile-and-load "string-aux.lsp") (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)) ;;; Keyword argument processing (deftest string-comparison.allow-other-keys.1 (loop for fn in '(string= string<= string>= string/= string< string> string-equal string-not-greaterp string-not-lessp string-not-equal string-lessp string-greaterp) for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) for result = (funcall fn "a" "b" :allow-other-keys t :foo nil) unless (eql result expected) collect (list fn expected result)) nil) (deftest string-comparison.allow-other-keys.2 (loop for fn in '(string= string<= string>= string/= string< string> string-equal string-not-greaterp string-not-lessp string-not-equal string-lessp string-greaterp) for expected in '(nil nil 0 0 nil 0 nil nil 0 0 nil 0) for result = (funcall fn "c" "b" :allow-other-keys t :allow-other-keys nil :foo 1) unless (eql result expected) collect (list fn expected result)) nil) (deftest string-comparison.allow-other-keys.3 (loop for fn in '(string= string<= string>= string/= string< string> string-equal string-not-greaterp string-not-lessp string-not-equal string-lessp string-greaterp) for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) for result = (funcall fn "a" "b" :allow-other-keys nil) unless (eql result expected) collect (list fn expected result)) nil) ;;; 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))) ;;; Tests on nil arrays (deftest string=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (notnot (string= s1 s1)) (notnot (string= s1 (make-array '(0) :element-type nil))) (notnot (string= s1 (make-array '(0) :element-type 'base-char))) (notnot (string= s1 "")) (notnot (string= "" s1)) (string= s1 "a") (string= "a" s1))) t t t t t nil nil) (deftest string/=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string/= s1 s1) (string/= s1 (make-array '(0) :element-type nil)) (string/= s1 (make-array '(0) :element-type 'base-char)) (string/= s1 "") (string/= "" s1) (string/= s1 "a") (string/= "a" s1))) nil nil nil nil nil 0 0) (deftest string<.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string< s1 s1) (string< s1 (make-array '(0) :element-type nil)) (string< s1 (make-array '(0) :element-type 'base-char)) (string< s1 "") (string< "" s1) (string< s1 "a") (string< "a" s1))) nil nil nil nil nil 0 nil) (deftest string<=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string<= s1 s1) (string<= s1 (make-array '(0) :element-type nil)) (string<= s1 (make-array '(0) :element-type 'base-char)) (string<= s1 "") (string<= "" s1) (string<= s1 "a") (string<= "a" s1))) 0 0 0 0 0 0 nil) (deftest string>.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string> s1 s1) (string> s1 (make-array '(0) :element-type nil)) (string> s1 (make-array '(0) :element-type 'base-char)) (string> s1 "") (string> "" s1) (string> s1 "a") (string> "a" s1))) nil nil nil nil nil nil 0) (deftest string>=.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string>= s1 s1) (string>= s1 (make-array '(0) :element-type nil)) (string>= s1 (make-array '(0) :element-type 'base-char)) (string>= s1 "") (string>= "" s1) (string>= s1 "a") (string>= "a" s1))) 0 0 0 0 0 nil 0) (deftest string-equal.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (notnot (string-equal s1 s1)) (notnot (string-equal s1 (make-array '(0) :element-type nil))) (notnot (string-equal s1 (make-array '(0) :element-type 'base-char))) (notnot (string-equal s1 "")) (notnot (string-equal "" s1)) (string-equal s1 "a") (string-equal "a" s1))) t t t t t nil nil) (deftest string-not-equal.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-not-equal s1 s1) (string-not-equal s1 (make-array '(0) :element-type nil)) (string-not-equal s1 (make-array '(0) :element-type 'base-char)) (string-not-equal s1 "") (string-not-equal "" s1) (string-not-equal s1 "a") (string-not-equal "a" s1))) nil nil nil nil nil 0 0) (deftest string-lessp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-lessp s1 s1) (string-lessp s1 (make-array '(0) :element-type nil)) (string-lessp s1 (make-array '(0) :element-type 'base-char)) (string-lessp s1 "") (string-lessp "" s1) (string-lessp s1 "a") (string-lessp "a" s1))) nil nil nil nil nil 0 nil) (deftest string-not-greaterp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-not-greaterp s1 s1) (string-not-greaterp s1 (make-array '(0) :element-type nil)) (string-not-greaterp s1 (make-array '(0) :element-type 'base-char)) (string-not-greaterp s1 "") (string-not-greaterp "" s1) (string-not-greaterp s1 "a") (string-not-greaterp "a" s1))) 0 0 0 0 0 0 nil) (deftest string-greaterp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-greaterp s1 s1) (string-greaterp s1 (make-array '(0) :element-type nil)) (string-greaterp s1 (make-array '(0) :element-type 'base-char)) (string-greaterp s1 "") (string-greaterp "" s1) (string-greaterp s1 "a") (string-greaterp "a" s1))) nil nil nil nil nil nil 0) (deftest string-not-lessp.nil-array.1 :notes (:nil-vectors-are-strings) (let ((s1 (make-array '(0) :element-type nil))) (values (string-not-lessp s1 s1) (string-not-lessp s1 (make-array '(0) :element-type nil)) (string-not-lessp s1 (make-array '(0) :element-type 'base-char)) (string-not-lessp s1 "") (string-not-lessp "" s1) (string-not-lessp s1 "a") (string-not-lessp "a" s1))) 0 0 0 0 0 nil 0) ;;; Error cases (deftest string=.error.1 (signals-error (string=) program-error) t) (deftest string=.error.2 (signals-error (string= "") program-error) t) (deftest string=.error.3 (signals-error (string= "a" "b" nil nil) program-error) t) (deftest string=.error.4 (signals-error (string= "a" "b" :start1) program-error) t) (deftest string=.error.5 (signals-error (string= "a" "b" 1 nil) program-error) t) (deftest string=.error.6 (signals-error (string= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string/=.error.1 (signals-error (string/=) program-error) t) (deftest string/=.error.2 (signals-error (string/= "") program-error) t) (deftest string/=.error.3 (signals-error (string/= "a" "b" nil nil) program-error) t) (deftest string/=.error.4 (signals-error (string/= "a" "b" :start1) program-error) t) (deftest string/=.error.5 (signals-error (string/= "a" "b" 1 nil) program-error) t) (deftest string/=.error.6 (signals-error (string/= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string<.error.1 (signals-error (string<) program-error) t) (deftest string<.error.2 (signals-error (string< "") program-error) t) (deftest string<.error.3 (signals-error (string< "a" "b" nil nil) program-error) t) (deftest string<.error.4 (signals-error (string< "a" "b" :start1) program-error) t) (deftest string<.error.5 (signals-error (string< "a" "b" 1 nil) program-error) t) (deftest string<.error.6 (signals-error (string< "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string<=.error.1 (signals-error (string<=) program-error) t) (deftest string<=.error.2 (signals-error (string<= "") program-error) t) (deftest string<=.error.3 (signals-error (string<= "a" "b" nil nil) program-error) t) (deftest string<=.error.4 (signals-error (string<= "a" "b" :start1) program-error) t) (deftest string<=.error.5 (signals-error (string<= "a" "b" 1 nil) program-error) t) (deftest string<=.error.6 (signals-error (string<= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string>.error.1 (signals-error (string>) program-error) t) (deftest string>.error.2 (signals-error (string> "") program-error) t) (deftest string>.error.3 (signals-error (string> "a" "b" nil nil) program-error) t) (deftest string>.error.4 (signals-error (string> "a" "b" :start1) program-error) t) (deftest string>.error.5 (signals-error (string> "a" "b" 1 nil) program-error) t) (deftest string>.error.6 (signals-error (string> "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string>=.error.1 (signals-error (string>=) program-error) t) (deftest string>=.error.2 (signals-error (string>= "") program-error) t) (deftest string>=.error.3 (signals-error (string>= "a" "b" nil nil) program-error) t) (deftest string>=.error.4 (signals-error (string>= "a" "b" :start1) program-error) t) (deftest string>=.error.5 (signals-error (string>= "a" "b" 1 nil) program-error) t) (deftest string>=.error.6 (signals-error (string>= "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-equal.error.1 (signals-error (string-equal) program-error) t) (deftest string-equal.error.2 (signals-error (string-equal "") program-error) t) (deftest string-equal.error.3 (signals-error (string-equal "a" "b" nil nil) program-error) t) (deftest string-equal.error.4 (signals-error (string-equal "a" "b" :start1) program-error) t) (deftest string-equal.error.5 (signals-error (string-equal "a" "b" 1 nil) program-error) t) (deftest string-equal.error.6 (signals-error (string-equal "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-not-equal.error.1 (signals-error (string-not-equal) program-error) t) (deftest string-not-equal.error.2 (signals-error (string-not-equal "") program-error) t) (deftest string-not-equal.error.3 (signals-error (string-not-equal "a" "b" nil nil) program-error) t) (deftest string-not-equal.error.4 (signals-error (string-not-equal "a" "b" :start1) program-error) t) (deftest string-not-equal.error.5 (signals-error (string-not-equal "a" "b" 1 nil) program-error) t) (deftest string-not-equal.error.6 (signals-error (string-not-equal "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-lessp.error.1 (signals-error (string-lessp) program-error) t) (deftest string-lessp.error.2 (signals-error (string-lessp "") program-error) t) (deftest string-lessp.error.3 (signals-error (string-lessp "a" "b" nil nil) program-error) t) (deftest string-lessp.error.4 (signals-error (string-lessp "a" "b" :start1) program-error) t) (deftest string-lessp.error.5 (signals-error (string-lessp "a" "b" 1 nil) program-error) t) (deftest string-lessp.error.6 (signals-error (string-lessp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-greaterp.error.1 (signals-error (string-greaterp) program-error) t) (deftest string-greaterp.error.2 (signals-error (string-greaterp "") program-error) t) (deftest string-greaterp.error.3 (signals-error (string-greaterp "a" "b" nil nil) program-error) t) (deftest string-greaterp.error.4 (signals-error (string-greaterp "a" "b" :start1) program-error) t) (deftest string-greaterp.error.5 (signals-error (string-greaterp "a" "b" 1 nil) program-error) t) (deftest string-greaterp.error.6 (signals-error (string-greaterp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-not-lessp.error.1 (signals-error (string-not-lessp) program-error) t) (deftest string-not-lessp.error.2 (signals-error (string-not-lessp "") program-error) t) (deftest string-not-lessp.error.3 (signals-error (string-not-lessp "a" "b" nil nil) program-error) t) (deftest string-not-lessp.error.4 (signals-error (string-not-lessp "a" "b" :start1) program-error) t) (deftest string-not-lessp.error.5 (signals-error (string-not-lessp "a" "b" 1 nil) program-error) t) (deftest string-not-lessp.error.6 (signals-error (string-not-lessp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) (deftest string-not-greaterp.error.1 (signals-error (string-not-greaterp) program-error) t) (deftest string-not-greaterp.error.2 (signals-error (string-not-greaterp "") program-error) t) (deftest string-not-greaterp.error.3 (signals-error (string-not-greaterp "a" "b" nil nil) program-error) t) (deftest string-not-greaterp.error.4 (signals-error (string-not-greaterp "a" "b" :start1) program-error) t) (deftest string-not-greaterp.error.5 (signals-error (string-not-greaterp "a" "b" 1 nil) program-error) t) (deftest string-not-greaterp.error.6 (signals-error (string-not-greaterp "a" "b" :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/file-position.lsp0000644000000000000000000000013214542551762016752 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/file-position.lsp0000644000175000017500000001016614542551762016354 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-plus.lsp0000644000000000000000000000013214542551762023023 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.517789293 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-plus.lsp0000644000175000017500000001322414542551762022423 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination + (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.+.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.plus.1 (x) (:method-combination +) (:method + ((x integer)) (car (push 8 *x*))) (:method + ((x rational)) (car (push 4 *x*))) (:method + ((x number)) (car (push 2 *x*))) (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) (deftest defgeneric-method-combination.+.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.plus.2 (x) (:method-combination + :most-specific-first) (:method + ((x integer)) (car (push 8 *x*))) (:method + ((x rational)) (car (push 4 *x*))) (:method + ((x number)) (car (push 2 *x*))) (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) (deftest defgeneric-method-combination.+.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.plus.3 (x) (:method-combination + :most-specific-last) (:method + ((x integer)) (car (push 8 *x*))) (:method + ((x rational)) (car (push 4 *x*))) (:method + ((x number)) (car (push 2 *x*))) (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (8 4 2 1)) (7 (4 2 1)) (3 (2 1)) (1 (1))) (deftest defgeneric-method-combination.+.4 (let ((fn (eval '(defgeneric dg-mc.plus.4 (x) (:method-combination +) (:method + ((x integer)) 1) (:method :around ((x rational)) 'foo) (:method + ((x number)) 1) (:method + ((x symbol)) 2) (:method + ((x t)) 4))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo 5 6 4) (deftest defgeneric-method-combination.+.5 (let ((fn (eval '(defgeneric dg-mc.plus.5 (x) (:method-combination +) (:method + ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method + ((x number)) 2) (:method + ((x symbol)) 4) (:method + ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo 11) (foo 10) 10 12 8) (deftest defgeneric-method-combination.+.6 (let ((fn (eval '(defgeneric dg-mc.plus.6 (x) (:method-combination +) (:method + ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method + ((x number)) 2) (:method + ((x symbol)) 4) (:method + ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar 11)) (foo (bar 10)) (bar 10) 10 12 8) (deftest defgeneric-method-combination.+.7 (let ((fn (eval '(defgeneric dg-mc.plus.7 (x) (:method-combination +) (:method + ((x dgmc-class-04)) 1) (:method + ((x dgmc-class-03)) 2) (:method + ((x dgmc-class-02)) 4) (:method + ((x dgmc-class-01)) 8))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) 8 12 10 15) (deftest defgeneric-method-combination.+.8 (let ((fn (eval '(defgeneric dg-mc.plus.8 (x) (:method-combination +) (:method + ((x (eql 1000))) 1) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method + ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (1)) (deftest defgeneric-method-combination.+.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.+.9 (x) (:method-combination +))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.+.10 (progn (eval '(defgeneric dg-mc.+.10 (x) (:method-combination +) (:method ((x t)) 0))) (handler-case (dg-mc.+.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.+.11 (progn (eval '(defgeneric dg-mc.+.11 (x) (:method-combination +) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.+.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.+.12 (let ((fn (eval '(defgeneric dg-mc.+.12 (x) (:method-combination +) (:method :around ((x t)) 1) (:method + ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/packages-09.lsp0000644000000000000000000000013114542551763016175 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.517789293 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-09.lsp0000644000175000017500000002154514542551763015603 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/TODO0000644000000000000000000000013214542551762014141 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.517789293 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/TODO0000644000175000017500000001042614542551762013542 0ustar00cammcammThings to do to the test suite (not a complete list) 1. subtypep and typep on complex types 2. Refactor random type/element-of-type code. There's too much duplication. 3. More type tests on array types 4. Extend random subtypep tester to array types. (complex types already added, but should extend generator of random real types) 5. Add JA's long form define-method-combination tests (from clisp), or write own (partially done) 6. adjust-array (need to add specialized integer arrays other than bit vectors, and float vectors) 7. Address synonym-stream issues (from Duane Rettig) 8. accuracy tests for numeric functions 9. Test that the streams operators that manipulate files do the right things with *default-pathname-defaults*. 10. Two-arg tests of FILE-POSITION on binary streams. 11. Address issues with broadcast streams (C. Rhodes) -- apparent contradictions in the spec. 17. Tests that have an argument that provides a return value for special conditions (like eof) that happens to be the same as a normal value the functions would return (suggested by CR). 18. Add random tests for COERCE (the result either is either typep of the second arg (except for rational stuff) or a type-error is signalled.) 19. Add two missing tests from CLOS (spotted by Bruno Haible): ;; Shared slot remains shared. ;; CLHS 4.3.6.: "The value of a slot that is specified as shared both in the old ;; class and in the new class is retained." (multiple-value-bind (value condition) (ignore-errors (defclass foo74 () ((size :initarg :size :initform 1 :allocation :class))) (setq i (make-instance 'foo74)) (defclass foo74 () ((size :initarg :size :initform 2 :allocation :class) (other))) (slot-value i 'size)) (list value (type-of condition))) Expected: (1 NULL) Got: (2 NULL) (progn (defclass foo92b (foo92a) ((s :initarg :s))) (defclass foo92a () ()) (let ((x (make-instance 'foo92b :s 5)) (update-counter 0)) (defclass foo92b (foo92a) ((s) (s1) (s2))) ; still subclass of foo92a (slot-value x 's) (defmethod update-instance-for-redefined-class ((object foo92b) added-slots discarded-slots property-list &rest initargs) (incf update-counter)) (make-instances-obsolete 'foo92a) (slot-value x 's) update-counter)) Expected: 1 Got: 0 21. The random tester showed (SETF AREF) wasn't being tested enough. Add tests. 22. Add more symbol printing tests. In particular, there doesn't appear to be a test that (princ :foo) >> :FOO (noticed by PG in ABCL) 23. Modify rt so that when failing tests are reported, they are grouped by :notes and the :notes comment is printed out. This will help explain what the failures mean. 28. Add tests for reading/printing with packages with weird names (lower case letters, digits, etc.) 30. Add more pathname equality tests to equal.lsp 34. (from C Rhodes) Test that CERROR allows additional arguments after a condition designating itself to be used in the continue format control. 36. Add tests for bad default-initargs in object constructors. 37. Add tests that methods on initialize-instance and shared-initialize receive defaulted initargs from compiled make-instance 38, Floating point tests must be expanded. -- Add tests for the floating point inspection functions (decode-float, etc.) -- Add tests of -0.0 vs. 0.0 consistency (a bug here affected abcl) -- transcendantal functions 39. There are various constraints that things defined at the top level become available at compile time. Test these constraints. 40, Check that OPEN, etc. do pathname merging. 41. Add tests for MOD, REM 42. Add randomized tests for BIT-* functions (requested by piso on #lisp) (partially done; tests on simple bit vectors going to a new bit vector have been added; should add in-place versions and operations on non-simple bit-vectors and non-vector arrays) 43. Add tests for structs that defining subtypes using :include doesn't change the parent type(s). (This came up in ABCL.) 44. Add tests for SPECIAL declarations in MACROLET (requested by piso on #lisp) (partially done) 45. Sweep files for missing order-of-execution tests 46. Add tests that class objects are valid class specifiers in method definitions. 47. Test that :import-from in DEFPACKAGE can take a package object. gcl-2.7.1/ansi-tests/PaxHeaders/load-misc.lsp0000644000000000000000000000013214772071553016041 xustar0030 mtime=1743287147.874903809 30 atime=1744294960.517789293 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-misc.lsp0000644000175000017500000000051314772071553015436 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 23 20:14:32 2005 ;;;; Contains: Load misc. tests ;;; Miscellaneous tests, mostly tests that failed in random testing ;;; on various implementations (load "misc.lsp") ;;; Misc. tests dealing with type propagation in CMUCL (load "misc-cmucl-type-prop.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/format-i.lsp0000644000000000000000000000013214542551762015707 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-i.lsp0000644000175000017500000000330614542551762015307 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 21 07:01:36 2004 ;;;; Contains: Tests for the ~I format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; pprint-indent.9 (def-pprint-test format.i.1 (format nil "~" '(M M)) "M M") ;;; See pprint-indent.10 (def-pprint-test format.i.2 (format nil "~:" '(M M)) "(M M)") ;;; See pprint-indent.11 (def-pprint-test format.i.3 (format nil "~<(~;M~-1:i~:@_M~;)~:>" '(M M)) "(M M)") (def-pprint-test format.i.4 (format nil "~:" '(M M)) "(M M)") (def-pprint-test format.i.5 (format nil "~<(~;M~:I~:@_M~;)~:>" '(M M)) "(M M)") (def-pprint-test format.i.6 (format nil "~<(~;M~v:i~:@_M~;)~:>" '(nil)) "(M M)") (def-pprint-test format.i.7 (format nil "~:" '(M M)) "(M M)") (def-pprint-test format.i.8 (format nil "~" '(M M)) "M M") ;;; See pprint-indent.13 (def-pprint-test format.i.9 (format nil "~" '(M M)) "MMM MMMMM") (def-pprint-test format.i.10 (format nil "~:" '(M M)) "(MMM MMMMM)") (def-pprint-test format.i.11 (format nil "~" '(M M)) "MMM MMMMM") (def-pprint-test format.i.12 (format nil "XXX~" '(M M)) "XXXMMM MMMMM") (def-pprint-test format.i.13 (format nil "XXX~" '(M M)) "XXXMMM MMMMM") (def-pprint-test format.i.14 (format nil "XXX~" '(M M)) "XXXMMM MMMMM") (def-pprint-test format.i.15 (format nil "XXX~" '(nil)) "XXXMMM MMMMM") (def-pprint-test format.i.16 (format nil "XXX~" '(2)) "XXXMMM MMMMM") gcl-2.7.1/ansi-tests/PaxHeaders/float.lsp0000644000000000000000000000013214542551762015276 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/float.lsp0000644000175000017500000000366114542551762014702 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 21:53:51 2003 ;;;; Contains: Tests of FLOAT (in-package :cl-test) (deftest float.error.1 (signals-error (float) program-error) t) (deftest float.error.2 (signals-error (float 0 0.0 nil) program-error) t) ;;; (deftest float.1 (notnot (member (float 0) '(0.0f0 -0.0f0))) t) (deftest float.2 (float 1) 1.0f0) (deftest float.3 (float -1) -1.0f0) (deftest float.4 (loop for i from -1000 to 1000 always (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for tp in '(short-float single-float double-float long-float) for y = (float i x) always (and (= i y) (typep y tp)))) t) (deftest float.5 (loop for x in *reals* always (or (not (floatp x)) (eql (float x) x))) t) (deftest float.6 (loop for x in *reals* unless (handler-case (or (not (typep x 'short-float)) (let ((y (float x 0.0f0))) (and (typep y 'single-float) (= x y)))) (arithmetic-error () t)) collect x) nil) (deftest float.7 (loop for x in *reals* unless (or (not (typep x 'short-float)) (let ((y (float x 0.0d0))) (and (typep y 'double-float) (= x y)))) collect x) nil) (deftest float.8 (loop for x in *reals* unless (or (not (typep x 'short-float)) (let ((y (float x 0.0l0))) (and (typep y 'long-float) (= x y)))) collect x) nil) (deftest float.9 (loop for x in *reals* unless (or (not (typep x 'single-float)) (let ((y (float x 0.0d0))) (and (typep y 'double-float) (= x y)))) collect x) nil) (deftest float.10 (loop for x in *reals* unless (or (not (typep x 'single-float)) (let ((y (float x 0.0l0))) (and (typep y 'long-float) (= x y)))) collect x) nil) (deftest float.11 (loop for x in *reals* unless (or (not (typep x 'double-float)) (let ((y (float x 0.0l0))) (and (typep y 'long-float) (= x y)))) collect x) nil) gcl-2.7.1/ansi-tests/PaxHeaders/flet.lsp0000644000000000000000000000013214542551762015123 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/flet.lsp0000644000175000017500000003240314542551762014523 0ustar00cammcamm;-*- 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 :good))) nil)) (%f) :bad)) :good) ;;; Key arguments are not in the block defined by ;;; the local function declaration (deftest flet.4a (block %f (flet ((%f (&key (x (return-from %f :good))) nil)) (%f) :bad)) :good) (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 (signals-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)) program-error) t) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest flet.13 (signals-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)) program-error) t) ;;; Too few arguments (section 3.5.1.2) (deftest flet.14 (signals-error (flet ((%f (a) a)) (%f)) program-error) t) ;;; Too many arguments (section 3.5.1.3) (deftest flet.15 (signals-error (flet ((%f (a) a)) (%f 1 2)) program-error) t) ;;; Invalid keyword argument (section 3.5.1.5) (deftest flet.16 (signals-error (flet ((%f (&key a) a)) (%f '(foo))) program-error) t) ;;; 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 (1- lambda-parameters-limit) 1024)) (vars (loop repeat n collect (gensym)))) (eval `(eqlt ,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) (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 = `(ignore-errors (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 = `(ignore-errors (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 = `(ignore-errors (flet (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) ;;; Check that FLET does not have a tagbody (deftest flet.52 (block done (tagbody (flet ((%f () (go 10) 10 (return-from done 'bad))) (%f)) 10 (return-from done 'good))) good) ;;; Check that nil keyword arguments do not enable the default values (deftest flet.53 (flet ((%f (&key (a 'wrong)) a)) (%f :a nil)) nil) (deftest flet.54 (flet ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) (nil nil)) (deftest flet.55 (flet ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) nil) (deftest flet.56 (flet ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) (%f :a nil)) (nil nil)) (deftest flet.57 (flet ((%f (&key) 'good)) (%f :allow-other-keys nil)) good) (deftest flet.58 (flet ((%f (&key) 'good)) (%f :allow-other-keys t)) good) (deftest flet.59 (flet ((%f (&key) 'good)) (%f :allow-other-keys t :a 1 :b 2)) good) (deftest flet.60 (flet ((%f (&key &allow-other-keys) 'good)) (%f :a 1 :b 2)) good) ;;; NIL as a disallowed keyword argument (deftest flet.61 (signals-error (flet ((%f (&key) :bad)) (%f nil nil)) program-error) t) ;;; Free declarations do not affect argument forms (deftest flet.62 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f (&optional (y x)) (declare (special x)) y)) (%f)))) :good) (deftest flet.63 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f (&key (y x)) (declare (special x)) y)) (%f)))) :good) (deftest flet.64 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet () (declare (special x))) x)) :good) (deftest flet.65 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f () (declare (special x))))) x)) :good) (deftest flet.66 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f () (declare (special x)))) x))) :good) (deftest flet.67 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f (&aux (y x)) (declare (special x)) y)) (%f)))) :good) (deftest flet.68 (let ((x :bad)) (declare (special x)) (let ((x :good)) (flet ((%f () x)) (declare (special x)) (%f)))) :good) (deftest flet.69 (let ((*x* 0)) (declare (special *x*)) (flet ((%f (i) #'(lambda (arg) (declare (ignore arg)) (incf *x* i)))) (values (mapcar (%f 1) '(a b c)) (mapcar (%f 2) '(a b c))))) (1 2 3) (5 7 9)) ;;; Macros are expanded in the appropriate environment (deftest flet.70 (macrolet ((%m (z) z)) (flet () (expand-in-current-env (%m :good)))) :good) (deftest flet.71 (macrolet ((%m (z) z)) (flet ((%f () (expand-in-current-env (%m :good)))) (%f))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/get-universal-time.lsp0000644000000000000000000000013114542551762017711 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/get-universal-time.lsp0000644000175000017500000000275214542551762017316 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 19:25:41 2005 ;;;; Contains: Tests of GET-UNIVERSAL-TIME, GET-DECODED-TIME (in-package :cl-test) ;;; Note -- this ignores the possibilty that the time cannot ;;; be determined. (deftest get-universal-time.1 (notnot-mv (typep (get-universal-time) 'unsigned-byte)) t) (deftest get-universal-time.2 (let* ((time1 (get-universal-time)) (vals (multiple-value-list (get-decoded-time))) (time2 (get-universal-time))) (when (= time1 time2) (let ((vals2 (multiple-value-list (decode-universal-time time1)))) (assert (= (length vals) 9)) (assert (= (length vals2) 9)) (assert (equal (subseq vals 0 7) (subseq vals2 0 7))) (assert (if (elt vals 7) (elt vals2 7) (not (elt vals2 7)))) (assert (= (elt vals 8) (elt vals2 8))))) (values))) (deftest get-universal-time.3 (let* ((first (get-universal-time)) (prev first)) (loop for time = (get-universal-time) do (assert (>= time prev)) do (setf prev time) until (>= time (+ 5 first)))) nil) ;;; Error tests (deftest get-universal-time.error.1 (signals-error (get-universal-time nil) program-error) t) (deftest get-universal-time.error.2 (signals-error (get-universal-time :allow-other-keys t) program-error) t) (deftest get-decoded-time.error.1 (signals-error (get-decoded-time nil) program-error) t) (deftest get-decoded-time.error.2 (signals-error (get-decoded-time :allow-other-keys t) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/elt.lsp0000644000000000000000000000013214542551762014755 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/elt.lsp0000644000175000017500000002374114542551762014362 0ustar00cammcamm;-*- 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 (signals-error (elt nil 0) type-error) t) (deftest elt.1a (signals-error (elt nil -10) type-error) t) (deftest elt.1b (signals-error (locally (elt nil 0) t) type-error) t) (deftest elt.2 (signals-error (elt nil 1000000) type-error) t) (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 (signals-error (elt '(a b c d e) -4) type-error) t) (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 (signals-error (let ((x (list 'a 'b 'c))) (setf (elt x 4) 'd)) type-error) t) (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 (signals-error (let ((x (list 'a 'b 'c))) (elt x 10)) type-error) t) (deftest elt.15 (signals-error (let ((x (list 'a 'b 'c))) (elt x 'a)) type-error) t) (deftest elt.16 (signals-error (let ((x (list 'a 'b 'c))) (elt x 10.0)) type-error) t) (deftest elt.17 (signals-error (let ((x (list 'a 'b 'c))) (elt x -1)) type-error) t) (deftest elt.18 (signals-error (let ((x (list 'a 'b 'c))) (elt x -100000000000000000)) type-error) t) (deftest elt.19 (signals-error (let ((x (list 'a 'b 'c))) (elt x #\w)) type-error) t) (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 (signals-error (elt (make-array '(0)) 0) type-error) t) ;; (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 (signals-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd)) type-error) t) (deftest elt-v.11 (signals-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd)) type-error) t) (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 (signals-error (elt (make-adj-array '(0)) 0) type-error) t) ;;; (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 (signals-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd)) type-error) t) (deftest elt-adj-array.11 (signals-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd)) type-error) t) (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 (signals-error (elt (make-displaced-array '(0) 100) 0) type-error) t) (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 (signals-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :fill-pointer 3))) (elt a 4)) type-error) t) (deftest elt-fill-pointer.4 (signals-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :element-type 'bit :fill-pointer 3))) (elt a 4)) type-error) t) (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 (signals-error (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'character :fill-pointer 3))) (elt a 4)) type-error) t) (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 (signals-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) t) ;;; Specialized strings (deftest elt.special-strings.1 (do-special-strings (s "abcde" nil) (assert (char= (elt s 0) #\a)) (assert (char= (elt s 3) #\d)) (assert (char= (elt s 4) #\e))) nil) ;;; Specialized integer vectors (deftest elt.special-vectors.1 (do-special-integer-vectors (v #(1 1 0 1 0 1) nil) (assert (= (elt v 0) 1)) (assert (= (elt v 1) 1)) (assert (= (elt v 2) 0)) (assert (= (elt v 3) 1)) (assert (= (elt v 4) 0)) (assert (= (elt v 5) 1))) nil) (deftest elt.special-vectors.2 (do-special-integer-vectors (v #(1 2 0 -1 0 3) nil) (assert (= (elt v 0) 1)) (assert (= (elt v 1) 2)) (assert (= (elt v 2) 0)) (assert (= (elt v 3) -1)) (assert (= (elt v 4) 0)) (assert (= (elt v 5) 3))) nil) (deftest elt.special-vectors.3 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for vec = (make-array len :element-type type :initial-contents vals) unless (loop for i below len always (eql (elt vec i) (coerce (1+ i) type))) collect (list type vals vec)) nil) (deftest elt.special-vectors.4 (loop for etype in '(short-float single-float long-float double-float integer rational) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for vec = (make-array len :element-type type :initial-contents vals) unless (loop for i below len always (eql (elt vec i) (elt vals i))) collect (list type vals vec)) nil) ;;; Error tests (deftest elt.error.1 (signals-error (elt) program-error) t) (deftest elt.error.2 (signals-error (elt nil) program-error) t) (deftest elt.error.3 (signals-error (elt nil 0 nil) program-error) t) (deftest elt.error.4 (do-special-integer-vectors (v #(1 1 0 1 0 1) nil) (assert (eql t (eval `(signals-error (elt ,v -1) type-error)))) (assert (eql t (eval `(signals-error (elt ,v 6) type-error))))) nil) (deftest elt.error.5 (do-special-strings (s "ABCDEFGH" nil) (assert (eql t (eval `(signals-error (elt ,s -1) type-error)))) (assert (eql t (eval `(signals-error (elt ,s 8) type-error))))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/dribble.lsp0000644000000000000000000000013214542551762015574 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/dribble.lsp0000644000175000017500000000063114542551762015172 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 15 12:56:29 2005 ;;;; Contains: Tests of DRIBBLE (in-package :cl-test) ;;; Error tests only -- cannot depend on using it in a program ;;; See the CLHS DRIBBLE and issue DRIBBLE-TECHNIQUE for an explanation (deftest dribble.error.1 (signals-error (dribble "dribble.out" nil) program-error) t) ;;; FIXME -- more error tests here gcl-2.7.1/ansi-tests/PaxHeaders/types-and-class.lsp0000644000000000000000000000013114542551763017200 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.517789293 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/types-and-class.lsp0000644000175000017500000001751414542551763016607 0ustar00cammcamm;-*- 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) (compile-and-load "types-aux.lsp") (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) nil) (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) (deftest all-classes-are-type-equivalent-to-their-names.2 (loop for x in *universe* for cl = (class-of x) for name = (class-name cl) when name append (check-equivalence name cl)) 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-standard-classes-are-subtypes-of-standard-object.2 (loop for x in *universe* for class = (class-of x) when (and (typep class 'standard-class) (not (subtypep class 'standard-object))) collect x) 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) (deftest all-structure-classes-are-subtypes-of-structure-object.2 (loop for x in *universe* for cl = (class-of x) when (and (typep cl 'structure-class) (not (subtypep cl 'structure-object))) collect x) 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) ;; 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) ;;; TYPE-ERROR accessors (deftest type-error-datum.1 (let ((c (make-condition 'type-error :datum 'a :expected-type 'integer))) (type-error-datum c)) a) (deftest type-error-expected-type.1 (let ((c (make-condition 'type-error :datum 'a :expected-type 'integer))) (type-error-expected-type c)) integer) ;;; Error checking of type-related functions (deftest type-error-datum.error.1 (signals-error (type-error-datum) program-error) t) (deftest type-error-datum.error.2 (signals-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-datum c nil)) program-error) t) (deftest type-error-expected-type.error.1 (signals-error (type-error-expected-type) program-error) t) (deftest type-error-expected-type.error.2 (signals-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-expected-type c nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/let.lsp0000644000000000000000000000013114542551762014754 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.517789293 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/let.lsp0000644000175000017500000000646614542551762014367 0ustar00cammcamm;-*- 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 100) (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 = `(ignore-errors (let ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) ;;; Check that LET does not have a tagbody (deftest let.16 (block done (tagbody (let () (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Check that free declarations do not apply to the init forms (deftest let.17 (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let ((y x)) (declare (special x)) ;; free declaration y))) :good) (deftest let.17a (funcall (compile nil '(lambda () (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let ((y x)) (declare (special x)) ;; free declaration y)))))) :good) (deftest let.18 (let ((foo 'special)) (declare (special foo)) (let ((foo 'lexical)) (locally (declare (special foo))) foo)) lexical) (deftest let.19 (loop for k in lambda-list-keywords unless (eql (eval `(let ((,k :foo)) ,k)) :foo) collect k) nil) ;;; Macros are expanded in the appropriate environment (deftest let.20 (macrolet ((%m (z) z)) (let () (expand-in-current-env (%m :good)))) :good) (deftest let.21 (macrolet ((%m (z) z)) (let ((x (expand-in-current-env (%m 1)))) (+ x x x))) 3) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-complex.lsp0000644000000000000000000000013114542551763017511 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.517789293 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-complex.lsp0000644000175000017500000001010014542551763017100 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 23 07:12:38 2005 ;;;; Contains: Tests of SUBTYPEP on complex types (in-package :cl-test) (compile-and-load "types-aux.lsp") (deftest subtypep-complex.1 (subtypep* 'complex 'number) t t) (deftest subtypep-complex.2 (subtypep* 'number 'complex) nil t) (defun check-not-complex-type (type) (let ((result1 (multiple-value-list (subtypep* type 'complex))) (result2 (multiple-value-list (subtypep* 'complex type)))) (if (and (equal result1 '(nil t)) (equal result2 '(nil t))) nil (list (list type result1 result2))))) (deftest subtypep-complex.3 (mapcan #'check-not-complex-type '(bit unsigned-byte integer rational ratio real float short-float single-float double-float long-float fixnum bignum)) nil) (deftest subtypep-complex.4 (loop for i from 1 to 100 nconc (check-not-complex-type `(unsigned-byte ,i))) nil) (deftest subtypep-complex.5 (loop for i from 1 to 100 nconc (check-not-complex-type `(signed-byte ,i))) nil) (deftest subtypep-complex.7 (let ((types '(complex (complex) (complex *)))) (loop for tp1 in types nconc (loop for tp2 in types for result = (multiple-value-list (subtypep* tp1 tp2)) unless (equal result '(t t)) collect (list tp1 tp2 result)))) nil) (defun check-complex-upgrading (t1 t2) (let* ((ucpt1 (upgraded-complex-part-type t1)) (ucpt2 (upgraded-complex-part-type t2)) (result (multiple-value-list (subtypep* `(complex ,t1) `(complex ,t2))))) (cond ((or (equal ucpt1 ucpt2) (subtypep t1 t2)) (unless (equal result '(t t)) (list (list :case1 t1 t2 ucpt1 ucpt2 result)))) (t (multiple-value-bind (ucpt-sub1? good1?) (subtypep* ucpt1 ucpt2) (multiple-value-bind (ucpt-sub2? good2?) (subtypep* ucpt2 ucpt1) (cond ;; the second is not a subtype of the first ((and good2? ucpt-sub1? (not ucpt-sub2?)) (assert good1?) (unless (equal result '(nil t)) (list (list :case2 t1 t2 ucpt1 ucpt2 result)))) ;; the first is not a subtype of the second ((and good1? (not ucpt-sub1?) ucpt-sub2?) (assert good2?) (unless (equal result '(nil t)) (list (list :case3 t1 t2 ucpt1 ucpt2 result)))) ;; they are both subtypes of each other, and so represent ;; the same set of objects ((and ucpt-sub1? ucpt-sub2?) (assert good1?) (assert good2?) (unless (equal result '(t t)) (list (list :case4 t1 t2 ucpt1 ucpt2 result))))))))))) (deftest subtypep-complex.8 (let ((types (reverse '(bit fixnum bignum integer unsigned-byte rational ratio short-float single-float double-float long-float float real))) (float-types (remove-duplicates '(short-float single-float double-float long-float) :test #'(lambda (t1 t2) (eql (coerce 0 t1) (coerce 0 t2)))))) (loop for i in '(1 2 3 4 6 8 13 16 17 28 29 31 32 48 64) do (push `(unsigned-byte ,i) types) do (push `(signed-byte ,i) types) do (loop for ftp in float-types do (push `(,ftp ,(coerce 0 ftp) ,(coerce i ftp)) types) do (push `(,ftp (,(coerce (- i) ftp)) ,(coerce i ftp)) types)) do (push `(float ,(coerce 0 'single-float) ,(coerce i 'single-float)) types)) (setq types (reverse types)) (let ((results (mapcan #'(lambda (t1) (mapcan #'(lambda (t2) (check-complex-upgrading t1 t2)) types)) types))) (subseq results 0 (min 100 (length results))))) nil) (deftest subtypep-complex.9 (check-all-not-subtypep '(complex (or (integer 1 2) (integer 5 6))) '(or (complex (integer 1 2)) (complex (integer 5 6)))) nil) (deftest subtypep-complex.10 (check-all-subtypep '(or (complex (integer 1 2)) (complex (integer 5 6))) '(complex (or (integer 1 2) (integer 5 6)))) nil) (deftest subtypep-complex.11 (check-all-not-subtypep '(complex (rational 1 3/2)) '(complex (rational (1) 3/2))) nil) (deftest subtypep-complex.12 (check-all-subtypep '(complex (rational (1) 3/2)) '(complex (rational 1 3/2))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/define-modify-macro.lsp0000644000000000000000000000013214542551762020007 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.521789311 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-modify-macro.lsp0000644000175000017500000000514714542551762017414 0ustar00cammcamm;-*- 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 ;;; (signals-error (define-modify-macro) program-error) ;;; t) ;;; ;;; (deftest define-modify-macro.error.2 ;;; (signals-error (define-modify-macro dfm-error-1) program-error) ;;; t) ;;; ;;; (deftest define-modify-macro.error.3 ;;; (signals-error (define-modify-macro dfm-error-2 ()) program-error) ;;; t) ;;; ;;; (deftest define-modify-macro.error.4 ;;; (signals-error (define-modify-macro dfm-error-2 () nil "Documentation" ;;; "extra illegal argument") ;;; program-error) ;;; t) (def-macro-test define-modify-macro.error.1 (define-modify-macro nonexistent-modify-macro () foo)) ;;; Documentation tests (deftest define-modify-macro.documentation.1 (let ((sym (gensym))) (eval `(define-modify-macro ,sym (&optional (delta 1)) +)) (values (documentation sym 'function) (documentation (macro-function sym) 'function) (documentation (macro-function sym) t))) nil nil nil) (deftest define-modify-macro.documentation.2 (let ((sym (gensym)) (doc "DMM-DOC")) (eval `(define-modify-macro ,sym (&optional (delta 1)) + ,doc)) (values (equalt doc (or (documentation sym 'function) doc)) (equalt doc (or (documentation (macro-function sym) 'function) doc)) (equalt doc (or (documentation (macro-function sym) t) doc)))) t t t) gcl-2.7.1/ansi-tests/PaxHeaders/write-string.lsp0000644000000000000000000000013214542551763016630 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.521789311 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/write-string.lsp0000644000175000017500000000666414542551763016242 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/copy-list.lsp0000644000000000000000000000013214542551762016114 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.521789311 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/copy-list.lsp0000644000175000017500000000147114542551762015515 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:55:19 2003 ;;;; Contains: Tests of COPY-LIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test copy-list.fold.1 (copy-list '(a b c d))) (def-fold-test copy-list.fold.2 (copy-list '(a . b))) ;;; Error tests (deftest copy-list.error.1 (signals-error (copy-list) program-error) t) (deftest copy-list.error.2 (signals-error (copy-list nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/handler-bind.lsp0000644000000000000000000000013114542551762016517 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.521789311 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/handler-bind.lsp0000644000175000017500000000613614542551762016124 0ustar00cammcamm;-*- 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 ((nil #'(lambda (c) (declare (ignore c)) (throw 'done 'bad))) (error #'(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.7.1/ansi-tests/PaxHeaders/member-if-not.lsp0000644000000000000000000000013114542551763016632 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.521789311 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/member-if-not.lsp0000644000175000017500000000656214542551763016242 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:39:29 1998 ;;;; Contains: Tests of MEMBER-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 tests (deftest member-if-not.error.1 (check-type-error #'(lambda (x) (member-if-not #'identity x)) #'listp) nil) (deftest member-if-not.error.2 (signals-error (member-if-not) program-error) t) (deftest member-if-not.error.3 (signals-error (member-if-not #'null) program-error) t) (deftest member-if-not.error.4 (signals-error (member-if-not #'null '(a b c) :bad t) program-error) t) (deftest member-if-not.error.5 (signals-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil) program-error) t) (deftest member-if-not.error.6 (signals-error (member-if-not #'null '(a b c) :key) program-error) t) (deftest member-if-not.error.7 (signals-error (member-if-not #'null '(a b c) 1 2) program-error) t) (deftest member-if-not.error.8 (signals-error (locally (member-if-not #'identity 'a) t) type-error) t) (deftest member-if-not.error.9 (signals-error (member-if-not #'cons '(a b c)) program-error) t) (deftest member-if-not.error.10 (signals-error (member-if-not #'identity '(a b c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/lognot.lsp0000644000000000000000000000013214542551763015474 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.521789311 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/lognot.lsp0000644000175000017500000000153614542551763015077 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:16:20 2003 ;;;; Contains: Tests of LOGNOT (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest lognot.error.1 (check-type-error #'lognot #'integerp) nil) (deftest lognot.error.2 (signals-error (lognot) program-error) t) (deftest lognot.error.3 (signals-error (lognot 0 0) program-error) t) ;;; Non-error tests (deftest lognot.1 (lognot 0) -1) (deftest lognot.2 (lognot -1) 0) (deftest lognot.3 (lognot 123) -124) (deftest lognot.4 (loop for x = (random-from-interval (ash 1 (random 200))) for z = (lognot x) repeat 1000 unless (and (if (>= x 0) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (not (logbitp i x)) (logbitp i z) (not (logbitp i z))))) collect (list x z)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/adjoin.lsp0000644000000000000000000000013214542551762015435 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.521789311 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/adjoin.lsp0000644000175000017500000001264214542551762015040 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:33:20 1998 ;;;; Contains: Tests of ADJOIN (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Ordering in comparison function (deftest adjoin.19 (adjoin 10 '(1 2 3) :test #'<) (10 1 2 3)) (deftest adjoin.20 (adjoin 10 '(1 2 3) :test #'>) (1 2 3)) (deftest adjoin.21 (adjoin 10 '(1 2 3) :test-not #'>) (10 1 2 3)) (deftest adjoin.22 (adjoin 10 '(1 2 3) :test-not #'<) (1 2 3)) ;;; Test that :key satisfies the description in 17.2.1 ;;; This contradicts other parts of the spec, particularly ;;; PUSHNEW, so the test is commented out. ;;; (deftest adjoin.23 ;;; (adjoin 1 '(1 2 3) :key '1+) ;;; (1 1 2 3)) (deftest adjoin.24 (macrolet ((%m (z) z)) (values (adjoin (expand-in-current-env (%m 'a)) '(b c)) (adjoin 'a (expand-in-current-env (%m '(b c)))) (adjoin 'a '(b c) (expand-in-current-env (%m :test)) 'eql) (adjoin 'a '(a a) (expand-in-current-env (%m :test-not)) 'eql) (adjoin 'a '(b c) :test (expand-in-current-env (%m 'eql))) (adjoin 'a '(b c) :test (expand-in-current-env (%m #'eql))) (adjoin 1 '(1 2 3) :key (expand-in-current-env (%m 'identity))) )) (a b c) (a b c) (a b c) (a a a) (a b c) (a b c) (1 2 3)) (defharmless adjoin.test-and-test-not.1 (adjoin 'a '(b c) :test #'eql :test-not #'eql)) (defharmless adjoin.test-and-test-not.2 (adjoin 'a '(b c) :test-not #'eql :test #'eql)) (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) (def-fold-test adjoin.fold.1 (adjoin 'x '(a b c nil d))) (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 (signals-error (adjoin) program-error) t) (deftest adjoin.error.2 (signals-error (adjoin 'a) program-error) t) (deftest adjoin.error.3 (signals-error (adjoin 'a '(b c) :bad t) program-error) t) (deftest adjoin.error.4 (signals-error (adjoin 'a '(b c) :allow-other-keys nil :bad t) program-error) t) (deftest adjoin.error.5 (signals-error (adjoin 'a '(b c) 1 2) program-error) t) (deftest adjoin.error.6 (signals-error (adjoin 'a '(b c) :test) program-error) t) (deftest adjoin.error.7 (signals-error (adjoin 'a '(b c) :test #'identity) program-error) t) (deftest adjoin.error.8 (signals-error (adjoin 'a '(b c) :test-not #'identity) program-error) t) (deftest adjoin.error.9 (signals-error (adjoin 'a '(b c) :key #'cons) program-error) t) (deftest adjoin.error.10 (signals-error (adjoin 'a (list* 'b 'c 'd)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/logorc1.lsp0000644000000000000000000000013214542551763015540 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.521789311 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logorc1.lsp0000644000175000017500000000333114542551763015136 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:23:43 2003 ;;;; Contains: Tests of LOGORC1 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logorc1.error.1 (check-type-error #'(lambda (x) (logorc1 x 0)) #'integerp) nil) (deftest logorc1.error.2 (check-type-error #'(lambda (x) (logorc1 0 x)) #'integerp) nil) (deftest logorc1.error.3 (signals-error (logorc1) program-error) t) (deftest logorc1.error.4 (signals-error (logorc1 0) program-error) t) (deftest logorc1.error.5 (signals-error (logorc1 1 2 3) program-error) t) ;;; Non-error tests (deftest logorc1.1 (logorc1 0 0) -1) (deftest logorc1.2 (logorc1 0 -1) -1) (deftest logorc1.2a (logorc1 -1 0) 0) (deftest logorc1.3 (logorc1 123 0) -124) (deftest logorc1.4 (loop for x in *integers* always (and (eql -1 (logorc1 0 x)) (eql x (logorc1 -1 x)) (eql -1 (logorc1 x x)) (eql x (logorc1 (lognot x) x)) (eql (lognot x) (logorc1 x (lognot x))))) t) (deftest logorc1.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logorc1 xc x)) collect x) nil) (deftest logorc1.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logorc1 x y) repeat 1000 unless (and (if (or (>= x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (not (logbitp i x)) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logorc1.order.1 (let ((i 0) a b) (values (logorc1 (progn (setf a (incf i)) -3) (progn (setf b (incf i)) 17)) i a b)) 19 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/simple-string-p.lsp0000644000000000000000000000013214542551763017224 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.521789311 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-string-p.lsp0000644000175000017500000000332014542551763016620 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:31:24 2004 ;;;; Contains: Tests of SIMPLE-STRING-P (in-package :cl-test) (deftest simple-string-p.1 (check-type-predicate #'simple-string-p 'simple-string) nil) (deftest simple-string-p.2 (notnot-mv (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-mv (simple-string-p (make-array 4 :element-type 'base-char :initial-contents '(#\a #\a #\a #\b)))) t) (deftest simple-string-p.6 (notnot-mv (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) (deftest simple-string-p.8 :notes (:nil-vectors-are-strings) (notnot-mv (simple-string-p (make-array '(0) :element-type nil))) t) (deftest simple-string-p.9 :notes (:nil-vectors-are-strings) (notnot-mv (simple-string-p (make-array '(37) :element-type nil))) t) (deftest simple-string-p.10 (let ((i 0)) (values (notnot (simple-string-p (progn (incf i) ""))) i)) t 1) ;;; Error tests (deftest simple-string-p.error.1 (signals-error (simple-string-p) program-error) t) (deftest simple-string-p.error.2 (signals-error (simple-string-p "" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/boundp.lsp0000644000000000000000000000013014542551762015456 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.525789329 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/boundp.lsp0000644000175000017500000000223614542551762015061 0ustar00cammcamm;-*- 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 (signals-error (boundp) program-error) t) (deftest boundp.error.2 (signals-error (boundp 'a 'a) program-error) t) (deftest boundp.error.3 (check-type-error #'boundp #'symbolp) nil) (deftest boundp.error.4 (signals-type-error x '(setf car) (boundp x)) t) (deftest boundp.error.5 (signals-type-error x "abc" (boundp x)) t) (deftest boundp.error.6 (signals-type-error x "abc" (locally (boundp x) t)) t) ;;; 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) ;;; See 11.1.2.1.1 (deftest boundp.5 (loop for x in *cl-non-variable-constant-symbols* when (boundp x) collect x) nil) (deftest boundp.6 (macrolet ((%m (z) z)) (boundp (expand-in-current-env (%m '#: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.7.1/ansi-tests/PaxHeaders/rename-file.lsp0000644000000000000000000000013114542551763016355 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.525789329 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rename-file.lsp0000644000175000017500000001516014542551763015757 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/load-files.lsp0000644000000000000000000000013214772071552016207 xustar0030 mtime=1743287146.374902404 30 atime=1744294960.525789329 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-files.lsp0000644000175000017500000000061614772071552015610 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/multiple-value-setq.lsp0000644000000000000000000000013114542551763020110 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.525789329 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/multiple-value-setq.lsp0000644000175000017500000000715714542551763017521 0ustar00cammcamm;-*- 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) (deftest multiple-value-setq.13 (multiple-value-setq nil :good) :good) (deftest multiple-value-setq.14 (multiple-value-setq nil (values)) nil) (deftest multiple-value-setq.15 (multiple-value-setq nil (values 'a 'b)) a) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest multiple-value-setq.16 (macrolet ((%m (z) z)) (let ((x :bad)) (symbol-macrolet ((z (expand-in-current-env (%m x)))) (multiple-value-setq (z) :good)) x)) :good) (deftest multiple-value-setq.17 (macrolet ((%m (z) z)) (let ((x :bad)) (values (multiple-value-setq (x) (expand-in-current-env (%m :good))) x))) :good :good) ;;; Error tests (deftest multiple-value-setq.error.1 (signals-error (funcall (macro-function 'multiple-value-setq)) program-error) t) (deftest multiple-value-setq.error.2 (signals-error (funcall (macro-function 'multiple-value-setq) '(multiple-value-setq nil nil)) program-error) t) (deftest multiple-value-setq.error.3 (signals-error (funcall (macro-function 'multiple-value-setq) '(multiple-value-setq nil nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-24.lsp0000644000000000000000000000013214542551762016333 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.525789329 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-24.lsp0000644000175000017500000001314614542551762015736 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/type-of.lsp0000644000000000000000000000013114542551763015554 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.525789329 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/type-of.lsp0000644000175000017500000000607114542551763015157 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 21:15:05 2003 ;;;; Contains: Tests of TYPE-OF (in-package :cl-test) ;;; It turns out I left out an important test of type-of: ;;; (type-of x) must be a recognizable subtype of every builtin type ;;; of which x is a member. (deftest type-of.1 :notes :type-of/strict-builtins (loop for x in *universe* for tp = (type-of x) for failures = (loop for tp2 in *cl-all-type-symbols* when (and (typep x tp2) (not (subtypep tp tp2))) collect tp2) when failures collect (list x failures)) nil) ;;; Some have objected to that (in type-of.1) interpretation ;;; of req. 1.a in the TYPE-OF page, saying that it need hold ;;; for only *one* builtin type that the object is an element of. ;;; This test tests the relaxed requirement. (deftest type-of.1-relaxed (loop for x in *universe* for builtins = (remove x *cl-all-type-symbols* :test (complement #'typep)) for tp = (type-of x) when (and builtins (not (loop for tp2 in builtins thereis (subtypep tp tp2)))) collect x) nil) ;;; 1. For any object that is an element of some built-in type: ;;; b. the type returned does not involve and, eql, member, not, ;;; or, satisfies, or values. ;;; ;;; Since every object is an element of the built-in type T, this ;;; applies universally. (deftest type-of.2 (loop for x in *universe* for tp = (type-of x) when (and (consp tp) (member (car tp) '(and eql member not or satisfies values function))) collect x) nil) (deftest type-of.3 (loop for x in *universe* unless (typep x (type-of x)) collect x) nil) (deftest type-of.4 (loop for x in *universe* for tp = (type-of x) for class = (class-of x) unless (equal (multiple-value-list (subtypep* tp class)) '(t t)) collect x) nil) (deftest type-of.5 (loop for x in *cl-condition-type-symbols* for cnd = (make-condition x) for tp = (type-of cnd) unless (eq x tp) collect x) nil) (defstruct type-of.example-struct a b c) (deftest type-of.6 (type-of (make-type-of.example-struct)) type-of.example-struct) (defclass type-of.example-class () ()) (deftest type-of.7 (type-of (make-instance 'type-of.example-class)) type-of.example-class) (deftest type-of.8 (let ((class (eval '(defclass type-of.example-class-2 () ((a) (b) (c)))))) (setf (class-name class) nil) (eqt (type-of (make-instance class)) class)) t) (deftest type-of.9 (let ((class (eval '(defclass type-of.example-class-3 () ((a) (b) (c)))))) (setf (find-class 'type-of.example-class-3) nil) (eqt (type-of (make-instance class)) class)) t) (deftest type-of.10 (let* ((class (eval '(defclass type-of.example-class-4 () ((a) (b) (c))))) (obj (make-instance class))) (setf (class-name class) nil) (notnot-mv (typep obj class))) t) (deftest type-of.11 (let* ((c #c(-1 1/2)) (type (type-of c))) (notnot (typep c type))) t) ;;; Error tests (deftest type-of.error.1 (signals-error (type-of) program-error) t) (deftest type-of.error.2 (signals-error (type-of nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/notes.lsp0000644000000000000000000000013214542551763015322 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.525789329 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/notes.lsp0000644000175000017500000000452514542551763014726 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 30 21:43:23 2003 ;;;; Contains: Notes concerning various parts of the ANSI spec. (in-package :cl-test) (defnote :allow-nil-arrays "Allow specialized arrays of type (array nil).") (defnote :allow-nonzero-nil-vectors "Allow specialized vectors of type (vector nil) of nonzero size.") (defnote :nil-vectors-are-strings "Assume that (VECTOR NIL) objects are strings.") (defnote :standardized-package-nicknames "The standardized package nicknames specified in section 11 of ANSI CL are exclusive (disputed).") (defnote :type-of/strict-builtins "Interpret requirement 1.a on the TYPE-OF page to apply to all built-in types that contain the object, not just to some builtin type that contains the object.") (defnote :assume-no-gray-streams "Disable the test if gray streams are present.") (defnote :assume-no-simple-streams "Disable the test if simple streams are present.") (defnote :open-if-exists-new-version-no-error "Assume that OPEN, when called with :if-exists :new-version, does not fail.") #+sbcl (rt::disable-note :open-if-exists-new-version-no-error) (defnote :make-condition-with-compound-name "The spec says MAKE-CONDITION should work on any subtype of CONDITION, but this causes all sorts of problems. They probably meant only non-compound names.") (defnote :ansi-spec-problem "A catch-all for tests that illustrate problems in the ANSI spec.") (defnote :negative-zero-is-similar-to-positive-zero "The definition of similarity implies that -0.0 and 0.0 are similar (for each float type.) If negative zeros are distinct this is probably not good, since it makes (defconstant x 0.0) be nonportable.") (defnote :result-type-element-type-by-subtype "Assume that (for sequence functions MAP, etc.) the element type of a vector result type is defined to be the type X such that result-type is a subtype of (vector X).") (defnote :string-on-character-can-be-constant "string on characters need not be fresh") ;;; Haible disagrees with :result-type-element-type-by-subtype #+clisp (rt::disable-note :result-type-element-type-by-subtype) #+(or openmcl gcl ecl) (rt::disable-note :nil-vectors-are-strings) #+gcl (rt::disable-note :allow-nil-arrays) #+gcl (rt::disable-note :make-condition-with-compound-name) #+gcl (rt::disable-note :string-on-character-can-be-constant) gcl-2.7.1/ansi-tests/PaxHeaders/string-right-trim.lsp0000644000000000000000000000013214542551763017564 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.525789329 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-right-trim.lsp0000644000175000017500000001264314542551763017170 0ustar00cammcamm;-*- 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.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :fill-pointer 7)) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.10b (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :adjustable t :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.20 :notes (:nil-vectors-are-strings) (string-right-trim "abcd" (make-array '(0) :element-type nil)) "") (deftest string-right-trim.21 :notes (:nil-vectors-are-strings) (string-right-trim (make-array '(0) :element-type nil) "abcd") "abcd") (deftest string-right-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'base-char :adjustable t))) (values (string-right-trim "ab" s) s)) "abcae" "abcaeb") (deftest string-right-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'character :adjustable t))) (values (string-right-trim "ab" s) s)) "abcae" "abcaeb") (deftest string-right-trim.24 (let* ((etype 'base-char) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-right-trim "ab" s) s s0)) "bc" "bca" "abcaeb") (deftest string-right-trim.25 (let* ((etype 'character) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-right-trim "ab" s) s s0)) "bc" "bca" "abcaeb") (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) (def-fold-test string-right-trim.fold.1 (string-right-trim " " "abcd ")) ;;; Error cases (deftest string-right-trim.error.1 (signals-error (string-right-trim) program-error) t) (deftest string-right-trim.error.2 (signals-error (string-right-trim "abc") program-error) t) (deftest string-right-trim.error.3 (signals-error (string-right-trim "abc" "abcdddabc" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/file-length.lsp0000644000000000000000000000013214542551762016367 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.525789329 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/file-length.lsp0000644000175000017500000001106014542551762015763 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/fmakunbound.lsp0000644000000000000000000000013214542551762016502 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.525789329 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fmakunbound.lsp0000644000175000017500000000354514542551762016107 0ustar00cammcamm;-*- 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 (equalt (check-values (fmakunbound n)) n) (fboundp n)))) t nil) (deftest fmakunbound.error.1 (check-type-error #'fmakunbound #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) nil) (deftest fmakunbound.error.2 (check-type-error #'fmakunbound (constantly nil) '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) nil) (deftest fmakunbound.error.3 (signals-type-error x '(x) (fmakunbound x)) t) (deftest fmakunbound.error.4 (signals-error (fmakunbound) program-error) t) (deftest fmakunbound.error.5 (signals-error (fmakunbound (gensym) nil) program-error) t) (deftest fmakunbound.error.6 (signals-error (locally (fmakunbound 1) t) type-error) t) (deftest fmakunbound.error.7 (loop for x in *mini-universe* unless (symbolp x) nconc (handler-case (list x (fmakunbound `(setf ,x))) (type-error (c) (assert (not (typep (type-error-datum c) (type-error-expected-type c)))) nil) (error (c) (list (list x c))))) nil)gcl-2.7.1/ansi-tests/PaxHeaders/modules8a.lsp0000644000000000000000000000013114542551763016072 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.525789329 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/modules8a.lsp0000644000175000017500000000006514542551763015472 0ustar00cammcamm(in-package :cl-test) (defun modules8a-fun () :good) gcl-2.7.1/ansi-tests/PaxHeaders/find-if.lsp0000644000000000000000000000013214542551762015505 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.525789329 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find-if.lsp0000644000175000017500000003472514542551762015116 0ustar00cammcamm;-*- 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) (deftest find-if-string.20 (do-special-strings (s "123a456" nil) (assert (eql (find-if #'alpha-char-p s) #\a))) nil) ;;; 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 (check-type-error #'(lambda (x) (find-if #'null x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest find-if.error.4 (signals-error (find-if 'null '(a b c . d)) type-error) t) (deftest find-if.error.5 (signals-error (find-if) program-error) t) (deftest find-if.error.6 (signals-error (find-if #'null) program-error) t) (deftest find-if.error.7 (signals-error (find-if #'null nil :bad t) program-error) t) (deftest find-if.error.8 (signals-error (find-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest find-if.error.9 (signals-error (find-if #'null nil 1 1) program-error) t) (deftest find-if.error.10 (signals-error (find-if #'null nil :key) program-error) t) (deftest find-if.error.11 (signals-error (locally (find-if #'null 'b) t) type-error) t) (deftest find-if.error.12 (signals-error (find-if #'cons '(a b c)) program-error) t) (deftest find-if.error.13 (signals-error (find-if #'car '(a b c)) type-error) t) (deftest find-if.error.14 (signals-error (find-if #'identity '(a b c) :key #'cons) program-error) t) (deftest find-if.error.15 (signals-error (find-if #'identity '(a b c) :key #'car) type-error) t) ;;; 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) (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) (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.7.1/ansi-tests/PaxHeaders/export.lsp0000644000000000000000000000013214542551762015512 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.529789347 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/export.lsp0000644000175000017500000000506714542551762015120 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:45 1998 ;;;; Contains: Tests of EXPORT (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 (progn (set-up-packages) (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 (signals-error (export) program-error) t) (deftest export.error.2 (signals-error (export 'X "CL-TEST" NIL) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/get-setf-expansion.lsp0000644000000000000000000000013114542551762017710 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.529789347 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/get-setf-expansion.lsp0000644000175000017500000000264614542551762017317 0ustar00cammcamm;-*- 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 (signals-error (get-setf-expansion) program-error) t) (deftest get-setf-expansion.error.2 (signals-error (get-setf-expansion 'x nil nil) program-error) t) ;;; FIXME ;;; Tests for proper behavior will go here ;;; There are tests in DEFINE-SETF-EXPANDER too ;;; For a function on which the setf expansion is otherwise ;;; undefined, produce a call to #'(setf ). Note: this ;;; form has to be present, since portable code walkers may ;;; grovel over the setf expansion (sorry, clisp). (deftest get-setf-expansion.1 (let* ((fn (gensym)) (vals (multiple-value-list (get-setf-expansion (list fn))))) (values (length vals) (first vals) (second vals) (length (third vals)) (block done (subst-if nil #'(lambda (term) (when (equal term `(function (setf ,fn))) (return-from done :good))) (fourth vals))) (if (equal (fifth vals) (list fn)) :good (fifth vals)))) 5 nil nil 1 :good :good) (deftest get-setf-expansion.2 (let* ((fn (gensym)) (vals (multiple-value-list (get-setf-expansion (list fn) nil)))) (length vals)) 5) (deftest get-setf-expansion.3 (let* ((var (gensym)) (vals (multiple-value-list (get-setf-expansion var)))) (length vals)) 5) gcl-2.7.1/ansi-tests/PaxHeaders/find.lsp0000644000000000000000000000013214542551762015111 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.529789347 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find.lsp0000644000175000017500000005032514542551762014514 0ustar00cammcamm;-*- 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)) (deftest find-list.29 (find 10 '(1 2 3 8 20 3 1 21 3) :test #'<) 20) (deftest find-list.30 (find 10 '(1 2 3 8 20 3 1 21 3) :test-not #'>=) 20) ;;; 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))) (deftest find-vector.31 (find 10 #(1 2 3 8 20 3 1 21 3) :test #'<) 20) (deftest find-vector.32 (find 10 #(1 2 3 8 20 3 1 21 3) :test-not #'>=) 20) (deftest find-vector.33 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (null (find 0 v))) (assert (= (find 4 v) 4)) (assert (= (find -1 v :test #'<) 1)) (assert (= (find -1 v :test #'< :from-end t) 7))) nil) (deftest find-vector.34 (do-special-integer-vectors (v #(0 0 0 0) nil) (assert (eql (find 0 v) 0)) (assert (eql (find 0 v :start 1) 0)) (assert (eql (find 0 v :from-end t) 0)) (assert (null (find 1 v))) (assert (null (find 'a v))) (assert (null (find 0.0 v))) (assert (null (find #c(1.0 0.0) v))) (assert (null (find -1 v))) (assert (null (find 2 v)))) nil) ;;; 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) (deftest find-bit-vector.31 (find 2 #*00011010010 :test #'<) nil) (deftest find-bit-vector.32 (find 2 #*0010101101 :test-not #'>=) nil) (deftest find-bit-vector.33 (find 0 #*00011010010 :test #'<) 1) (deftest find-bit-vector.34 (find 0 #*0010101101 :test-not #'>=) 1) ;;; 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)) (deftest find-string.26 (find #\k "abcdmnop" :test #'char<) #\m) (deftest find-string.27 (find #\k "abcdmnop" :test-not #'char>=) #\m) (deftest find-string.28 (do-special-strings (s "abcdef" nil) (assert (char= (find #\c s :test #'char<) #\d))) nil) ;;; Test & test not (defharmless find-list.test-and-test-not.1 (find 'b '(a b c) :test #'eql :test-not #'eql)) (defharmless find-list.test-and-test-not.2 (find 'b '(a b c) :test-not #'eql :test #'eql)) (defharmless find-vector.test-and-test-not.1 (find 'b #(a b c) :test #'eql :test-not #'eql)) (defharmless find-vector.test-and-test-not.2 (find 'b #(a b c) :test-not #'eql :test #'eql)) (defharmless find-string.test-and-test-not.1 (find #\b "abc" :test #'eql :test-not #'eql)) (defharmless find-string.test-and-test-not.2 (find #\b "abc" :test-not #'eql :test #'eql)) (defharmless find-bit-string.test-and-test-not.1 (find 0 #*110110 :test #'eql :test-not #'eql)) (defharmless find-bit-string.test-and-test-not.2 (find 0 #*110110 :test-not #'eql :test #'eql)) ;;; 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 (check-type-error #'(lambda (x) (find 'a x)) #'(lambda (x) (typep x 'sequence))) nil) (deftest find.error.4 (signals-error (find 'e '(a b c . d)) type-error) t) (deftest find.error.5 (signals-error (find) program-error) t) (deftest find.error.6 (signals-error (find 'a) program-error) t) (deftest find.error.7 (signals-error (find 'a nil :bad t) program-error) t) (deftest find.error.8 (signals-error (find 'a nil :bad t :allow-other-keys nil) program-error) t) (deftest find.error.9 (signals-error (find 'a nil 1 1) program-error) t) (deftest find.error.10 (signals-error (find 'a nil :key) program-error) t) (deftest find.error.11 (signals-error (locally (find 'a 'b) t) type-error) t) (deftest find.error.12 (signals-error (find 'b '(a b c) :test #'identity) program-error) t) (deftest find.error.13 (signals-error (find 'b '(a b c) :test-not #'identity) program-error) t) (deftest find.error.14 (signals-error (find 'c '(a b c) :key #'cons) program-error) t) (deftest find.error.15 (signals-error (find 'c '(a b c) :key #'car) type-error) t) ;;; 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) (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) (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.7.1/ansi-tests/PaxHeaders/apply.lsp0000644000000000000000000000013214542551762015316 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.529789347 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/apply.lsp0000644000175000017500000000264714542551762014725 0ustar00cammcamm;-*- 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 (signals-error (apply) program-error) t) (deftest apply.error.2 (signals-error (apply #'cons) program-error) t) (deftest apply.error.3 (signals-error (apply #'cons nil) program-error) t) (deftest apply.error.4 (signals-error (apply #'cons (list 1 2 3)) program-error) t) ;;; 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.6 (macrolet ((%m (z) z)) (apply (expand-in-current-env (%m 'cons)) 1 2 nil)) (1 . 2)) (deftest apply.7 (macrolet ((%m (z) z)) (apply #'cons (expand-in-current-env (%m 1)) '(2))) (1 . 2)) (deftest apply.8 (macrolet ((%m (z) z)) (apply #'cons (expand-in-current-env (%m '(1 2))))) (1 . 2)) (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.7.1/ansi-tests/PaxHeaders/load-environment.lsp0000644000000000000000000000013214772071551017450 xustar0030 mtime=1743287145.510901603 30 atime=1744294960.529789347 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-environment.lsp0000644000175000017500000000116414772071551017050 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 19:43:17 2004 ;;;; Contains: Load environment tests (section 25) (load "apropos.lsp") (load "apropos-list.lsp") (load "describe.lsp") (load "disassemble.lsp") (load "environment-functions.lsp") (load "room.lsp") (load "time.lsp") (load "trace.lsp") ;; and untrace (load "user-homedir-pathname.lsp") (load "decode-universal-time.lsp") (load "encode-universal-time.lsp") (load "get-universal-time.lsp") (load "sleep.lsp") (load "get-internal-time.lsp") (load "documentation.lsp") #-lispworks (load "inspect.lsp") (load "dribble.lsp") (load "ed.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/set.lsp0000644000000000000000000000013214542551763014765 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.529789347 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/set.lsp0000644000175000017500000000246614542551763014373 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 21 22:35:48 2003 ;;;; Contains: Tests of SET (in-package :cl-test) (deftest set.1 (let ((*var-used-in-set-tests* 'a) (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values *var-used-in-set-tests* (set var 'b) *var-used-in-set-tests*)) a b b) (deftest set.2 (let ((*var-used-in-set-tests* 'a) (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values (let ((*var-used-in-set-tests* 'c)) (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) *var-used-in-set-tests*)) (b c b) b) (deftest set.error.1 (signals-error (set) program-error) t) (deftest set.error.2 (signals-error (let ((*var-used-in-set-tests* 'a)) (declare (special *var-used-in-set-tests*)) (set '*var-used-in-set-tests*)) program-error) t) (deftest set.error.3 (signals-error (let ((*var-used-in-set-tests* 'a)) (declare (special *var-used-in-set-tests*)) (set '*var-used-in-set-tests* nil nil)) program-error) t) (deftest set.error.4 (signals-error (let ((*var-used-in-set-tests* 'a) (*y* 'b)) (declare (special *var-used-in-set-tests*)) (set '*var-used-in-set-tests* nil '*y* nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/import.lsp0000644000000000000000000000013114542551762015502 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.529789347 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/import.lsp0000644000175000017500000002047414542551762015110 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 19 07:06:48 2004 ;;;; Contains: Tests of IMPORT (in-package :cl-test) (compile-and-load "package-aux.lsp") ;;; Create a package name that does not collide with an existing package ;;; name or nickname (defvar *import-package-test-name* (loop for i from 1 for name = (format nil "ITP-~A" i) unless (find-package name) return name)) (deftest import.1 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym pkg)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.2 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import (list sym) pkg)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.3 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((*package* (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym)) (eqlt (find-symbol (symbol-name sym)) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package *package*) ))) (t) t t nil) (deftest import.4 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (syms '(foo bar baz))) (values (multiple-value-list (import syms pkg)) (loop for sym in syms always (eqlt (find-symbol (symbol-name sym) pkg) sym)) (loop for sym in syms always (eqlt (symbol-package sym) (find-package :cl-test))) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.5 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym (make-symbol (symbol-name :foo)))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) (eqlt (find-symbol (symbol-name sym) pkg) sym) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.6 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym (intern (symbol-name :foo) pkg))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) (eqlt (find-symbol (symbol-name sym) pkg) sym) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.7 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use) (:export #:foo)))) (sym (intern (symbol-name :foo) pkg))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) (eqlt (find-symbol (symbol-name sym) pkg) sym) (length (external-symbols-in-package pkg)) (eqlt (car (external-symbols-in-package pkg)) sym) ))) (t) t t 1 t) (deftest import.8 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym pkg-name)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.9 (let ((pkg-name "Z")) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (multiple-value-list (import sym #\Z)) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.10 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (let ((pname (make-array (length pkg-name) :element-type 'base-char :initial-contents pkg-name))) (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.11 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (let ((pname (make-array (+ 3 (length pkg-name)) :element-type 'base-char :fill-pointer (length pkg-name) :initial-contents (concatenate 'string pkg-name "XYZ")))) (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) (deftest import.12 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo)) (values (let* ((pname0 (make-array (+ 4 (length pkg-name)) :element-type 'base-char :fill-pointer (length pkg-name) :initial-contents (concatenate 'string " " pkg-name "XY"))) (pname (make-array (length pkg-name) :element-type 'base-char :displaced-to pname0 :displaced-index-offset 2))) (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) ))) (t) t t nil) ;;; Error tests (deftest import.error.1 (signals-error (import) program-error) t) (deftest import.error.2 (signals-error (import 'nil (find-package :cl-test) nil) program-error) t) (deftest import.error.3 (signals-error (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo) (name (symbol-name sym))) (intern name pkg) (import sym pkg))) package-error) t) (deftest import.error.4 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo) (name (symbol-name sym)) (isym (intern name pkg)) (outer-restarts (compute-restarts))) (block done (and (handler-bind ((package-error #'(lambda (c) ;; There should be at least one restart ;; associated with this condition that was ;; not a preexisting restart (let ((my-restarts (remove 'abort (set-difference (compute-restarts c) outer-restarts) :key #'restart-name))) (assert my-restarts) ; (unintern isym pkg) ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) (return-from done :good))))) (import sym pkg)) (eqlt (find-symbol name pkg) sym) (eqlt (symbol-package sym) (find-package "CL-TEST")) :good)))) :good) (deftest import.error.5 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) (sym 'foo) (name (symbol-name sym)) (isym (shadow name pkg)) ;; shadow instead of intern (outer-restarts (compute-restarts))) (block done (and (handler-bind ((package-error #'(lambda (c) ;; There should be at least one restart ;; associated with this condition that was ;; not a preexisting restart (let ((my-restarts (remove 'abort (set-difference (compute-restarts c) outer-restarts) :key #'restart-name))) (assert my-restarts) ; (unintern isym pkg) ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) (return-from done :good))))) (import sym pkg)) (eqlt (find-symbol name pkg) sym) (eqlt (symbol-package sym) (find-package "CL-TEST")) :good)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/remove.lsp0000644000000000000000000000013114542551763015466 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.529789347 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remove.lsp0000644000175000017500000006657014542551763015103 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 14 11:46:05 2002 ;;;; Contains: Tests for REMOVE (compile-and-load "remove-aux.lsp") (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 ;;; NOTE: this test was bogus, since we can't sure non-EQness is preserved #| (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 remove-string.4 (do-special-strings (s "abcdbad" nil) (let ((s2 (remove #\b s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdad"))) (let ((s2 (remove #\b s :count 1))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdbad"))) (let ((s2 (remove #\b s :count 1 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "abcdad")))) nil) (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 delete-string.4 (do-special-strings (s "abcdbad" nil) (let ((s2 (delete #\b s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdad")))) nil) (deftest delete-string.5 (do-special-strings (s "abcdbad" nil) (let ((s2 (delete #\b s :count 1))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "acdbad")))) nil) (deftest delete-string.6 (do-special-strings (s "abcdbad" nil) (let ((s2 (delete #\b s :count 1 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "abcdad")))) nil) (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) ;;; test & test-not together is harmless (defharmless remove-list.test-and-test-not.1 (remove 'a '(a b c) :test #'eql :test-not #'eql)) (defharmless remove-list.test-and-test-not.2 (remove 'a '(a b c) :test-not #'eql :test #'eql)) (defharmless remove-vector.test-and-test-not.1 (remove 'a #(a b c) :test #'eql :test-not #'eql)) (defharmless remove-vector.test-and-test-not.2 (remove 'a #(a b c) :test-not #'eql :test #'eql)) (defharmless remove-bit-string.test-and-test-not.1 (remove 0 #*0001100100 :test #'eql :test-not #'eql)) (defharmless remove-bit-string.test-and-test-not.2 (remove 0 #*0001100100 :test-not #'eql :test #'eql)) (defharmless remove-string.test-and-test-not.1 (remove #\0 "0001100100" :test #'eql :test-not #'eql)) (defharmless remove-string.test-and-test-not.2 (remove #\0 "0001100100" :test-not #'eql :test #'eql)) (defharmless delete-list.test-and-test-not.1 (delete 'a (list 'a 'b 'c) :test #'eql :test-not #'eql)) (defharmless delete-list.test-and-test-not.2 (delete 'a (list 'a 'b 'c) :test-not #'eql :test #'eql)) (defharmless delete-vector.test-and-test-not.1 (delete 'a (vector 'a 'b 'c) :test #'eql :test-not #'eql)) (defharmless delete-vector.test-and-test-not.2 (delete 'a (vector 'a 'b 'c) :test-not #'eql :test #'eql)) (defharmless delete-bit-string.test-and-test-not.1 (delete 0 (copy-seq #*0001100100) :test #'eql :test-not #'eql)) (defharmless delete-bit-string.test-and-test-not.2 (delete 0 (copy-seq #*0001100100) :test-not #'eql :test #'eql)) (defharmless delete-string.test-and-test-not.1 (delete #\0 (copy-seq "0001100100") :test #'eql :test-not #'eql)) (defharmless delete-string.test-and-test-not.2 (delete #\0 (copy-seq "0001100100") :test-not #'eql :test #'eql)) ;;; Const fold tests (def-fold-test remove.fold.1 (remove 'c '(a b c d e))) (def-fold-test remove.fold.2 (remove 'c #(a b c d e))) (def-fold-test remove.fold.3 (remove 1 #*0011011001)) (def-fold-test remove.fold.4 (remove #\c "abcde")) (def-fold-test remove-if.fold.1 (remove-if 'null '(a b nil d e))) (def-fold-test remove-if.fold.2 (remove-if #'null #(a b nil d e))) (def-fold-test remove-if.fold.3 (remove-if 'plusp #*0011011001)) (def-fold-test remove-if.fold.4 (remove-if 'digit-char-p "ab0de")) (def-fold-test remove-if-not.fold.1 (remove-if-not #'identity '(a b nil d e))) (def-fold-test remove-if-not.fold.2 (remove-if-not 'identity #(a b nil d e))) (def-fold-test remove-if-not.fold.3 (remove-if-not #'zerop #*0011011001)) (def-fold-test remove-if-not.fold.4 (remove-if-not #'alpha-char-p "ab-de")) ;;; 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 (signals-error (remove) program-error) t) (deftest remove.error.2 (signals-error (remove 'a) program-error) t) (deftest remove.error.3 (signals-error (remove 'a nil :key) program-error) t) (deftest remove.error.4 (signals-error (remove 'a nil 'bad t) program-error) t) (deftest remove.error.4a (signals-error (remove 'a nil nil t) program-error) t) (deftest remove.error.5 (signals-error (remove 'a nil 'bad t :allow-other-keys nil) program-error) t) (deftest remove.error.6 (signals-error (remove 'a nil 1 2) program-error) t) (deftest remove.error.7 (signals-error (remove 'a (list 'a 'b 'c) :test #'identity) program-error) t) (deftest remove.error.8 (signals-error (remove 'a (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest remove.error.9 (signals-error (remove 'a (list 'a 'b 'c) :key #'cons) program-error) t) (deftest remove.error.10 (signals-error (remove 'a (list 'a 'b 'c) :key #'car) type-error) t) (deftest remove.error.11 (check-type-error #'(lambda (x) (remove 'a x)) #'sequencep) nil) ;;; (deftest delete.error.1 (signals-error (delete) program-error) t) (deftest delete.error.2 (signals-error (delete 'a) program-error) t) (deftest delete.error.3 (signals-error (delete 'a nil :key) program-error) t) (deftest delete.error.4 (signals-error (delete 'a nil 'bad t) program-error) t) (deftest delete.error.5 (signals-error (delete 'a nil 'bad t :allow-other-keys nil) program-error) t) (deftest delete.error.6 (signals-error (delete 'a nil 1 2) program-error) t) (deftest delete.error.7 (signals-error (delete 'a (list 'a 'b 'c) :test #'identity) program-error) t) (deftest delete.error.8 (signals-error (delete 'a (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest delete.error.9 (signals-error (delete 'a (list 'a 'b 'c) :key #'cons) program-error) t) (deftest delete.error.10 (signals-error (delete 'a (list 'a 'b 'c) :key #'car) type-error) t) (deftest delete.error.11 (check-type-error #'(lambda (x) (delete 'a x)) #'sequencep) nil) ;;; More specialized string tests (deftest remove-if-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-not-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-not-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")) (assert (string= s "ab1c23def4")))) nil) (deftest remove-if-not-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")) (assert (string= s "ab1c23def4")))) nil) (deftest delete-if-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")))) nil) (deftest delete-if-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")))) nil) (deftest delete-if-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")))) nil) (deftest delete-if-not-string.1 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "1234")))) nil) (deftest delete-if-not-string.2 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s :count 3))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "123def4")))) nil) (deftest delete-if-not-string.3 (do-special-strings (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "ab1c234")))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/make-random-state.lsp0000644000000000000000000000013214542551763017503 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.529789347 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-random-state.lsp0000644000175000017500000000312214542551763017077 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 17:53:30 2003 ;;;; Contains: Tests of MAKE-RANDOM-STATE (in-package :cl-test) ;;; Error tests (deftest make-random-state.error.1 (signals-error (make-random-state nil nil) program-error) t) (deftest make-random-state.error.2 (signals-error (make-random-state t nil) program-error) t) (deftest make-random-state.error.3 (signals-error (make-random-state *random-state* nil) program-error) t) (deftest make-random-state.error.4 (check-type-error #'make-random-state (typef '(or (member nil t) random-state))) nil) ;;; Non-error tests (deftest make-random-state.1 (let ((rs (make-random-state))) (and (not (eq rs *random-state*)) (random-state-p rs) (eqlt (random 1000000) (random 1000000 rs)))) t) (deftest make-random-state.2 (let ((rs (make-random-state *random-state*))) (and (not (eq rs *random-state*)) (random-state-p rs) (eqlt (random 1000000) (random 1000000 rs)))) t) (deftest make-random-state.3 (let ((rs (make-random-state))) (random 10) (let ((rs2 (make-random-state rs))) (and (not (eq rs *random-state*)) (not (eq rs rs2)) (not (eq rs2 *random-state*)) (random-state-p rs) (random-state-p rs2) (eqlt (random 1.0 rs) (random 1.0 rs2))))) t) (deftest make-random-state.4 (let ((rs (make-random-state t)) (rs2 (make-random-state t))) (and (random-state-p rs) (not (eq rs *random-state*)) (random-state-p rs2) (not (eq rs2 *random-state*)) (not (eq rs rs2)) (integerp (random 10 rs)) (floatp (random 1.0 rs2)) t)) t) gcl-2.7.1/ansi-tests/PaxHeaders/restart-case.lsp0000644000000000000000000000013114542551763016566 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.529789347 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/restart-case.lsp0000644000175000017500000001563514542551763016177 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 22 06:58:03 2003 ;;;; Contains: Tests for RESTART-CASE (in-package :cl-test) (deftest restart-case.1 (restart-case (values))) (deftest restart-case.2 (restart-case 1) 1) (deftest restart-case.3 (restart-case (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest restart-case.4 (restart-case (progn (invoke-restart 'foo) 'bad) (foo () 'good)) good) (deftest restart-case.5 (restart-case (progn (invoke-restart 'foo) 'bad) (foo ())) nil) (deftest restart-case.6 (restart-case (progn (invoke-restart 'foo) 'bad) (bar () 'bad2) (foo () 'good) (foo () 'bad3)) good) (deftest restart-case.7 (restart-case (invoke-restart 'foo 'a 'b 'c 'd) (foo (w x y z) (list z y x w))) (d c b a)) (deftest restart-case.8 (restart-case (invoke-restart 'foo :a 1 :b 2) (foo (&key a b c d) (list a b c d))) (1 2 nil nil)) (deftest restart-case.9 (restart-case (invoke-restart 'foo 1 2 3 4) (foo (&rest args) (reverse args))) (4 3 2 1)) (deftest restart-case.10 (restart-case (invoke-restart 'foo 1 2 3) (foo (a b &optional c d) (list a b c d))) (1 2 3 nil)) (deftest restart-case.11 (restart-case (invoke-restart 'foo 1 2) (foo (x y) (declare (type fixnum x y)) (+ x y))) 3) (deftest restart-case.12 (restart-case (restart-case (invoke-restart 'foo 1) (foo (x) (invoke-restart 'foo (1+ x)))) (foo (y) (+ 4 y))) 6) (deftest restart-case.13 (let ((i 10)) (values (restart-case (progn (invoke-restart 'foo) 'bad) (foo () (incf i 100) 'good)) i)) good 110) (deftest restart-case.14 (restart-case (invoke-restart 'foo 1 2) (foo (x y) (declare (type fixnum x)) (declare (type fixnum y)) (+ x y))) 3) (deftest restart-case.15 (restart-case (invoke-restart 'foo 1 2) (foo (x y) (declare (ignore x y)) (declare (type fixnum x)) (declare (type fixnum y)))) nil) (deftest restart-case.16 (restart-case (invoke-restart 'foo) (foo () (values)))) (deftest restart-case.17 (restart-case (invoke-restart 'foo) (foo () (values 'a 'b 'c 'd 'e 'f))) a b c d e f) (deftest restart-case.18 (restart-case (invoke-restart 'foo) (foo () :test (lambda (c) (declare (ignore c)) t) 'good)) good) (deftest restart-case.19 (restart-case (invoke-restart 'foo) (foo () :test (lambda (c) (declare (ignore c)) nil) 'bad) (foo () 'good)) good) (deftest restart-case.20 (with-output-to-string (s) (restart-case (let ((restart (find-restart 'foo)) (*print-escape* nil)) (format s "~A" restart)) (foo () :report "A report"))) "A report") (deftest restart-case.21 (with-output-to-string (s) (flet ((%f (s2) (format s2 "A report"))) (restart-case (let ((restart (find-restart 'foo)) (*print-escape* nil)) (format s "~A" restart)) (foo () :report %f)))) "A report") (deftest restart-case.22 (with-output-to-string (s) (restart-case (let ((restart (find-restart 'foo)) (*print-escape* nil)) (format s "~A" restart)) (foo () :report (lambda (s2) (format s2 "A report"))))) "A report") ;;; Special cases when restart-case associates the restarts with ;;; a condition (deftest restart-case.23 (handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'foo)))) (restart-case (error "Boo!") (foo () 'good))) good) (deftest restart-case.24 (handler-bind ((error #'(lambda (c) (invoke-restart (find-restart 'foo c))))) (restart-case (error "Boo!") (foo () 'good))) good) ;;; Test that the inner restart-case has associated its restart with ;;; the condition to be raised by the error form. (deftest restart-case.25 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (error "Boo!") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.26 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((simple-condition #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (signal "Boo!") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.27 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (cerror "" "") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.28 (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (warn "Boo!") (foo () 'bad)) (foo () 'good)))) good) (deftest restart-case.29 (macrolet ((%m (&rest args) (cons 'error args))) (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (%m "Boo!") (foo () 'bad)) (foo () 'good))))) good) (deftest restart-case.30 (symbol-macrolet ((%s (error "Boo!"))) (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case %s (foo () 'bad)) (foo () 'good))))) good) (deftest restart-case.31 (macrolet ((%m2 (&rest args) (cons 'error args))) (macrolet ((%m (&rest args &environment env) (macroexpand (cons '%m2 args) env))) (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case (%m "Boo!") (foo () 'bad)) (foo () 'good)))))) good) (deftest restart-case.32 (restart-case (invoke-restart-interactively 'foo) (foo () 'good)) good) (deftest restart-case.33 (restart-case (invoke-restart-interactively 'foo) (foo (w x y z) :interactive (lambda () (list 'a 'b 'c 'd)) (list x w z y))) (b a d c)) (deftest restart-case.34 (flet ((%f () (list 'a 'b 'c 'd))) (restart-case (invoke-restart-interactively 'foo) (foo (w x y z) :interactive %f (list x w z y)))) (b a d c)) (deftest restart-case.35 (restart-case (loop for i from 1 to 4 for r in (compute-restarts) collect (restart-name r)) (foo () t) (bar () t) (foo () 'a) (nil () :report (lambda (s) (format s "Anonymous restart")) 10)) (foo bar foo nil)) (deftest restart-case.36 (let ((x :bad)) (declare (special x)) (let ((x :good)) (restart-case (invoke-restart 'foo) (foo (&aux (y x)) (declare (special x)) y)))) :good)gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-07.lsp0000644000000000000000000000013214542551762016334 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.533789364 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-07.lsp0000644000175000017500000001027114542551762015733 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/sbit.lsp0000644000000000000000000000013214542551763015133 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.533789364 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sbit.lsp0000644000175000017500000000340614542551763014534 0ustar00cammcamm;-*- 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 (signals-error (sbit) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/probe-file.lsp0000644000000000000000000000013114542551763016215 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.533789364 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/probe-file.lsp0000644000175000017500000000244514542551763015621 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/bit-and.lsp0000644000000000000000000000013014542551762015505 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.533789364 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-and.lsp0000644000175000017500000001532514542551762015113 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:18:47 2003 ;;;; Contains: Tests of BIT-AND (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-and (expand-in-current-env (%m #*0011)) #*0101)) #*0001) (deftest bit-and.21 (macrolet ((%m (z) z)) (bit-and #*1010 (expand-in-current-env (%m #*1100)))) #*1000) (deftest bit-and.22 (macrolet ((%m (z) z)) (bit-and #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*00100010) (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) (def-fold-test bit-and.fold.1 (bit-and #*01101 #*01011)) ;;; Randomized tests (deftest bit-and.random.1 (bit-random-test-fn #'bit-and #'logand) nil) ;;; Error tests (deftest bit-and.error.1 (signals-error (bit-and) program-error) t) (deftest bit-and.error.2 (signals-error (bit-and #*000) program-error) t) (deftest bit-and.error.3 (signals-error (bit-and #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/reader-aux.lsp0000644000000000000000000000013114542551763016226 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.533789364 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/reader-aux.lsp0000644000175000017500000000300514542551763015623 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 14 07:43:48 2005 ;;;; Contains: Auxiliary functions and macros for reader tests (in-package :cl-test) ;;; Define a test using standard io syntax (defmacro def-syntax-test (name form &body expected-results) `(deftest ,name (with-standard-io-syntax (let ((*package* (find-package :cl-test))) ,form)) ,@expected-results)) ;;; Macros for testing specific features (defmacro def-syntax-vector-test (name form &body expected-elements) `(def-syntax-test ,name (let ((v (read-from-string ,form))) (assert (simple-vector-p v)) v) ,(apply #'vector expected-elements))) (defmacro def-syntax-bit-vector-test (name form &body expected-elements) `(def-syntax-test ,name (let ((v (read-from-string ,form))) (assert (simple-bit-vector-p v)) v) ,(make-array (length expected-elements) :element-type 'bit :initial-contents expected-elements))) (defmacro def-syntax-unintern-test (name string) `(deftest ,name (let ((s (read-from-string ,(concatenate 'string "#:" string)))) (values (symbol-package s) (symbol-name s))) nil ,(string-upcase string))) (defmacro def-syntax-array-test (name form expected-result) `(def-syntax-test ,name (let ((v (read-from-string ,form))) (assert (typep v 'simple-array)) (assert (not (array-has-fill-pointer-p v))) (assert (eql (array-element-type v) (upgraded-array-element-type t))) v) ,(eval expected-result))) gcl-2.7.1/ansi-tests/PaxHeaders/clear-output.lsp0000644000000000000000000000013014542551762016613 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.533789364 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/clear-output.lsp0000644000175000017500000000240114542551762016210 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/print-array.lsp0000644000000000000000000000013114542551763016441 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.533789364 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-array.lsp0000644000175000017500000003663714542551763016057 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Apr 22 22:38:11 2004 ;;;; Contains: Tests of printing of arrays (other than vectors) (compile-and-load "printer-aux.lsp") (in-package :cl-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Zero dimensional arrays (deftest print.array.0.1 (let ((a (make-array nil :initial-element 0))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#0A0") (deftest print.array.0.2 (with-standard-io-syntax (let ((a (make-array nil :initial-element '|A|)) (*package* (find-package "CL-TEST"))) (write-to-string a :readably nil :array t))) "#0AA") (deftest print.array.0.3 (let* ((a (make-array nil :initial-element 0)) (result (write-to-string a :readably nil :array nil))) (values (subseq result 0 2) (subseq result (1- (length result))))) "#<" ">") (deftest print.array.0.4 (let ((a (make-array nil :initial-element 0 :adjustable t))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#0A0") (deftest print.array.0.5 (let* ((a (make-array nil :initial-element 0 :adjustable t)) (b (make-array nil :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#0A0") (deftest print.array.0.6 (let ((a (make-array nil :initial-element 0 :element-type '(integer 0 2)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#0A0") (deftest print.array.0.7 (loop for a = (make-array nil :initial-element (- (random 1000000) 500000)) repeat 30 nconc (randomly-check-readability a :test #'is-similar)) nil) (deftest print.array.0.8 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) nconc (let ((a (make-array nil :initial-element 1 :element-type type))) (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar :can-fail t)))) nil) (deftest print.array.0.9 (loop for a = (make-array nil :initial-element (random 1000000) :adjustable t) repeat 30 nconc (randomly-check-readability a :test #'is-similar)) nil) (deftest print.array.0.10 (loop for a = (make-array nil :initial-element (random 1000000000)) for b = (make-array nil :displaced-to a :displaced-index-offset 0) repeat 30 nconc (randomly-check-readability b :test #'is-similar)) nil) (deftest print.array.0.11 (loop for type in '(short-float single-float double-float long-float float) for zero = (coerce 0 type) for a = (make-array nil :initial-element zero :element-type type) nconc (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.0.12 (loop for type0 in '(short-float single-float double-float long-float float) for type = `(complex ,type0) for zero = (complex (coerce 0.0s0 type0)) for a = (make-array nil :initial-element zero :element-type type) nconc (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.0.13 (let ((result (write-to-string (make-array nil :initial-element 0) :readably nil :array nil))) (values (subseq result 0 2) (subseq result (1- (length result))))) "#<" ">") (deftest print.array.0.14 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) for a = (make-array nil :element-type type :initial-element 1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.0.15 (loop for i from 1 to 64 for type = `(signed-byte ,i) for a = (make-array nil :element-type type :initial-element -1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.0.16 (loop for type in '(short-float single-float double-float long-float) for a = (make-array nil :element-type type :initial-element (coerce 17 type)) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) (deftest print.array.0.17 (loop for type0 in '(short-float single-float double-float long-float float real) for type = `(complex ,type0) for a = (make-array nil :element-type type :initial-element (complex 0 (coerce 3 type0))) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Two-d arrays (deftest print.array.2.1 (let ((a (make-array '(1 1) :initial-contents '((1))))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A((1))") (deftest print.array.2.2 (let ((a (make-array '(2 3) :initial-contents '((1 3 8)(2 6 10))))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A((1 3 8) (2 6 10))") (deftest print.array.2.3 (let ((a (make-array '(0 1)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A()") (deftest print.array.2.4 (let ((a (make-array '(1 0)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A(())") (deftest print.array.2.5 (let ((a (make-array '(0 0)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A()") (deftest print.array.2.6 (let ((a (make-array '(10 0)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A(() () () () () () () () () ())") (deftest print.array.2.7 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(3 3) :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((1 3 8) (2 67 121) (65 432 6))") (deftest print.array.2.8 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(2 3) :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((1 3 8) (2 67 121))") (deftest print.array.2.9 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(2 2) :displaced-to a :displaced-index-offset 4))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((67 121) (65 432))") (deftest print.array.2.10 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) (b (make-array '(2 2) :displaced-to a :displaced-index-offset 4 :adjustable t))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((67 121) (65 432))") (deftest print.array.2.11 (let* ((a (make-array '(3 4) :initial-contents '((7 8 9 10) (65 12 42 -1) (:|W| :|X| :|Y| :|Z| )) :adjustable t))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A((7 8 9 10) (65 12 42 -1) (:W :X :Y :Z))") (deftest print.array.2.12 (let ((desired-result "#2A((0 1 1) (1 1 0))")) (loop for i from 2 to 64 for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) :initial-contents '((0 1 1) (1 1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.13 (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) (loop for i from 1 to 64 for a = (make-array '(2 3) :element-type `(signed-byte ,i) :initial-contents '((0 -1 -1) (-1 -1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.14 (let ((desired-result "#2A((0 1 1) (1 1 0))")) (loop for i from 2 to 64 for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) :adjustable t :initial-contents '((0 1 1) (1 1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.15 (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) (loop for i from 1 to 64 for a = (make-array '(2 3) :element-type `(signed-byte ,i) :adjustable t :initial-contents '((0 -1 -1) (-1 -1 0))) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) unless (string= desired-result result) collect (list i a result))) nil) (deftest print.array.2.16 (let ((desired-result "#2A((1 1) (1 0))")) (loop for i from 2 to 64 for type = `(unsigned-byte ,i) for a = (make-array '(2 3) :element-type type :adjustable t :initial-contents '((0 1 1) (1 1 0))) for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 :element-type type) for result = (with-standard-io-syntax (write-to-string b :readably nil :array t)) unless (string= desired-result result) collect (list i b result))) nil) (deftest print.array.2.17 (let ((desired-result "#2A((1 -1) (-2 0))")) (loop for i from 2 to 64 for type = `(signed-byte ,i) for a = (make-array '(2 3) :element-type type :adjustable t :initial-contents '((0 1 1) (-1 -2 0))) for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 :element-type type) for result = (with-standard-io-syntax (write-to-string b :readably nil :array t)) unless (string= desired-result result) collect (list i b result))) nil) (deftest print.array.2.20 (let* ((a (make-array '(9) :initial-contents '(1 3 8 2 67 121 65 432 6))) (b (make-array '(2 2) :displaced-to a :displaced-index-offset 1))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((3 8) (2 67))") (deftest print.array.2.21 (trim-list (loop for dims = (list (random 4) (random 4)) for a = (make-array dims :initial-element (- (random 1000000) 500000)) repeat 100 nconc (let ((result (randomly-check-readability a :test #'is-similar :can-fail t))) (and result (list (cons dims (first result)))))) 10) nil) (deftest print.array.2.22 (loop for a = (make-array (list (random 4) (random 4)) :initial-element (- (random 1000000) 500000) :adjustable t) repeat 100 nconc (randomly-check-readability a :test #'is-similar :can-fail t)) nil) (deftest print.array.2.23 (loop for d1 = (random 10) for d2 = (random 10) for a = (make-array (list d1 d2) :initial-element (- (random 1000000) 500000)) for d1a = (random (1+ d1)) for d2a = (random (1+ d2)) for offset = (random (1+ (- (* d1 d2) (* d1a d2a)))) for b = (make-array (list d1a d2a) :displaced-to a :displaced-index-offset offset) repeat 100 nconc (randomly-check-readability b :test #'is-similar :can-fail t)) nil) (deftest print.array.2.24 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) nconc (let ((a (make-array '(3 4) :initial-element 1 :element-type type))) (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar :can-fail t)))) nil) (deftest print.array.2.25 (let ((a (make-array '(3 4) :initial-element #\a :element-type 'character))) (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.2.26 (let ((a (make-array '(3 4) :initial-element #\a :element-type 'base-char))) (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar :can-fail t))) nil) (deftest print.array.2.27 (let ((str (write-to-string (make-array '(2 3) :initial-element 0) :readably nil :array nil))) (values (subseq str 0 2) (subseq str (1- (length str))))) "#<" ">") (deftest print.array.2.28 (loop for i from 1 to 64 for type = `(unsigned-byte ,i) for a = (make-array '(4 3) :element-type type :initial-element 1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.2.29 (loop for i from 1 to 64 for type = `(signed-byte ,i) for a = (make-array '(4 8) :element-type type :initial-element -1) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list i result)) nil) (deftest print.array.2.30 (loop for type in '(short-float single-float double-float long-float) for a = (make-array '(5 7) :element-type type :initial-element (coerce 17 type)) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) (deftest print.array.2.31 (loop for type0 in '(short-float single-float double-float long-float float real) for type = `(complex ,type0) for a = (make-array '(13 5) :element-type type :initial-element (complex 0 (coerce 3 type0))) for result = (write-to-string a :readably nil :array nil) unless (and (string= (subseq result 0 2) "#<") (string= (subseq result (1- (length result))) ">")) collect (list type result)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Three D arrays (deftest print.array.3.1 (let* ((a (make-array '(1 2 3) :initial-contents '(((:|A| :|B| :|C|) (:|D| :|E| :|F|))))) (b (make-array '(3 2 1) :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (values (write-to-string a :readably nil :array t) (write-to-string b :readably nil :array t)))) "#3A(((:A :B :C) (:D :E :F)))" "#3A(((:A) (:B)) ((:C) (:D)) ((:E) (:F)))") ;;; Multidimensional arrays (deftest print.array.multi-dim.1 (with-standard-io-syntax (loop for d in (remove array-rank-limit '(4 5 6 7 8 9 10 12 16 20 30 40 100 200 400 600 800 1023) :test #'<=) for dims = (make-list d :initial-element 1) for a = (make-array dims :initial-element 0) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) for expected-result = (concatenate 'string (format nil "#~DA" d) (make-string d :initial-element #\() "0" (make-string d :initial-element #\))) unless (string= result expected-result) collect (list d result expected-result))) nil) (deftest print.array.multi-dim.2 (with-standard-io-syntax (loop for d = (+ 4 (random (min (- array-rank-limit 4) 1000))) for p = (random d) for dims = (let ((list (make-list d :initial-element 1))) (setf (elt list p) 0) list) for a = (make-array dims :initial-element 0) for result = (with-standard-io-syntax (write-to-string a :readably nil :array t)) for expected-result = (concatenate 'string (format nil "#~DA" d) (make-string (1+ p) :initial-element #\() (make-string (1+ p) :initial-element #\))) repeat 50 unless (string= result expected-result) collect (list d result expected-result))) nil) ;;; To add: more tests for high dimensional arrays, including arrays with ;;; element types gcl-2.7.1/ansi-tests/PaxHeaders/load-test-file-2.lsp0000644000000000000000000000013114542551762017140 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.533789364 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/load-test-file-2.lsp0000644000175000017500000000030314542551762016533 0ustar00cammcamm(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.7.1/ansi-tests/PaxHeaders/format-justify.lsp0000644000000000000000000000013214542551762017154 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.533789364 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-justify.lsp0000644000175000017500000001533114542551762016555 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 22 18:09:49 2004 ;;;; Contains: Tests of the ~< ~> directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test format.justify.1 (format nil "~<~>") "") (def-pprint-test format.justify.2 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for s2 = (format nil "~<~A~>" s1) unless (string= s1 s2) collect (list i s1 s2)) nil) (def-pprint-test format.justify.3 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for s2 = (format nil "~<~A~;~A~>" s1 s1) unless (string= s2 (concatenate 'string s1 s1)) collect (list i s1 s2)) nil) (def-pprint-test format.justify.4 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for expected = (concatenate 'string s1 " " s1) for s2 = (format nil "~,,1<~A~;~A~>" s1 s1) unless (string= s2 expected) collect (list i expected s2)) nil) (def-pprint-test format.justify.5 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for expected = (concatenate 'string s1 "," s1) for s2 = (format nil "~,,1,',<~A~;~A~>" s1 s1) unless (string= s2 expected) collect (list i expected s2)) nil) (def-pprint-test format.justify.6 (loop for i from 1 to 20 for s1 = (make-string i :initial-element #\x) for expected = (concatenate 'string s1 " " s1) for s2 = (format nil "~,,2<~A~;~A~>" s1 s1) unless (string= s2 expected) collect (list i expected s2)) nil) (def-pprint-test format.justify.7 (loop for mincol = (random 50) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil "~v<~A~>" mincol s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element #\Space) s1) s1) repeat 100 unless (string= s2 expected) collect (list mincol len s1 s2 expected)) nil) (def-pprint-test format.justify.8 (loop for mincol = (random 50) for minpad = (random 10) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil "~v,,v<~A~>" mincol minpad s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element #\Space) s1) s1) repeat 100 unless (string= s2 expected) collect (list mincol minpad len s1 s2 expected)) nil) (def-pprint-test format.justify.9 (loop for mincol = (random 50) for padchar = (random-from-seq +standard-chars+) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil "~v,,,v<~A~>" mincol padchar s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element padchar) s1) s1) repeat 100 unless (string= s2 expected) collect (list mincol padchar len s1 s2 expected)) nil) (def-pprint-test format.justify.10 (loop for mincol = (random 50) for padchar = (random-from-seq +standard-chars+) for len = (random 50) for s1 = (make-string len :initial-element #\x) for s2 = (format nil (format nil "~~~d,,,'~c<~~A~~>" mincol padchar) s1) for expected = (if (< len mincol) (concatenate 'string (make-string (- mincol len) :initial-element padchar) s1) s1) repeat 500 unless (string= s2 expected) collect (list mincol padchar len s1 s2 expected)) nil) (def-pprint-test format.justify.11 (loop for i = (1+ (random 20)) for colinc = (1+ (random 10)) for s1 = (make-string i :initial-element #\x) for s2 = (format nil "~,v<~A~>" colinc s1) for expected-len = (* colinc (ceiling i colinc)) for expected = (concatenate 'string (make-string (- expected-len i) :initial-element #\Space) s1) repeat 10 unless (string= expected s2) collect (list i colinc expected s2)) nil) (def-pprint-test format.justify.12 (format nil "~") "") (def-pprint-test format.justify.13 (format nil "~") "XXXXXX") (def-pprint-test format.justify.13a (format nil "~<~~>") "XXXXXX") (def-pprint-test format.justify.14 (format nil "~") "XXXXXX") (def-pprint-test format.justify.15 (format nil "~13,,2") "aaa bbb ccc") (def-pprint-test format.justify.16 (format nil "~10@") "abcdef ") (def-pprint-test format.justify.17 (format nil "~10:@") " abcdef ") (def-pprint-test format.justify.18 (format nil "~10:") " abcdef") (def-pprint-test format.justify.19 (format nil "~4@<~>") " ") (def-pprint-test format.justify.20 (format nil "~5:@<~>") " ") (def-pprint-test format.justify.21 (format nil "~6:<~>") " ") (def-pprint-test format.justify.22 (format nil "~v<~A~>" nil "XYZ") "XYZ") (def-pprint-test format.justify.23 (format nil "~,v<~A~;~A~>" nil "ABC" "DEF") "ABCDEF") (def-pprint-test format.justify.24 (format nil "~,,v<~A~;~A~>" nil "ABC" "DEF") "ABCDEF") (def-pprint-test format.justify.25 (format nil "~,,1,v<~A~;~A~>" nil "ABC" "DEF") "ABC DEF") (def-pprint-test format.justify.26 (format nil "~,,1,v<~A~;~A~>" #\, "ABC" "DEF") "ABC,DEF") (def-pprint-test format.justify.27 (format nil "~6") " abc") (def-pprint-test format.justify.28 (format nil "~6@") "abc ") ;;; ~:; tests (def-pprint-test format.justify.29 (format nil "~%X ~,,1<~%X ~:;AAA~;BBB~;CCC~>") " X AAA BBB CCC") (def-pprint-test format.justify.30 (format nil "~%X ~<~%X ~0,3:;AAA~>~<~%X ~0,3:;BBB~>~<~%X ~0,3:;CCC~>") " X X AAA X BBB X CCC") (def-pprint-test format.justify.31 (format nil "~%X ~<~%X ~0,30:;AAA~>~<~%X ~0,30:;BBB~>~<~%X ~0,30:;CCC~>") " X AAABBBCCC") (def-pprint-test format.justify.32 (format nil "~%X ~<~%X ~0,3:;AAA~>,~<~%X ~0,3:;BBB~>,~<~%X ~0,3:;CCC~>") " X X AAA, X BBB, X CCC") ;;; Error cases ;;; See 22.3.5.2 ;;; Interaction with ~W (deftest format.justify.error.w.1 (signals-error-always (format nil "~< ~W ~>" nil) error) t t) (deftest format.justify.error.w.2 (signals-error-always (format nil "~~W" nil) error) t t) (deftest format.justify.error.w.3 (signals-error-always (format nil "~w~" nil) error) t t) ;;; Interaction with ~_ (deftest format.justify.error._.1 (signals-error-always (format nil "~< ~_ ~>") error) t t) (deftest format.justify.error._.2 (signals-error-always (format nil "~~_") error) t t) (deftest format.justify.error._.3 (signals-error-always (format nil "~_~") error) t t) ;;; Interaction with ~I (deftest format.justify.error.i.1 (signals-error-always (format nil "~< ~i ~>") error) t t) (deftest format.justify.error.i.2 (signals-error-always (format nil "~~I") error) t t) (deftest format.justify.error.i.3 (signals-error-always (format nil "~i~") error) t t) gcl-2.7.1/ansi-tests/PaxHeaders/concatenate.lsp0000644000000000000000000000013014542551762016453 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.533789364 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/concatenate.lsp0000644000175000017500000002025314542551762016055 0ustar00cammcamm;-*- 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.18a (concatenate '(vector *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.18b (concatenate '(vector) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.18c (concatenate '(simple-vector *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.18d (concatenate '(simple-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 10) x x) (concatenate '(bit-vector *) x) (not (simple-bit-vector-p (concatenate 'bit-vector x))) )) #*011000 #*001100 #*0110001100 #*01100 nil) (deftest concatenate.30a (let* ((x (make-array '(10) :initial-contents #*0110010111 :fill-pointer 5 :element-type 'bit))) (values (concatenate 'simple-bit-vector x '(0)) (concatenate 'simple-bit-vector '(0) x) (concatenate 'simple-bit-vector x x) (concatenate 'simple-bit-vector x) (not (simple-bit-vector-p (concatenate 'bit-vector x))) )) #*011000 #*001100 #*0110001100 #*01100 nil) (deftest concatenate.31 :notes (:nil-vectors-are-strings) (concatenate 'string "abc" (make-array '(0) :element-type nil) "def") "abcdef") (deftest concatenate.32 :notes (:nil-vectors-are-strings) (concatenate '(array nil (*))) "") (deftest concatenate.33 (do-special-strings (s "abc" nil) (assert (string= (concatenate 'string s s s) "abcabcabc")) (assert (string= (concatenate 'string "xy" s) "xyabc")) (assert (string= (concatenate 'simple-string s "z" s "w" s) "abczabcwabc")) (assert (string= (concatenate 'base-string s "z" s "w" s) "abczabcwabc")) (assert (string= (concatenate 'simple-base-string s "z" s "w" s) "abczabcwabc")) (assert (string= (concatenate '(vector character) s "z" s "w" s) "abczabcwabc"))) nil) (deftest concatenate.34 (concatenate 'simple-string "abc" "def") "abcdef") (deftest concatenate.35 (concatenate '(simple-string) "abc" "def") "abcdef") (deftest concatenate.36 (concatenate '(simple-string *) "abc" "def") "abcdef") (deftest concatenate.37 (concatenate '(simple-string 6) "abc" "def") "abcdef") (deftest concatenate.38 (concatenate '(string) "abc" "def") "abcdef") (deftest concatenate.39 (concatenate '(string *) "abc" "def") "abcdef") (deftest concatenate.40 (concatenate '(string 6) "abc" "def") "abcdef") ;;; Order of evaluation tests (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) ;;; Constant folding tests (def-fold-test concatenate.fold.1 (concatenate 'list '(a b) '(c d))) (def-fold-test concatenate.fold.2 (concatenate 'vector '(a b) '(c d))) (def-fold-test concatenate.fold.3 (concatenate 'bit-vector '(0 0) '(1 0 1))) (def-fold-test concatenate.fold.4 (concatenate 'string "ab" "cd")) (def-fold-test concatenate.fold.5 (concatenate 'list '(a b c d))) (def-fold-test concatenate.fold.6 (concatenate 'vector #(a b c d))) (def-fold-test concatenate.fold.7 (concatenate 'bit-vector #*110101101)) (def-fold-test concatenate.fold.8 (concatenate 'string "abcdef")) ;;; Error tests (deftest concatenate.error.1 (signals-error (concatenate 'sequence '(a b c)) error) t) (deftest concatenate.error.2 (signals-error-always (concatenate 'fixnum '(a b c d e)) error) t t) (deftest concatenate.error.3 (signals-error (concatenate '(vector * 3) '(a b c d e)) type-error) t) (deftest concatenate.error.4 (signals-error (concatenate) program-error) t) (deftest concatenate.error.5 (signals-error (locally (concatenate '(vector * 3) '(a b c d e)) t) type-error) t) (deftest concatenate.error.6 :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector bit) (vector t)))) (if (subtypep type 'vector) (eval `(signals-error-always (concatenate ',type '(0 1 0) '(1 1 0)) error)) (values t t))) t t) gcl-2.7.1/ansi-tests/PaxHeaders/nsublis.lsp0000644000000000000000000000013114542551763015650 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.533789364 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nsublis.lsp0000644000175000017500000001074714542551763015260 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:35:33 2003 ;;;; Contains: Tests of NSUBLIS (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest nsublis.10 (check-nsublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (x y z 20)) (deftest nsublis.11 (check-nsublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (x y z 20)) (defharmless nsublis.test-and-test-not.1 (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'eql :test-not #'eql)) (defharmless nsublis.test-and-test-not.2 (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (nsublis) program-error) t) (deftest nsublis.error.2 (signals-error (nsublis nil) program-error) t) (deftest nsublis.error.3 (signals-error (nsublis nil 'a :test) program-error) t) (deftest nsublis.error.4 (signals-error (nsublis nil 'a :bad-keyword t) program-error) t) (deftest nsublis.error.5 (signals-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity) program-error) t) (deftest nsublis.error.6 (signals-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons) program-error) t) (deftest nsublis.error.7 (signals-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity) program-error) t) (deftest nsublis.error.8 (signals-error (nsublis '((a . 1) . bad) (list 'a 'b 'c 'd)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/append.lsp0000644000000000000000000000013214542551762015440 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.533789364 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/append.lsp0000644000175000017500000000371714542551762015046 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:36:46 2003 ;;;; Contains: Tests of APPEND (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;;; Test suggested by Peter Graves (deftest append.7 (let ((x (list 'a 'b 'c 'd))) (eq (append x nil) x)) nil) ;;; Compiler macro expansion in correct env (deftest append.8 (macrolet ((%m (z) z)) (append (expand-in-current-env (%m '(a b c))))) (a b c)) (deftest append.9 (macrolet ((%m (z) z)) (append (expand-in-current-env (%m (list 1 2 3))) (list 4 5 6))) (1 2 3 4 5 6)) (deftest append.10 (macrolet ((%m (z) z)) (append (list 1 2 3) (expand-in-current-env (%m (list 4 5 6))))) (1 2 3 4 5 6)) ;;; Order of evaluation tests (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) (def-fold-test append.fold.1 (append '(a b c) nil)) (def-fold-test append.fold.2 (append nil '(x) nil)) ;;; Error tests (deftest append.error.1 (signals-error (append '(a . b) '(z)) type-error) t) (deftest append.error.2 (signals-error (append '(x y z) '(a . b) '(z)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/compile.lsp0000644000000000000000000000013014542551762015617 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.533789364 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile.lsp0000644000175000017500000000410514542551762015217 0ustar00cammcamm;-*- 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 (eval '(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) ;;; Error tests (deftest compile.error.1 (signals-error (compile) program-error) t) (deftest compile.error.2 (signals-error (compile nil '(lambda () nil) 'garbage) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/README0000644000000000000000000000013214542551762014331 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.537789381 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/README0000644000175000017500000000276014542551762013734 0ustar00cammcammThis directory contains a partial Common Lisp standards compliance test suite. To run the tests, load doit.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 '). Tests can be invoked from the makefile setting the enviroment variable LISP to the lisp executable to be tested, then invoking make test Run tests with test bodies EVALed. make test-compiled Run tests with test bodies compiled before being EVALed. Please tell me when you find incorrect test cases. Paul Dietz dietz@dls.net -------------------------------- (30 Jun 2003) I've decided to add metainformation to the tests, in the form of : pairs after DEFTEST. Also, I've added a DEFNOTE form to define note objects whose names can be attached to properties of tests, to enable selective disabling of classes of tests. The file doit.lsp disables some contentious tests under certain implementations using the note mechanism. If any implementor wishes that some of these tests be inhibited in their implementation, please contact me and I will add code to do so. -------------------------------- NOTE!!! This test suite is not intended to rank Common Lisp implementations. The tests have not be selected to reflect the importance or relative frequency of different CL features. Implementations may even have extended the CL standard (arguably a good thing) in a way that causes certain tests to fail. gcl-2.7.1/ansi-tests/PaxHeaders/with-hash-table-iterator.lsp0000644000000000000000000000013214542551763021002 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.537789381 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-hash-table-iterator.lsp0000644000175000017500000001005714542551763020403 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 20:08:43 2003 ;;;; Contains: Tests of WITH-HASH-TABLE-ITERATOR (in-package :cl-test) (deftest with-hash-table-iterator.1 (with-hash-table-iterator (x (make-hash-table))) nil) (deftest with-hash-table-iterator.2 (with-hash-table-iterator (x (make-hash-table)) (values))) (deftest with-hash-table-iterator.3 (with-hash-table-iterator (x (make-hash-table)) (values 'a 'b 'c 'd)) a b c d) (deftest with-hash-table-iterator.4 (with-hash-table-iterator (%x (make-hash-table)) (%x)) nil) (deftest with-hash-table-iterator.5 (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) (with-hash-table-iterator (%x table) (multiple-value-bind (success-p key val) (%x) (values (notnot success-p) key val)))) t a b) (deftest with-hash-table-iterator.6 (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) (with-hash-table-iterator (%x table) (length (multiple-value-list (%x))))) 3) (deftest with-hash-table-iterator.7 (let ((keys '("a" "b" "c" "d" "e"))) (loop for test in '(eq eql equal equalp) for test-fn of-type function = (symbol-function test) collect (let ((table (make-hash-table :test test))) (loop for k in keys for i from 0 do (setf (gethash k table) i)) (let ((count 0) (found-keys)) (with-hash-table-iterator (%x table) (block done (loop (multiple-value-bind (success key val) (%x) (unless success (return-from done nil)) (incf count) (push key found-keys) (assert (= val (position key keys :test test-fn)))))) (and (= count (length keys)) (every test-fn (sort (remove-duplicates found-keys :test test) #'string<) keys) t)))))) (t t t t)) (deftest with-hash-table-iterator.8 (with-hash-table-iterator (%x (make-hash-table)) (declare (optimize))) nil) (deftest with-hash-table-iterator.8a (with-hash-table-iterator (%x (make-hash-table)) (declare (optimize)) (declare (optimize))) nil) (deftest with-hash-table-iterator.9 (with-hash-table-iterator (%x (make-hash-table)) (macrolet ((expand-%x (&environment env) (let ((expanded-form (macroexpand '(%x) env))) (if (equal expanded-form '(%x)) nil t)))) (expand-%x))) t) (deftest with-hash-table-iterator.10 (let ((table (make-hash-table))) (loop for key from 1 to 100 for val from 101 to 200 do (setf (gethash key table) val)) (let ((pairs nil)) (with-hash-table-iterator (%x table) (loop (multiple-value-bind (success key val) (%x) (unless success (return nil)) (remhash key table) (push (cons key val) pairs)))) (assert (eql (length pairs) 100)) (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) (values (hash-table-count table) (loop for (key . val) in pairs for expected-key from 1 for expected-val from 101 always (and (eql key expected-key) (eql val expected-val)))))) 0 t) (deftest with-hash-table-iterator.11 (let ((table (make-hash-table))) (loop for key from 1 to 100 for val from 101 to 200 do (setf (gethash key table) val)) (let ((pairs nil)) (with-hash-table-iterator (%x table) (loop (multiple-value-bind (success key val) (%x) (unless success (return nil)) (setf (gethash key table) (+ 1000 val)) (push (cons key val) pairs)))) (assert (eql (length pairs) 100)) (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) (values (hash-table-count table) (loop for (key . val) in pairs for expected-key from 1 for expected-val from 101 always (and (eql key expected-key) (eql val expected-val) (eql (gethash key table) (+ 1000 val)) ))))) 100 t) ;;; Free declaration scope (deftest with-hash-table-iterator.12 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-hash-table-iterator (m (return-from done x)) (declare (special x)))))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/unintern.lsp0000644000000000000000000000013114542551763016033 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.537789381 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/unintern.lsp0000644000175000017500000002010714542551763015432 0ustar00cammcamm();-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:56 1998 ;;;; Contains: Tests of UNINTERN (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" :use nil)) (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" :use nil))) (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" :use nil))) (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" :use nil))) (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" :use nil))) (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" :use nil) (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" :use nil)) (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" :use nil)) (pg2 (make-package "G2" :use nil)) (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" :use nil)) (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) ;;; Specialized sequence tests (defmacro def-unintern-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (prog1 (let ((p (make-package name :use nil))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym name) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package name))) t)) (def-unintern-test unintern.10 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unintern-test unintern.11 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unintern-test unintern.12 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unintern-test unintern.13 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unintern-test unintern.14 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unintern-test unintern.15 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unintern-test unintern.16 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (deftest unintern.error.1 (signals-error (unintern) program-error) t) (deftest unintern.error.2 (signals-error (unintern '#:x "CL-TEST" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/constantp.lsp0000644000000000000000000000013214542551762016202 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.537789381 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/constantp.lsp0000644000175000017500000000331414542551762015601 0ustar00cammcamm;-*- 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) ;;; Error tests (deftest constantp.error.1 (signals-error (constantp) program-error) t) (deftest constantp.error.2 (signals-error (constantp nil nil nil) program-error) t) ;;; Non-error tests (deftest constantp.1 (check-predicate #'(lambda (e) (or (symbolp e) (consp e) (constantp 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) (defmacro macro-for-constantp.11 (x) x) (deftest constantp.11 (macrolet ((macro-for-constantp.11 (y) (declare (ignore y)) '*standard-input*)) (macrolet ((%m (&environment env) (if (constantp '(macro-for-constantp.11 0) env) :bad :good))) (%m))) :good) (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.7.1/ansi-tests/PaxHeaders/equalp.lsp0000644000000000000000000000013214542551762015460 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.537789381 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/equalp.lsp0000644000175000017500000001576114542551762015070 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 22:14:42 2002 ;;;; Contains: Tests for EQUALP (in-package :cl-test) (compile-and-load "random-aux.lsp") (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.5 :notes (:allow-nil-arrays) (equalpt (make-array '(0) :element-type nil) #()) t) (deftest equalp.6 :notes (:allow-nil-arrays) (equalpt (make-array '(0) :element-type nil) "") t) (deftest equalp.7 (loop for nbits from 1 to 100 for type = `(unsigned-byte ,nbits) for bound = (ash 1 nbits) for val = (random bound) for a1 = (make-array nil :initial-element val :element-type type) for a2 = (make-array nil :initial-element val) unless (equalp a1 a2) collect (list nbits type val)) nil) (deftest equalp.8 (loop for nbits from 1 to 100 for type = `(unsigned-byte ,nbits) for bound = (ash 1 nbits) for n = (1+ (random 20)) for vals = (loop repeat n collect (random bound)) for a1 = (make-array n :initial-contents vals :element-type type) for a2 = (make-array n :initial-contents vals) unless (equalp a1 a2) collect (list nbits type vals)) nil) (deftest equalp.9 (loop for nbits from 1 to 100 for type = `(signed-byte ,nbits) for bound = (ash 1 nbits) for n = (1+ (random 20)) for vals = (loop repeat n collect (- (random bound) (/ bound 2))) for a1 = (make-array n :initial-contents vals :element-type type) for a2 = (make-array n :initial-contents vals) unless (equalp a1 a2) collect (list nbits type vals)) nil) (deftest equalp.10 (equalpt #*0010 #(0 0 1 0)) t) (deftest equalp.11 (let ((v1 #(1 2 3)) (v2 (make-array 8 :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 3))) (equalpt v1 v2)) t) (deftest equalp.12 (equalpt '(#\a #\b) "ab") nil) (deftest equalp.13 (equalpt '(#\a #\b) '(#\A #\B)) t) (deftest equalp.14 (let ((s1 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) :element-type 'base-char)) (s2 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) :element-type 'character))) (equalpt s1 s2)) t) (deftest equalp.15 (let ((bv (make-array '(4) :initial-contents '(0 0 1 0) :element-type 'bit)) (v #(0 0 1 0))) (equalpt bv v)) t) (defstruct equalp-struct-16 a b c) (defstruct equalp-struct-16-alt a b c) (deftest equalp.16 (let ((s1 (make-equalp-struct-16 :a 1 :b 2 :c #\a)) (s2 (make-equalp-struct-16 :a 1.0 :b 2.0 :c #\A)) (s3 (make-equalp-struct-16-alt :a 1.0 :b 2.0 :c #\A))) (values (equalpt s1 s2) (equalpt s1 s3) (equalpt s2 s3))) t nil nil) (deftest equalp.17 (loop for i below 8192 for f = (float i 1.0s0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.18 (loop for i = (- (random 10000000) 5000000) for f = (float i 1.0f0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.19 (loop for i = (- (random 10000000) 5000000) for f = (float i 1.0d0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.20 (loop for i = (- (random 10000000) 5000000) for f = (float i 1.0l0) repeat 1000 unless (equalp i f) collect (list i f)) nil) (deftest equalp.21 (let ((ht1 (make-hash-table :test #'eq)) (ht2 (make-hash-table :test #'eql)) (ht3 (make-hash-table :test #'equal)) (ht4 (make-hash-table :test #'equalp))) (values (equalpt ht1 ht2) (equalpt ht1 ht3) (equalpt ht1 ht4) (equalpt ht2 ht3) (equalpt ht2 ht4) (equalpt ht3 ht4))) nil nil nil nil nil nil) (deftest equalp.22 (equalpt (make-hash-table :test 'eq) (make-hash-table :test #'eq)) t) (deftest equalp.23 (equalpt (make-hash-table :test 'eql) (make-hash-table :test #'eql)) t) (deftest equalp.24 (equalpt (make-hash-table :test 'equal) (make-hash-table :test #'equal)) t) (deftest equalp.25 (equalpt (make-hash-table :test 'equalp) (make-hash-table :test #'equalp)) t) (deftest equalp.26 (let ((ht1 (make-hash-table :test #'eq)) (ht2 (make-hash-table :test #'eq))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.27 (let ((ht1 (make-hash-table :test #'eq)) (ht2 (make-hash-table :test #'eq))) (setf (gethash 'a ht1) #\a) (setf (gethash 'a ht2) #\A) (equalpt ht1 ht2)) t) (deftest equalp.28 (let ((ht1 (make-hash-table :test #'eql)) (ht2 (make-hash-table :test #'eql))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.29 (let ((ht1 (make-hash-table :test #'eql)) (ht2 (make-hash-table :test #'eql))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) t) (deftest equalp.30 (let ((ht1 (make-hash-table :test #'equal)) (ht2 (make-hash-table :test #'equal))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.31 (let ((ht1 (make-hash-table :test #'equal)) (ht2 (make-hash-table :test #'equal))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) t) (deftest equalp.32 (let ((ht1 (make-hash-table :test #'equalp)) (ht2 (make-hash-table :test #'equalp))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) t) (deftest equalp.33 (let ((ht1 (make-hash-table :test #'equalp)) (ht2 (make-hash-table :test #'equalp))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) t) (deftest equalp.34 (let ((ht1 (make-hash-table :test #'equalp)) (ht2 (make-hash-table :test #'equalp))) (setf (gethash '#:a ht1) t) (setf (gethash '#:a ht2) t) (equalpt ht1 ht2)) nil) (deftest equalp.35 (loop for test in '(eq eql equal equalp) collect (flet ((%make-table () (apply #'make-hash-table :test test `(,@(when (coin) (list :size (random 100))) ,@(when (coin) (list :rehash-size (1+ (random 50)))) ,@(when (coin) (list :rehash-threshold (random 1.0)) ))))) (loop repeat 200 count (let ((ht1 (%make-table)) (ht2 (%make-table)) (pairs (loop for i below (random 100) collect (cons (gensym) i)))) (loop for (k . v) in pairs do (setf (gethash k ht1) v)) (setf pairs (random-permute pairs)) (loop for (k . v) in pairs do (setf (gethash k ht2) v)) (not (equalp ht1 ht2)))))) (0 0 0 0)) (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) ;;; Error tests (deftest equalp.error.1 (signals-error (equalp) program-error) t) (deftest equalp.error.2 (signals-error (equalp nil) program-error) t) (deftest equalp.error.3 (signals-error (equalp nil nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/search-string.lsp0000644000000000000000000000013214542551763016743 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.537789381 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/search-string.lsp0000644000175000017500000001232514542551763016344 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on strings (in-package :cl-test) (compile-and-load "search-aux.lsp") ;;; 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) ;; Order of test, test-not (deftest search-string.17 (let ((pat "m") (target '"adgmnpq")) (search pat target :test #'char<)) 4) (deftest search-string.18 (let ((pat "m") (target '"adgmnpq")) (search pat target :test-not #'char>=)) 4) ;;; Specialized strings (deftest search-string.19 (do-special-strings (s "a" nil) (assert (eql (search s "xyza123apqr") 3)) (assert (eql (search s "xyza1a3apqr" :start2 4) 5)) (assert (eql (search s "xyza123apqr" :from-end t) 7))) nil) (deftest search-string.20 (do-special-strings (s "xababcdefabc123ababc18" nil) (assert (eql (search "abc" s) 3)) (assert (eql (search "abc" s :start2 4) 9)) (assert (eql (search "abc" s :from-end t) 17))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/format-b.lsp0000644000000000000000000000013214542551762015700 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.537789381 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-b.lsp0000644000175000017500000003717314542551762015311 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 05:10:10 2004 ;;;; Contains: Tests of the ~B format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.b.1 (let ((fn (formatter "~b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~B" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 2)) (read-from-string s1)) repeat 1000 when (or (not (string= s1 s2)) (/= i j) (find #\+ s1) (loop for c across s1 thereis (not (find c "-01")))) collect (list i s1 j s2)))) nil) (deftest format.b.2 (let ((fn (formatter "~@b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@b" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 2)) (read-from-string s1)) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (loop for c across s1 thereis (not (find c "-+01")))) collect (list i s1 j s2)))) nil) (deftest format.b.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~db" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~db" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.b.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@B" i) for fmt = (format nil "~~~d@b" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@B" i) for fmt = (format nil "~~~d@b" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.b.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "bB")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "bB")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.b.6 (let ((fn (formatter "~v,vB"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~b" i) for s2 = (format nil "~v,vb" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.b.7 (let ((fn (formatter "~v,v@B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@B" i) for s2 = (format nil "~v,v@b" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests (deftest format.b.8 (let ((fn (formatter "~:B"))) (loop for i from -7 to 7 for s1 = (format nil "~b" i) for s2 = (format nil "~:b" i) for s3 = (formatter-call-to-string fn i) unless (and (string= s1 s2) (string= s2 s3)) collect (list i s1 s2 s3))) nil) (deftest format.b.9 (let ((fn (formatter "~:b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~b" i) for s2 = (format nil "~:B" i) for s3 = (formatter-call-to-string fn i) repeat 1000 unless (and (string= s1 (remove commachar s2)) (string= s2 s3) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "01"))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.10 (let ((fn (formatter "~,,v:B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~b" i) for s2 = (format nil "~,,v:b" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~b" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) for s2 = (format nil fmt i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.b.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~b" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.b.12 (let ((fn (formatter "~,,V,V:b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~b" i) for s2 = (format nil "~,,v,v:B" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.13 (let ((fn (formatter "~,,V,V@:B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@B" i) for s2 = (format nil "~,,v,v:@b" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.b.14 "~vb" (nil #b110100) "110100") (def-format-test format.b.15 "~6,vB" (nil #b100) " 100") (def-format-test format.b.16 "~,,v:b" (nil #b10011) "10,011") (def-format-test format.b.17 "~,,'*,v:B" (nil #b10110) "10*110") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.b.18 (let ((fn (formatter "~b"))) (loop for x in *mini-universe* for s1 = (format nil "~b" x) for s2 = (let ((*print-base* 2)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) collect (list x s1 s2 s3))) nil) (deftest format.b.19 (let ((fn (formatter "~:b"))) (loop for x in *mini-universe* for s1 = (format nil "~:B" x) for s2 = (let ((*print-base* 2)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) collect (list x s1 s2 s3))) nil) (deftest format.b.20 (let ((fn (formatter "~@b"))) (loop for x in *mini-universe* for s1 = (format nil "~@b" x) for s2 = (let ((*print-base* 2)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) collect (list x s1 s2 s3))) nil) (deftest format.b.21 (let ((fn (formatter "~:@b"))) (loop for x in *mini-universe* for s1 = (let ((*print-base* 2)) (format nil "~A" x)) for s2 = (format nil "~@:B" x) for s3 = (formatter-call-to-string fn x) for s4 = (let ((*print-base* 2)) (format nil "~A" x)) unless (or (integerp x) (and (string= s1 s2) (string= s1 s3)) (string/= s1 s4)) collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.b.22 (apply #'values (let ((fn (formatter "~#B")) (bv #b11001)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#b" bv args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream bv args) args))) do (assert (string= s s2)) collect s))) "11001" "11001" "11001" "11001" "11001" " 11001" " 11001" " 11001" " 11001" " 11001" " 11001") (deftest format.b.23 (apply #'values (let ((fn (formatter "~,,,#:b")) (bv #b1100100010)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:B" bv args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream bv args) args))) do (assert (string= s s2)) collect s))) "1,1,0,0,1,0,0,0,1,0" "11,00,10,00,10" "1,100,100,010" "11,0010,0010" "11001,00010" "1100,100010" "110,0100010" "11,00100010" "1,100100010" "1100100010" "1100100010") (deftest format.b.24 (apply #'values (let ((fn (formatter "~,,,#@:B")) (bv #b1100100010)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:B" bv args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream bv args) args))) do (assert (string= s s2)) collect s))) "+1,1,0,0,1,0,0,0,1,0" "+11,00,10,00,10" "+1,100,100,010" "+11,0010,0010" "+11001,00010" "+1100,100010" "+110,0100010" "+11,00100010" "+1,100100010" "+1100100010" "+1100100010") (def-format-test format.b.25 "~+10b" (#b1101) " 1101") (def-format-test format.b.26 "~+10@B" (#b1101) " +1101") (def-format-test format.b.27 "~-1b" (#b1101) "1101") (def-format-test format.b.28 "~-1000000000000000000B" (#b1101) "1101") (def-format-test format.b.29 "~vb" ((1- most-negative-fixnum) #b1101) "1101") ;;; Randomized test (deftest format.b.30 (let ((fn (formatter "~V,V,V,VB"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~db" commaint) "b")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vb" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2))) nil)gcl-2.7.1/ansi-tests/PaxHeaders/restart-bind.lsp0000644000000000000000000000013114542551763016567 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.537789381 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/restart-bind.lsp0000644000175000017500000001146014542551763016170 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 21 22:28:53 2003 ;;;; Contains: Tests for RESTART-BIND (in-package :cl-test) (deftest restart-bind.1 (restart-bind () nil) nil) (deftest restart-bind.2 (restart-bind () (values))) (deftest restart-bind.3 (restart-bind () (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest restart-bind.4 (block nil (restart-bind () (return 'good) 'bad)) good) (deftest restart-bind.5 (block done (tagbody (restart-bind () (go 10) (return-from done 'bad)) 10 (return-from done 'good))) good) (deftest restart-bind.6 (restart-bind ()) nil) (deftest restart-bind.7 (block done (restart-bind ((foo #'(lambda () (return-from done 'good)))) (invoke-restart 'foo) 'bad)) good) (deftest restart-bind.8 (block done (restart-bind ((foo #'(lambda () (return-from done 'good)))) (let ((restart (find-restart 'foo))) (and (typep restart 'restart) (invoke-restart restart))) 'bad)) good) (deftest restart-bind.9 (restart-bind ((foo #'(lambda (a b c) (list c a b)))) (invoke-restart 'foo 1 2 3)) (3 1 2)) (deftest restart-bind.10 (flet ((%f () (invoke-restart 'foo 'x 'y 'z))) (restart-bind ((foo #'(lambda (a b c) (list c a b)))) (%f))) (z x y)) (deftest restart-bind.11 (restart-bind ((foo #'(lambda () 'bad))) (restart-bind ((foo #'(lambda () 'good))) (invoke-restart 'foo))) good) (deftest restart-bind.12 (let ((*x* 'bad)) (declare (special *x*)) (restart-bind ((foo #'(lambda () (declare (special *x*)) *x*))) (let ((*x* 'good)) (declare (special *x*)) (invoke-restart 'foo)))) good) (deftest restart-bind.13 (restart-bind ((foo #'(lambda () 'bad))) (flet ((%f () (invoke-restart 'foo))) (restart-bind ((foo #'(lambda () 'good))) (%f)))) good) (deftest restart-bind.14 (let ((x 10) (y nil)) (restart-bind ((foo #'(lambda () (when (> x 0) (push 'a y) (decf x) (invoke-restart 'foo)) y))) (invoke-restart 'foo))) (a a a a a a a a a a)) (deftest restart-bind.15 (block done (let ((i 0)) (restart-bind ((foo (progn (incf i) #'(lambda () (return-from done i))))) (invoke-restart 'foo) 'bad))) 1) (deftest restart-bind.16 (let ((i 0)) (values (with-output-to-string (s) (restart-bind ((foo #'(lambda () nil) :report-function (progn (incf i) #'(lambda (s) (format s "A report"))))) (let ((*print-escape* nil)) (format s "~A" (find-restart 'foo))))) i)) "A report" 1) (deftest restart-bind.17 (restart-bind ((foo #'(lambda () 'good)) (foo #'(lambda () 'bad))) (invoke-restart 'foo)) good) (deftest restart-bind.18 (restart-bind ((foo #'(lambda () 'good)) (bar #'(lambda () 'bad))) (invoke-restart 'foo)) good) (deftest restart-bind.19 (restart-bind ((foo #'(lambda () 'bad)) (bar #'(lambda () 'good))) (invoke-restart 'bar)) good) ;;; Using the :test-function to associate a restart with a condition ;;; This test is disabled until I figure out how to fix ;;; it. See sbcl-devel mailing list, Oct 2005 #| (deftest restart-bind.20 (let ((c (make-condition 'error))) (restart-bind ((foo #'(lambda () 'bad) :test-function #'(lambda (c1) (not (eq c c1)))) (foo #'(lambda () 'good) :test-function #'(lambda (c2) (or (null c2) (eq c c2))))) (invoke-restart (find-restart 'foo c)))) good) |# (deftest restart-bind.21 (let ((c (make-condition 'error))) (restart-bind ((foo #'(lambda () 'bad) :test-function #'(lambda (c1) nil)) (foo #'(lambda () 'good) :test-function #'(lambda (c2) t))) (invoke-restart (find-restart 'foo c)))) good) (deftest restart-bind.22 (let ((c (make-condition 'error)) (i 0)) (values (restart-bind ((foo #'(lambda () 'good) :test-function (progn (incf i) #'(lambda (c2) t)))) (invoke-restart (find-restart 'foo c))) i)) good 1) ;;; Error tests (deftest restart-bind.error.1 (signals-error (restart-bind ((foo #'(lambda () t))) (invoke-restart 'foo 'a)) program-error) t) (deftest restart-bind.error.2 (signals-error (restart-bind ((foo #'(lambda (x) x))) (invoke-restart 'foo)) program-error) t) (deftest restart-bind.error.3 (signals-error (restart-bind ((foo #'identity)) (invoke-restart 'foo)) program-error) t) (deftest restart-bind.23 (restart-bind ((foo #'(lambda () 'good))) (invoke-restart-interactively 'foo)) good) (deftest restart-bind.24 (let ((i 0)) (values (restart-bind ((foo #'(lambda (x y z) (list z y x)) :interactive-function (progn (incf i) #'(lambda () (list 'a 'b 'c))))) (invoke-restart-interactively 'foo)) i)) (c b a) 1) gcl-2.7.1/ansi-tests/PaxHeaders/letstar.lsp0000644000000000000000000000013114542551762015646 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.537789381 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/letstar.lsp0000644000175000017500000000666614542551762015263 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 24 20:53:36 2005 ;;;; Contains: Tests for LET* (in-package :cl-test) (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 100) (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 = `(ignore-errors (let* ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) ;;; Check that LET* does not have a tagbody (deftest let*.16 (block done (tagbody (let () (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Check that free declarations do not apply to the init forms (deftest let*.17 (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let* ((y x)) (declare (special x)) ;; free declaration y))) :good) (deftest let*.17a (funcall (compile nil '(lambda () (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let* ((y x)) (declare (special x)) ;; free declaration y)))))) :good) (deftest let*.18 (let ((x :bad1) (z :bad2)) (declare (special x z)) (let ((x :good) (z :good)) ;; lexical bindings (let* ((y x) (w z)) (declare (special x)) ;; free declaration (values y w)))) :good :good) (deftest let*.19 (let ((foo 'special)) (declare (special foo)) (let* ((foo 'lexical)) (locally (declare (special foo))) foo)) lexical) (deftest let*.20 (loop for k in lambda-list-keywords unless (eql (eval `(let* ((,k :foo)) ,k)) :foo) collect k) nil) ;;; Macros are expanded in the appropriate environment (deftest let*.21 (macrolet ((%m (z) z)) (let* () (expand-in-current-env (%m :good)))) :good) (deftest let*.22 (macrolet ((%m (z) z)) (let* ((x (expand-in-current-env (%m 1)))) (+ x x x))) 3) (deftest let*.23 (macrolet ((%m (z) z)) (let* ((x (expand-in-current-env (%m 1))) (y (expand-in-current-env (%m 2)))) (+ x y))) 3) gcl-2.7.1/ansi-tests/PaxHeaders/format-question.lsp0000644000000000000000000000013214542551762017326 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.537789381 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-question.lsp0000644000175000017500000000147314542551762016731 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 17 20:08:18 2004 ;;;; Contains: Tests of the ~? and ~@? format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.?.1 "~?" ("" nil) "") (def-format-test format.?.2 "~?" ("~A" '(1)) "1") (def-format-test format.?.3 "~?" ("" '(1)) "") (def-format-test format.?.4 "~? ~A" ("" '(1) 2) " 2") (def-format-test format.?.5 "a~?z" ("b~?y" '("c~?x" ("~A" (1)))) "abc1xyz") ;;; Tests of ~@? (def-format-test format.@?.1 "~@?" ("") "") (def-format-test format.@?.2 "~@?" ("~A" 1) "1") (def-format-test format.@?.3 "~@? ~A" ("<~A>" 1 2) "<1> 2") (def-format-test format.@?.4 "a~@?z" ("b~@?y" "c~@?x" "~A" 1) "abc1xyz") (def-format-test format.@?.5 "~{~A~@?~A~}" ('(1 "~4*" 2 3 4 5 6)) "16") gcl-2.7.1/ansi-tests/PaxHeaders/minusp.lsp0000644000000000000000000000013114542551763015504 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.537789381 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/minusp.lsp0000644000175000017500000000231214542551763015101 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:33:44 2003 ;;;; Contains: Tests of MINUSP (in-package :cl-test) (deftest minusp.error.1 (signals-error (minusp) program-error) t) (deftest minusp.error.2 (signals-error (minusp 0 0) program-error) t) (deftest minusp.error.3 (signals-error (minusp 0 nil) program-error) t) (deftest minusp.error.4 (check-type-error #'minusp #'realp) nil) (deftest minusp.1 (minusp 0) nil) (deftest minusp.2 (notnot-mv (minusp -1)) t) (deftest minusp.3 (minusp 1) nil) (deftest minusp.4 (loop for x in *reals* when (if (minusp x) (>= x 0) (< x 0)) collect x) nil) (deftest minusp.5 (some #'minusp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) nil) (deftest minusp.6 (remove-if #'minusp (list 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 most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/pprint-linear.lsp0000644000000000000000000000013114542551763016755 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.537789381 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-linear.lsp0000644000175000017500000001047614542551763016364 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 26 21:55:26 2004 ;;;; Contains: Tests of PPRINT-LINEAR (in-package :cl-test) ;;; When printing a non-list, the result is the same as calling WRITE." (deftest pprint-linear.1 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (assert (equal (multiple-value-list (pprint-linear s obj)) '(nil)))))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (deftest pprint-linear.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (assert (equal (multiple-value-list (pprint-linear s obj)) '(nil)))))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-linear-test (name args expected-value &key (margin 100) (circle nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* ,margin) (*package* (find-package "CL-TEST")) (*print-circle* ,circle)) (with-output-to-string (s) (pprint-linear s ,@args)))) ,expected-value)) (def-pprint-linear-test pprint-linear.3 ('(|A|)) "(A)") (def-pprint-linear-test pprint-linear.4 ('(|A|) t) "(A)") (def-pprint-linear-test pprint-linear.5 ('(|A|) nil) "A") (def-pprint-linear-test pprint-linear.6 ('(1 2 3 4 5)) "(1 2 3 4 5)") (def-pprint-linear-test pprint-linear.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5") ;;; The fourth argument is ignored (def-pprint-linear-test pprint-linear.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)") (def-pprint-linear-test pprint-linear.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5") ;;; Takes T, NIL as stream designators (deftest pprint-linear.10 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-linear t '(1 2 3))))))) "(1 2 3)") (deftest pprint-linear.11 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-linear nil '(1 2 3))))) "(1 2 3)") (deftest pprint-linear.12 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-linear os obj)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string s) obj)) (list :bad2 s)) ((< (count #\Newline s) (length obj)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) (deftest pprint-linear.13 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-linear os obj nil)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string (concatenate 'string "(" s ")")) obj)) (list :bad2 s)) ((< (count #\Newline s) (length obj)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) ;;; (def-pprint-linear-test pprint-linear.14 ((let ((x (list '|A|))) (list x x))) "(#1=(A) #1#)" :circle t) ;;; Error tests (deftest pprint-linear.error.1 (signals-error (pprint-linear) program-error) t) (deftest pprint-linear.error.2 (signals-error (pprint-linear *standard-output*) program-error) t) (deftest pprint-linear.error.3 (signals-error (pprint-linear *standard-output* nil t t t) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-objects.lsp0000644000000000000000000000013214772071554016540 xustar0030 mtime=1743287148.622904517 30 atime=1744294960.541789399 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-objects.lsp0000644000175000017500000000352614772071554016144 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 24 03:39:09 2003 ;;;; Contains: Loader for CLOS-related test files (compile-and-load "defclass-aux.lsp") (load "defclass.lsp") (load "defclass-01.lsp") (load "defclass-02.lsp") (load "defclass-03.lsp") (load "defclass-errors.lsp") (load "defclass-forward-reference.lsp") (load "ensure-generic-function.lsp") (load "allocate-instance.lsp") (load "reinitialize-instance.lsp") (load "shared-initialize.lsp") (load "change-class.lsp") (load "update-instance-for-different-class.lsp") (load "slot-boundp.lsp") (load "slot-exists-p.lsp") (load "slot-makunbound.lsp") (load "slot-missing.lsp") (load "slot-unbound.lsp") (load "slot-value.lsp") (load "method-qualifiers.lsp") (load "no-applicable-method.lsp") (load "no-next-method.lsp") (load "remove-method.lsp") (load "make-instance.lsp") (load "make-instances-obsolete.lsp") (load "make-load-form.lsp") (load "make-load-form-saving-slots.lsp") (load "with-accessors.lsp") (load "with-slots.lsp") (load "defgeneric.lsp") (load "defgeneric-method-combination-aux.lsp") (load "defgeneric-method-combination-plus.lsp") (load "defgeneric-method-combination-append.lsp") (load "defgeneric-method-combination-nconc.lsp") (load "defgeneric-method-combination-list.lsp") (load "defgeneric-method-combination-max.lsp") (load "defgeneric-method-combination-min.lsp") (load "defgeneric-method-combination-and.lsp") (load "defgeneric-method-combination-or.lsp") (load "defgeneric-method-combination-progn.lsp") ;; (load "defgeneric-method-combination-standard.lsp") (load "find-class.lsp") (load "next-method-p.lsp") (load "call-next-method.lsp") (load "compute-applicable-methods.lsp") (load "define-method-combination.lsp") (load "find-method.lsp") (load "add-method.lsp") (load "class-name.lsp") (load "class-of.lsp") (load "unbound-slot.lsp") (load "defmethod.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/pprint-exit-if-list-exhausted.lsp0000644000000000000000000000013114542551763022011 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.541789399 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-exit-if-list-exhausted.lsp0000644000175000017500000002015714542551763021415 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 6 06:11:01 2004 ;;;; Contains: Tests of PPRINT-EXIT-IF-LIST-EXHAUSTED, PPRINT-POP (in-package :cl-test) (deftest pprint-exit-if-list-exhausted.1 (with-standard-io-syntax (let ((*print-pretty* nil) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 2)) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write #\Space :stream os) (write (pprint-pop) :stream os) (pprint-exit-if-list-exhausted) (assert nil))))) "1 2") (deftest pprint-exit-if-list-exhausted.2 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 2)) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write #\Space :stream os) (write (pprint-pop) :stream os) (pprint-exit-if-list-exhausted) (assert nil))))) "1 2") (deftest pprint-exit-if-list-exhausted.3 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 . 2)) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (write #\Space :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (pprint-pop) (assert nil))))) "1 . 2") (deftest pprint-exit-if-list-exhausted.4 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) ) (with-output-to-string (os) (pprint-logical-block (os '(1 . 2) :prefix "[" :suffix "]") (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (write (pprint-pop) :stream os) (write #\Space :stream os) (assert (equal (multiple-value-list (pprint-exit-if-list-exhausted)) '(nil))) (pprint-pop) (assert nil))))) "[1 . 2]") ;;; Tests focusing on pprint-pop (deftest pprint-pop.1 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block (os nil) (pprint-pop) (assert nil))))) "...") (deftest pprint-pop.2 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block (os 1) (pprint-pop))))) "1") (deftest pprint-pop.3 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 1)) (with-output-to-string (os) (pprint-logical-block (os '(1)) (assert (equal '(1) (multiple-value-list (pprint-pop)))))))) "") (deftest pprint-pop.4 (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3) :prefix "{" :suffix "}") (pprint-pop) (assert nil))))) "{...}") (deftest pprint-pop.5 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 3 4 5) :prefix "{" :suffix "}") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os)))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4) (%f 5) (%f 6))) "{...}" "{1 ...}" "{1 2 ...}" "{1 2 3 ...}" "{1 2 3 4 ...}" "{1 2 3 4 5}" "{1 2 3 4 5}") (deftest pprint-pop.6 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len)) (with-output-to-string (os) (pprint-logical-block (os '(1 2 . 3) :prefix "{" :suffix "}") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os)))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "{...}" "{1 ...}" "{1 2 . 3}" "{1 2 . 3}" "{1 2 . 3}") ;;; pprint-pop and circularity/sharing (deftest pprint-pop.7 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len) (*print-circle* t)) (with-output-to-string (os) (let* ((tail (list 1)) (x (list* tail 2 tail))) (pprint-logical-block (os x :prefix "<" :suffix ">") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os))))))))) (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "<#1=(1) 2 . #1#>" "<...>" "<(1) ...>" "<(1) 2 ...>" "<#1=(1) 2 . #1#>" "<#1=(1) 2 . #1#>") (deftest pprint-pop.8 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len) (*print-circle* t)) (with-output-to-string (os) (let* ((tail (list 2)) (x (list* 1 tail))) (setf (cdr tail) tail) (pprint-logical-block (os x :prefix "[[" :suffix "]]") (pprint-exit-if-list-exhausted) (write (pprint-pop) :stream os) (loop (pprint-exit-if-list-exhausted) (write #\Space :stream os) (write (pprint-pop) :stream os))))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 10) (%f 20))) "[[...]]" "[[1 ...]]" "[[1 2 ...]]" "[[1 . #1=(2 . #1#)]]" "[[1 . #1=(2 . #1#)]]" "[[1 . #1=(2 . #1#)]]") ;;; pprint-pop when pprint-logical-block is given NIL (deftest pprint-pop.9 (flet ((%f (len) (with-standard-io-syntax (let ((*print-pretty* t) (*print-escape* nil) (*print-right-margin* 100) (*print-readably* nil) (*print-length* len)) (with-output-to-string (os) (pprint-logical-block (os nil :prefix "{" :suffix "}") (let ((vals (multiple-value-list (pprint-pop)))) (assert (equal vals '(nil)) () "First call returned ~A" vals)) (write 1 :stream os) (write #\Space :stream os) (let ((vals (multiple-value-list (pprint-pop)))) (assert (equal vals '(nil)) () "Second call returned ~A" vals)) (write 2 :stream os) (write #\Space :stream os) (let ((vals (multiple-value-list (pprint-pop)))) (assert (equal vals '(nil)) () "Third call returned ~A" vals)) (write 3 :stream os) )))))) (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "{1 2 3}" "{...}" "{1 ...}" "{1 2 ...}" "{1 2 3}" "{1 2 3}") ;;; Error cases (deftest pprint-exit-if-list-exhausted.error.1 (signals-error (pprint-exit-if-list-exhausted) error) t) (deftest pprint-exit-if-list-exhausted.error.1-unsafe (locally (declare (optimize (safety 0))) (signals-error (locally (declare (optimize (safety 0))) (pprint-exit-if-list-exhausted)) error)) t) (deftest pprint-pop.error.1 (signals-error (pprint-pop) error) t) (deftest pprint-pop.error.1-unsafe (locally (declare (optimize (safety 0))) (signals-error (locally (declare (optimize (safety 0))) (pprint-pop)) error)) t) gcl-2.7.1/ansi-tests/PaxHeaders/error.lsp0000644000000000000000000000013214542551762015322 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.541789399 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/error.lsp0000644000175000017500000000427714542551762014732 0ustar00cammcamm;-*- 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) (declare (ignore c)) :wrong) (simple-condition (c) (declare (ignore c)) :right)) :right) (deftest error.7 (handler-case (error 'simple-warning) (error (c) (declare (ignore c)) :wrong) (simple-warning (c) (declare (ignore c)) :right) (condition (c) (declare (ignore 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) (deftest error.9 (let ((fmt (formatter "Boo!"))) (handler-case (error 'simple-warning :format-control fmt) (simple-warning (c) (frob-simple-warning c fmt)))) t) (deftest error.10 (let ((fmt (formatter "Error"))) (handler-case (error 'simple-error :format-control fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.11 (let ((fmt (formatter "Error"))) (handler-case (error fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.12 (let* ((fmt (formatter "Error")) (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (error cnd) (simple-error (c) (frob-simple-error c fmt)))) t) ;;; Tests for other conditions will in their own files. gcl-2.7.1/ansi-tests/PaxHeaders/nsubst-if-not.lsp0000644000000000000000000000013114542551763016701 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.541789399 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nsubst-if-not.lsp0000644000175000017500000000562714542551763016312 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:54:12 2003 ;;;; Contains: Tests of NSUBST-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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-not.2 (check-nsubst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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-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-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-not.6 (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) nil) (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) ;;; 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 (deftest nsubst-if-not.error.1 (signals-error (nsubst-if-not) program-error) t) (deftest nsubst-if-not.error.2 (signals-error (nsubst-if-not 'a) program-error) t) (deftest nsubst-if-not.error.3 (signals-error (nsubst-if-not 'a #'null) program-error) t) (deftest nsubst-if-not.error.4 (signals-error (nsubst-if-not 'a #'null nil :foo nil) program-error) t) (deftest nsubst-if-not.error.5 (signals-error (nsubst-if-not 'a #'null nil :test) program-error) t) (deftest nsubst-if-not.error.6 (signals-error (nsubst-if-not 'a #'null nil 1) program-error) t) (deftest nsubst-if-not.error.7 (signals-error (nsubst-if-not 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest nsubst-if-not.error.8 (signals-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/subst-if.lsp0000644000000000000000000000013114542551763015725 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.541789399 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subst-if.lsp0000644000175000017500000000534214542551763015330 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:39:42 2003 ;;;; Contains: Tests of SUBST-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (deftest subst-if.1 (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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.4 (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (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.6 (check-subst-if 'a #'(lambda (x) (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) (def-fold-test subst-if.fold.1 (subst-if 'x 'numberp '(a b 3 (4) c d . 12))) ;;; 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) ;;; Error tests (deftest subst-if.error.1 (signals-error (subst-if) program-error) t) (deftest subst-if.error.2 (signals-error (subst-if 'a) program-error) t) (deftest subst-if.error.3 (signals-error (subst-if 'a #'null) program-error) t) (deftest subst-if.error.4 (signals-error (subst-if 'a #'null nil :foo nil) program-error) t) (deftest subst-if.error.5 (signals-error (subst-if 'a #'null nil :test) program-error) t) (deftest subst-if.error.6 (signals-error (subst-if 'a #'null nil 1) program-error) t) (deftest subst-if.error.7 (signals-error (subst-if 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest subst-if.error.8 (signals-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/number-comparison.lsp0000644000000000000000000000013114542551763017631 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.541789399 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/number-comparison.lsp0000644000175000017500000012554714542551763017246 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 7 07:17:42 2003 ;;;; Contains: Tests of =, /=, <, <=, >, >= (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Errors tests on comparison functions (deftest =.error.1 (signals-error (=) program-error) t) (deftest /=.error.1 (signals-error (/=) program-error) t) (deftest <.error.1 (signals-error (<) program-error) t) (deftest <=.error.1 (signals-error (<=) program-error) t) (deftest >.error.1 (signals-error (>) program-error) t) (deftest >=.error.1 (signals-error (>=) program-error) t) ;;; Tests of = (deftest =.1 (loop for x in *numbers* unless (= x) collect x) nil) (deftest =.2 (loop for x in *numbers* unless (= x x) collect x) nil) (deftest =.3 (loop for x in *numbers* unless (= x x x) collect x) nil) (deftest =.4 (=.4-fn) nil) (deftest =.5 (loop for i from 1 to 10000 for i2 = (1+ i) never (or (= i i2) (= i2 i))) t) (deftest =.6 (loop for i from 5 to 10000 by 17 for j from 2 to i by 19 for r = (/ i j) unless (and (not (= r (1+ r))) (not (= r 0)) (not (= r (- r))) (= r r)) collect r) nil) (deftest =.7 (let ((args nil)) (loop for i from 1 to (min 256 (1- call-arguments-limit)) do (push 17 args) always (apply #'= args))) t) (deftest =.8 (loop for i from 2 to (min 256 (1- call-arguments-limit)) for args = (append (make-list (1- i) :initial-element 7) (list 23)) when (apply #'= args) collect args) nil) (deftest =.9 (=t 0 0.0) t) (deftest =.10 (=t 0 #c(0 0)) t) (deftest =.11 (=t 1 #c(1.0 0.0)) t) (deftest =.12 (=t -0.0 0.0) t) (deftest =.13 (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums unless (= x y) collect (list x y)))) nil) (deftest =.14 (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums unless (= x y) collect (list x y)))) nil) (deftest =.15 (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums unless (= x y) collect (list x y)))) nil) (deftest =.16 (let ((n 60000) (m 30000)) (loop for x = (- (random n) m) for y = (- (random n) m) for z = (- (random n) m) for w = (- (random n) m) for a = (* x y) for b = (* x w) for c = (* y z) for d = (* w z) repeat 10000 when (and (/= b 0) (/= d 0) (or (not (= (/ a b) (/ c d))) (/= (/ a b) (/ c d)))) collect (list a b c d))) nil) ;;; Comparison of a rational with a float (deftest =.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (= x xrat+rat/i) (list (list x i xrat+rat/i)) nil)))) nil) (deftest =.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (= x xrat-rat/i) (list (list x i xrat-rat/i)) nil)))) nil) (deftest =.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) when (and d (or (= (* 3/2 d) x) (= x (* 5/4 d)))) collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest =.order.1 (let ((i 0) x y) (values (= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2)) i x y)) nil 2 1 2) (deftest =.order.2 (let ((i 0) x y z) (values (= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3)) i x y z)) nil 3 1 2 3) (deftest =.order.3 (let ((i 0) u v w x y z) (values (= (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6)) i u v w x y z)) nil 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest /=.1 (loop for x in *numbers* unless (/= x) collect x) nil) (deftest /=.2 (loop for x in *numbers* when (/= x x) collect x) nil) (deftest /=.3 (loop for x in *numbers* when (/= x x x) collect x) nil) (deftest /=.4 (/=.4-fn) nil) (deftest /=.4a (/=.4a-fn) nil) (deftest /=.5 (loop for i from 1 to 10000 for i2 = (1+ i) always (and (/= i i2) (/= i2 i))) t) (deftest /=.6 (loop for i from 5 to 10000 by 17 for j from 2 to i by 19 for r = (/ i j) when (or (not (/= r (1+ r))) (not (/= r 0)) (not (/= r (- r))) (/= r r)) collect r) nil) (deftest /=.7 (let ((args (list 17)) (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push i args2) always (and (not (apply #'/= args)) (apply #'/= args2)))) t) (deftest /=.8 (loop for i from 2 to (min 256 (1- call-arguments-limit)) for args = (append (make-list (1- i) :initial-element 7) (list 7)) when (apply #'/= args) collect args) nil) (deftest /=.9 (/= 0 0.0) nil) (deftest /=.10 (/= 0 #c(0 0)) nil) (deftest /=.11 (/= 1 #c(1.0 0.0)) nil) (deftest /=.12 (/= -0.0 0.0) nil) (deftest /=.13 (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums when (/= x y) collect (list x y)))) nil) (deftest /=.14 (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums when (/= x y) collect (list x y)))) nil) (deftest /=.15 (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) (loop for x in nums append (loop for y in nums when (/= x y) collect (list x y)))) nil) (deftest /=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (/= x xrat+rat/i) nil (list (list x i xrat+rat/i)))))) nil) (deftest /=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (/= x xrat-rat/i) nil (list (list x i xrat-rat/i)))))) nil) (deftest /=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (/= (* 3/2 d) x) (/= x (* 5/4 d)))) collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest /=.order.1 (let ((i 0) x y) (values (notnot (/= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) (deftest /=.order.2 (let ((i 0) x y z) (values (notnot (/= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) (deftest /=.order.3 (let ((i 0) u v w x y z) (values (notnot (/= (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest <.1 (let ((a 0) (b 1)) (notnot-mv (< a b))) t) (deftest <.2 (let ((a 0) (b 0)) (notnot-mv (< a b))) nil) (deftest <.3 (let ((a 1) (b 0)) (notnot-mv (< a b))) nil) (defparameter *number-less-tests* (let* ((n (- most-positive-fixnum most-negative-fixnum)) (n2 (* 1000 n))) (nconc (loop for i = (+ (random n) most-negative-fixnum) for i2 = (+ i (random most-positive-fixnum)) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for i = (random n2) for i2 = (+ (random n2) i) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for x in *universe* when (integerp x) nconc (list (list x (1+ x) t) (list (1+ x) x nil))) (loop for x in *universe* when (realp x) collect (list x x nil)) (loop for x in *universe* when (and (realp x) (>= x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent bound)) 500)) when (<= (rational lower-bound) (rational x) (rational bound)) nconc (let* ((y (float x one)) (z (* y (- one (* 2 epsilon))))) (list (list y z nil) (list z y t))))) (loop for x in *universe* when (and (realp x) (<= x -1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational bound) (rational x) (rational upper-bound)) nconc (let* ((y (float x one))) (let ((z (* y (- one (* 2 epsilon))))) (list (list y z t) (list z y nil)))))) (loop for x in *universe* when (and (realp x) (< -1 x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational lower-bound) (rational x) (rational upper-bound)) nconc (handler-case (let* ((y (float x one)) (z1 (+ y epsilon)) (z2 (- y epsilon))) (list (list y z1 t) (list z1 y nil) (list y z2 nil) (list z2 y t))) (arithmetic-error () nil))) )))) (deftest <.4 (loop for (x y result . rest) in *number-less-tests* unless (if (< x y) result (not result)) collect (list* x y result rest)) nil) (deftest <.5 (loop for x in *universe* when (and (typep x 'real) (not (< x))) collect x) nil) (deftest <.6 (let ((args (list 17)) (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push (- i) args2) unless (and (not (apply #'< args)) (apply #'< args2)) collect (list args args2))) nil) (deftest <.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'< args))) t) ;;; Check that < is antisymmetric (deftest <.8 (<.8-fn) nil) ;;; < is symmetric with > (deftest <.9 (<.9-fn) nil) ;;; < is negation of >= (deftest <.10 (<.10-fn) nil) (deftest <.11 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) never (or (< (- x) x) (< x (- x)))) t) (deftest <.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (< x xrat+rat/i) nil (list (list x i xrat+rat/i)))))) nil) (deftest <.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (< x xrat-rat/i) (list (list x i xrat-rat/i)) nil)))) nil) (deftest <.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (< x (* 3/2 d)) (not (< (* 17/16 d) x)))) collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest <.order.1 (let ((i 0) x y) (values (notnot (< (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) (deftest <.order.2 (let ((i 0) x y z) (values (notnot (< (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) (deftest <.order.3 (let ((i 0) u v w x y z) (values (notnot (< (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest <=.1 (let ((a 0) (b 1)) (notnot-mv (<= a b))) t) (deftest <=.2 (let ((a 0) (b 0)) (notnot-mv (<= a b))) t) (deftest <=.3 (let ((a 1) (b 0)) (notnot-mv (<= a b))) nil) (defparameter *number-less-or-equal-tests* (let* ((n (- most-positive-fixnum most-negative-fixnum)) (n2 (* 1000 n))) (nconc (loop for i = (+ (random n) most-negative-fixnum) for i2 = (+ i (random most-positive-fixnum)) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for i = (random n2) for i2 = (+ (random n2) i) repeat 1000 nconc (list (list i i2 t) (list i2 i nil))) (loop for x in *universe* when (integerp x) nconc (list (list x (1+ x) t) (list (1+ x) x nil))) (loop for x in *universe* when (realp x) collect (list x x t)) (loop for x in *universe* when (and (realp x) (>= x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent bound)) 500)) when (<= (rational lower-bound) (rational x) (rational bound)) nconc (let* ((y (float x one)) (z (* y (- one (* 2 epsilon))))) (list (list y z nil) (list z y t))))) (loop for x in *universe* when (and (realp x) (<= x -1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational bound) (rational x) (rational upper-bound)) nconc (let* ((y (float x one)) (z (* y (- one (* 2 epsilon))))) (list (list y z t) (list z y nil))))) (loop for x in *universe* when (and (realp x) (< -1 x 1)) nconc (loop for epsilon in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for lower-bound in (list most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float) for upper-bound in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for one in '(1.0s0 1.0f0 1.0d0 1.0l0) when (and (<= (abs (float-exponent lower-bound)) 500) (<= (abs (float-exponent x)) 500) (<= (abs (float-exponent upper-bound)) 500)) when (<= (rational lower-bound) (rational x) (rational upper-bound)) nconc (handler-case (let* ((y (float x one)) (z1 (+ y epsilon)) (z2 (- y epsilon))) (list (list y z1 t) (list z1 y nil) (list y z2 nil) (list z2 y t))) (floating-point-underflow () nil)))) ))) (deftest <=.4 (loop for (x y result . rest) in *number-less-or-equal-tests* unless (if (<= x y) result (not result)) collect (list* x y result rest)) nil) (deftest <=.5 (loop for x in *universe* when (and (typep x 'real) (not (<= x))) collect x) nil) (deftest <=.6 (let ((args (list 17)) (args2 nil) (args3 (list 0))) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push (- i) args2) do (push i args3) unless (and (apply #'<= args) (apply #'<= args2) (not (apply #'<= args3))) collect (list args args2 args3))) nil) (deftest <=.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'<= args))) t) ;;; Check that <= is symmetric with >= (deftest <=.8 (<=.8-fn) nil) ;;; Check that <= is equivalent to (or < =) (deftest <=.9 (<=.9-fn) nil) (deftest <=.10 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) always (and (<= (- x) x) (<= x (- x)))) t) (deftest <=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (<= x xrat+rat/i) nil (list (list x i xrat+rat/i)))))) nil) (deftest <=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (<= x xrat-rat/i) (list (list x i xrat-rat/i)) nil)))) nil) (deftest <=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (<= x (* 3/2 d)) (not (<= (* 5/4 d) x)))) collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest <=.order.1 (let ((i 0) x y) (values (notnot (<= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) (deftest <=.order.2 (let ((i 0) x y z) (values (notnot (<= (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) (deftest <=.order.3 (let ((i 0) u v w x y z) (values (notnot (<= (progn (setf u (incf i)) 1) (progn (setf v (incf i)) 2) (progn (setf w (incf i)) 3) (progn (setf x (incf i)) 4) (progn (setf y (incf i)) 5) (progn (setf z (incf i)) 6))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest >.1 (let ((a 0) (b 1)) (notnot-mv (> a b))) nil) (deftest >.2 (let ((a 0) (b 0)) (notnot-mv (> a b))) nil) (deftest >.3 (let ((a 1) (b 0)) (notnot-mv (> a b))) t) (deftest >.4 (loop for (x y result . rest) in *number-less-tests* unless (if (> y x) result (not result)) collect (list* y x result rest)) nil) (deftest >.5 (loop for x in *universe* when (and (typep x 'real) (not (> x))) collect x) nil) (deftest >.6 (let ((args (list 17)) (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push i args2) unless (and (not (apply #'> args)) (apply #'> args2)) collect (list args args2))) nil) (deftest >.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'> args))) t) ;;; > is negation of <= (deftest >.8 (>.8-fn) nil) (deftest >.9 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) never (or (> (- x) x) (> x (- x)))) t) (deftest >.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (> x xrat+rat/i) (list (list x i xrat+rat/i)) nil)))) nil) (deftest >.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (> x xrat-rat/i) nil (list (list x i xrat-rat/i)))))) nil) (deftest >.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (> (* 3/2 d) x) (not (> x (* 17/16 d))))) collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest >.order.1 (let ((i 0) x y) (values (notnot (> (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 1))) i x y)) t 2 1 2) (deftest >.order.2 (let ((i 0) x y z) (values (notnot (> (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i x y z)) t 3 1 2 3) (deftest >.order.3 (let ((i 0) u v w x y z) (values (notnot (> (progn (setf u (incf i)) 6) (progn (setf v (incf i)) 5) (progn (setf w (incf i)) 4) (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest >=.1 (let ((a 0) (b 1)) (notnot-mv (>= a b))) nil) (deftest >=.2 (let ((a 0) (b 0)) (notnot-mv (>= a b))) t) (deftest >=.3 (let ((a 1) (b 0)) (notnot-mv (>= a b))) t) (deftest >=.4 (loop for (x y result . rest) in *number-less-or-equal-tests* unless (if (>= y x) result (not result)) collect (list* y x result rest)) nil) (deftest >=.5 (loop for x in *universe* when (and (typep x 'real) (not (>= x))) collect x) nil) (deftest >=.6 (let ((args (list 17)) (args2 (list 0)) (args3 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) do (push 17 args) do (push (- i) args2) do (push i args3) unless (and (apply #'>= args) (not (apply #'>= args2)) (apply #'>= args3)) collect (list args args2 args3))) nil) (deftest >=.7 (let* ((len (min 256 (1- call-arguments-limit))) (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len for args = (copy-list args-proto) do (setf (elt args i) 0) never (apply #'>= args))) t) ;;; Check that >= is equivalent to (or > =) (deftest >=.8 (>=.8-fn) nil) (deftest >=.9 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) always (and (>= (- x) x) (>= x (- x)))) t) (deftest >=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat+rat/i = (+ xrat rat/i) nconc (if (>= x xrat+rat/i) (list (list x i xrat+rat/i)) nil)))) nil) (deftest >=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) for exp = (nth-value 1 (decode-float eps)) for radix = (float-radix eps) when (< (* (log radix 2) exp) 1000) nconc (let* ((rat (rational eps)) (xrat (rational x))) (loop for i from 2 to 100 for rat/i = (/ rat i) for xrat-rat/i = (- xrat rat/i) nconc (if (>= x xrat-rat/i) nil (list (list x i xrat-rat/i)))))) nil) (deftest >=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for d = (and (<= x bound) (truncate x)) unless (or (null d) (and (>= (* 3/2 d) x) (not (>= x(* 17/16 d))))) collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest >=.order.1 (let ((i 0) x y) (values (notnot (>= (progn (setf x (incf i)) 2) (progn (setf y (incf i)) 1))) i x y)) t 2 1 2) (deftest >=.order.2 (let ((i 0) x y z) (values (notnot (>= (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i x y z)) t 3 1 2 3) (deftest >=.order.3 (let ((i 0) u v w x y z) (values (notnot (>= (progn (setf u (incf i)) 6) (progn (setf v (incf i)) 5) (progn (setf w (incf i)) 4) (progn (setf x (incf i)) 3) (progn (setf y (incf i)) 2) (progn (setf z (incf i)) 1))) i u v w x y z)) t 6 1 2 3 4 5 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Comparison of rationals (deftest compare-rationals.1 (compare-random-rationals 60000 30000 10000) nil) (deftest compare-rationals.2 (compare-random-rationals 600000 300000 10000) nil) (deftest compare-rationals.3 (compare-random-rationals 6000000 3000000 10000) nil) (deftest compare-rationals.4 (compare-random-rationals 6000000000 3000000000 10000) nil) ;;;; Comparison of bignums with floats (deftest bignum.float.compare.1a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (< x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.1b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (< i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.2a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (> i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.2b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (> x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.3a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (when (or (= x i) (= i x)) (list (list r x i)))))) nil) (deftest bignum.float.compare.3b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (when (or (= x i) (= i x)) (list (list r x i)))))) nil) (deftest bignum.float.compare.4a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (and (/= i x) (/= x i)) (list (list r x i)))))) nil) (deftest bignum.float.compare.4b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (and (/= i x) (/= x i)) (list (list r x i)))))) nil) (deftest bignum.float.compare.5a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (<= x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.5b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (<= i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.6a (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (+ r (ceiling (rational x))))) (unless (>= i x) (list (list r x i)))))) nil) (deftest bignum.float.compare.6b (loop for x in *floats* when (or (zerop x) (< (abs (log (abs x))) 10000)) nconc (loop for r = (1+ (random (ash 1 (random 32)))) repeat 200 nconc (let ((i (- (floor (rational x)) r))) (unless (>= x i) (list (list r x i)))))) nil) (deftest bignum.float.compare.7 (let ((toobig (loop for x in *reals* collect (and (> (abs x) 1.0) (> (abs (log (abs x))) 10000))))) (loop for x in *reals* for xtoobig in toobig nconc (unless xtoobig (let ((fx (floor x))) (loop for y in *reals* for ytoobig in toobig when (and (not ytoobig) (< x y) (or (not (< fx y)) (<= y fx) (not (> y fx)) (>= fx y))) collect (list x y)))))) nil) (deftest bignum.float.compare.8 (let ((toobig (loop for x in *reals* collect (and (> (abs x) 1.0) (> (abs (log (abs x))) 10000))))) (loop for x in *reals* for xtoobig in toobig nconc (unless xtoobig (let ((fx (floor x))) (loop for y in *reals* for ytoobig in toobig when (and (not ytoobig) (<= x y) (or (not (<= fx y)) (> fx y) (not (>= y fx)) (< y fx))) collect (list x y)))))) nil) ;;; More randomized comparisons (deftest bignum.short-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) (/ most-positive-short-float 2) (coerce integer-bound 'short-float)))) (loop for bound = 1.0s0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) (deftest bignum.single-float.random.compare.1 (let* ((integer-bound (ash 1 100)) (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) (/ most-positive-single-float 2) (coerce integer-bound 'single-float)))) (loop for bound = 1.0f0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) (deftest bignum.double-float.random.compare.1 (let* ((integer-bound (ash 1 100)) (upper-bound (if (< (/ most-positive-double-float 2) integer-bound) (/ most-positive-double-float 2) (coerce integer-bound 'double-float)))) (loop for bound = 1.0d0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) (deftest bignum.long-float.random.compare.1 (let* ((integer-bound (ash 1 100)) (upper-bound (if (< (/ most-positive-long-float 2) integer-bound) (/ most-positive-long-float 2) (coerce integer-bound 'long-float)))) (loop for bound = 1.0l0 then (* bound 2) while (< bound upper-bound) nconc (loop for r = (random bound) for fr = (floor r) for cr = (ceiling r) repeat 20 unless (and (<= fr r cr) (if (= r fr) (= r cr) (/= r cr)) (>= cr r fr)) collect (list r fr cr)))) nil) ;;; Rational/float comparisons (deftest rational.short-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) (/ most-positive-short-float 2) (coerce integer-bound 'short-float)))) (loop for bound = 1.0s0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) (deftest rational.single-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) (/ most-positive-single-float 2) (coerce integer-bound 'single-float)))) (loop for bound = 1.0f0 then (* bound 2) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) (deftest rational.double-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-double-float 4) integer-bound) (/ most-positive-double-float 4) (coerce integer-bound 'double-float)))) (loop for bound = 1.0d0 then (* bound 4) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) (deftest rational.long-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) (upper-bound (if (< (/ most-positive-long-float 4) integer-bound) (/ most-positive-long-float 4) (coerce integer-bound 'long-float)))) (loop for bound = 1.0d0 then (* bound 4) while (<= bound upper-bound) nconc (loop for r = (+ 1.s0 (random bound)) for fr = (floor r) for cr = (ceiling r) for m = (ash 1 (1+ (random 30))) for p = (1+ (random m)) for q = (1+ (random m)) for x = 0 repeat 50 when (<= p q) do (psetf p (1+ q) q p) do (setf x (/ p q)) unless (let ((fr/x (/ fr x)) (cr*x (* cr x))) (and (<= fr/x r cr*x) (< fr/x r cr*x) (> cr*x r fr/x) (>= cr*x r fr/x))) collect (list r p q x fr cr)))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest =.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (= (expand-in-current-env (%m 0))) (= 1 (expand-in-current-env (%m 1))) (= (expand-in-current-env (%m 2)) 2) (= (expand-in-current-env (%m 3)) (expand-in-current-env (%m 3))) (= (expand-in-current-env (%m #c(1 2))) (expand-in-current-env (%m #c(1 2)))) (= 1 (expand-in-current-env (%m 2.0))) (= (expand-in-current-env (%m 2)) 2/3) (= (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (= (expand-in-current-env (%m 0)) 0 0) (= 0 (expand-in-current-env (%m 0)) 0) (= 0 0 (expand-in-current-env (%m 0))) ))) (t t t t t nil nil nil t t t)) (deftest /=.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (/= (expand-in-current-env (%m 0))) (/= 1 (expand-in-current-env (%m 1))) (/= (expand-in-current-env (%m 2)) 2) (/= (expand-in-current-env (%m 3)) (expand-in-current-env (%m 3))) (/= (expand-in-current-env (%m #c(1 2))) (expand-in-current-env (%m #c(1 2)))) (/= 1 (expand-in-current-env (%m 2.0))) (/= (expand-in-current-env (%m 2)) 2/3) (/= (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (/= (expand-in-current-env (%m 2)) 0 1) (/= 0 (expand-in-current-env (%m 2)) 1) (/= 0 1 (expand-in-current-env (%m 2))) ))) (t nil nil nil nil t t t t t t)) (deftest <.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (< (expand-in-current-env (%m 0))) (< 0 (expand-in-current-env (%m 1))) (< (expand-in-current-env (%m 2)) 3) (< (expand-in-current-env (%m 5)) (expand-in-current-env (%m 7))) (< 3 (expand-in-current-env (%m 2.0))) (< (expand-in-current-env (%m 2)) 2/3) (< (expand-in-current-env (%m 6)) (expand-in-current-env (%m 5))) (< (expand-in-current-env (%m 1)) 2 3) (< 1 (expand-in-current-env (%m 2)) 3) (< 1 2 (expand-in-current-env (%m 3))) ))) (t t t t nil nil nil t t t)) (deftest <=.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (<= (expand-in-current-env (%m 0))) (<= 0 (expand-in-current-env (%m 1))) (<= (expand-in-current-env (%m 2)) 3) (<= (expand-in-current-env (%m 5)) (expand-in-current-env (%m 7))) (<= 3 (expand-in-current-env (%m 2.0))) (<= (expand-in-current-env (%m 2)) 2/3) (<= (expand-in-current-env (%m 6)) (expand-in-current-env (%m 5))) (<= (expand-in-current-env (%m 2)) 2 3) (<= 1 (expand-in-current-env (%m 1)) 3) (<= 1 2 (expand-in-current-env (%m 2))) ))) (t t t t nil nil nil t t t)) (deftest >.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (> (expand-in-current-env (%m 0))) (> 2 (expand-in-current-env (%m 1))) (> (expand-in-current-env (%m 4)) 3) (> (expand-in-current-env (%m 10)) (expand-in-current-env (%m 7))) (> 1 (expand-in-current-env (%m 2.0))) (> (expand-in-current-env (%m -1)) 2/3) (> (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (> (expand-in-current-env (%m 2)) 1 0) (> 2 (expand-in-current-env (%m 1)) 0) (> 2 1 (expand-in-current-env (%m 0))) ))) (t t t t nil nil nil t t t)) (deftest >=.env.1 (macrolet ((%m (z) z)) (mapcar 'notnot (list (>= (expand-in-current-env (%m 0))) (>= 2 (expand-in-current-env (%m 1))) (>= (expand-in-current-env (%m 4)) 3) (>= (expand-in-current-env (%m 7)) (expand-in-current-env (%m 7))) (>= 1 (expand-in-current-env (%m 2.0))) (>= (expand-in-current-env (%m -1)) 2/3) (>= (expand-in-current-env (%m 4)) (expand-in-current-env (%m 5))) (>= (expand-in-current-env (%m 2)) 1 1) (>= 1 (expand-in-current-env (%m 1)) 0) (>= 2 2 (expand-in-current-env (%m 0))) ))) (t t t t nil nil nil t t t)) gcl-2.7.1/ansi-tests/PaxHeaders/destructuring-bind.lsp0000644000000000000000000000013214542551762020005 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.541789399 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/destructuring-bind.lsp0000644000175000017500000001274714542551762017416 0ustar00cammcamm;-*- 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 (notnot z-p))) a b c t) (deftest destructuring-bind.7a (destructuring-bind (x y &optional (z x z-p)) '(a b) (values x y z z-p)) a b a nil) (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.12a (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.17a (destructuring-bind (&key (a 'foo) (b 'bar) c) '(:c 1) (values a b c)) foo bar 1) (deftest destructuring-bind.17c (destructuring-bind (&key (a 'foo a-p) (b a b-p) (c 'zzz c-p)) '(:c 1) (values a b c a-p b-p (notnot c-p))) foo foo 1 nil nil t) (deftest destructuring-bind.18 (destructuring-bind ((&key a b c)) '((:c 1 :b 2)) (values a b c)) nil 2 1) ;;; Test that destructuring-bind does not have a tagbody (deftest destructuring-bind.19 (block nil (tagbody (destructuring-bind (a . b) '(1 2) (go 10) 10 (return 'bad)) 10 (return 'good))) good) (deftest destructuring-bind.20 (destructuring-bind (&whole (a . b) c . d) '(1 . 2) (list a b c d)) (1 2 1 2)) (deftest destructuring-bind.21 (destructuring-bind (x &rest (y z)) '(1 2 3) (values x y z)) 1 2 3) (deftest destructuring-bind.22 (destructuring-bind (x y &key) '(1 2) (values x y)) 1 2) (deftest destructuring-bind.23 (destructuring-bind (&rest x &key) '(:allow-other-keys 1) x) (:allow-other-keys 1)) (deftest destructuring-bind.24 (destructuring-bind (&rest x &key) nil x) nil) (deftest destructuring-bind.25 (let ((x :bad)) (declare (special x)) (let ((x :good)) (destructuring-bind (y) (list x) (declare (special x)) y))) :good) (deftest destructuring-bind.26 (destructuring-bind (x) (list 1)) nil) (deftest destructuring-bind.27 (destructuring-bind (x) (list 1) (declare (optimize))) nil) (deftest destructuring-bind.28 (destructuring-bind (x) (list 1) (declare (optimize)) (declare)) nil) (deftest destructuring-bind.29 (destructuring-bind (x &aux y) '(:foo) (values x y)) :foo nil) (deftest destructuring-bind.30 (destructuring-bind (x &aux (y (list x))) '(:foo) (values x y)) :foo (:foo)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest destructuring-bind.31 (macrolet ((%m (z) z)) (destructuring-bind (a b c) (expand-in-current-env (%m '(1 2 3))) (values a b c))) 1 2 3) ;;; Error cases #| (deftest destructuring-bind.error.1 (signals-error (destructuring-bind (a b c) nil (list a b c)) program-error) t) (deftest destructuring-bind.error.2 (signals-error (destructuring-bind ((a b c)) nil (list a b c)) program-error) t) (deftest destructuring-bind.error.3 (signals-error (destructuring-bind (a b) 'x (list a b)) program-error) t) (deftest destructuring-bind.error.4 (signals-error (destructuring-bind (a . b) 'x (list a b)) program-error) t) |# ;;; (deftest destructuring-bind.error.5 ;;; (signals-error (destructuring-bind) program-error) ;;; t) ;;; ;;; (deftest destructuring-bind.error.6 ;;; (signals-error (destructuring-bind x) program-error) ;;; t) (deftest destructuring-bind.error.7 (signals-error (funcall (macro-function 'destructuring-bind)) program-error) t) (deftest destructuring-bind.error.8 (signals-error (funcall (macro-function 'destructuring-bind) '(destructuring-bind (a . b) '(1 2) nil)) program-error) t) (deftest destructuring-bind.error.9 (signals-error (funcall (macro-function 'destructuring-bind) '(destructuring-bind (a . b) '(1 2) nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/doit.lsp0000644000000000000000000000013214542551762015130 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.541789399 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/doit.lsp0000644000175000017500000000262114542551762014527 0ustar00cammcamm;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (setq *enclose-printer-errors* nil) ;;; Remove compiled files (let* ((fn (compile-file-pathname "doit.lsp")) (type (pathname-type fn)) (dir-pathname (make-pathname :name :wild :type type)) (files (directory dir-pathname))) (assert type) (assert (not (string-equal type "lsp"))) (mapc #'delete-file files)) (load "gclload1.lsp") (load "gclload2.lsp") #+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) #+lispworks (progn (rtest:disable-note :allow-nil-arrays) (rtest:disable-note :nil-vectors-are-strings)) ;#+gcl(si::use-fast-links nil) (in-package :cl-test) ;;; These two tests will misbehave if the tests are being ;;; invoked from a file that is being loaded, so remove them (when *load-pathname* (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) (time (regression-test:do-tests)) #+allegro (cl-user::exit) #+(or cmu sbcl gcl armedbear) (cl-user::quit) gcl-2.7.1/ansi-tests/PaxHeaders/cons.lsp0000644000000000000000000000013214542551762015133 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.545789417 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons.lsp0000644000175000017500000000203414542551762014530 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:24:25 2003 ;;;; Contains: Tests for CONS (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;;; 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) (def-fold-test cons.fold.1 (cons 'a 'b)) ;;; Error tests (deftest cons.error.1 (signals-error (cons) program-error) t) (deftest cons.error.2 (signals-error (cons 'a) program-error) t) (deftest cons.error.3 (signals-error (cons 'a 'b 'c) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-slash.lsp0000644000000000000000000000013214542551762016571 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.545789417 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-slash.lsp0000644000175000017500000000775414542551762016204 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 21 09:51:08 2004 ;;;; Contains: Tests for format directive ~/.../ (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test format./.1 (format nil "~/pprint-linear/" 1) "1") (def-pprint-test format./.2 (format nil "~/pprint-linear/" 2) "2" :pretty nil) (def-pprint-test format./.3 (format nil "~/pprint-linear/" '(17)) "17") (def-pprint-test format./.4 (format nil "~:/pprint-linear/" '(17)) "(17)") (def-pprint-test format./.5 (format nil "~@/pprint-linear/" 1) "1") (def-pprint-test format./.6 (format nil "~@:/pprint-linear/" 1) "1") (def-pprint-test format./.7 (format nil "~/PPRINT-LINEAR/" 1) "1") (def-pprint-test format./.8 (format nil "~/pPrINt-lINeaR/" 1) "1") (def-pprint-test format./.9 (progn (setf (symbol-function 'FUNCTION-FOR-FORMAT-SLASH-9) #'pprint-linear) (format nil "~/CL-TEST::FUNCTION-FOR-FORMAT-SLASH-9/" 1)) "1") ;;; Single : doesn't mean it has to be exported (def-pprint-test format./.10 (progn (setf (symbol-function 'FUNCTION-FOR-FORMAT-SLASH-10) #'pprint-linear) (format nil "~/cl-test:FUNCTION-FOR-FORMAT-SLASH-10/" 1)) "1") (def-pprint-test format./.11 (progn (setf (symbol-function '|FUNCTION:FOR::FORMAT:SLASH:11|) #'pprint-linear) (format nil "~/cL-tESt:FUNCTION:FOR::FORMAT:SLASH:11/" 1)) "1") (def-pprint-test format./.12 (format nil "~<~/pprint-tabular/~:>" '((|M|))) "M") (def-pprint-test format./.13 (format nil "~<~:/pprint-tabular/~:>" '((|M|))) "(M)") (def-pprint-test format./.14 (format nil "~<~:@/pprint-tabular/~:>" '((|M|))) "(M)") (def-pprint-test format./.15 (format nil "~<~@/pprint-tabular/~:>" '((|M|))) "M") (def-pprint-test format./.16 (format nil "~<~4:/pprint-tabular/~:>" '((|M| |M|))) "(M M)") (def-pprint-test format./.17 (format nil "~<~v:/pprint-tabular/~:>" '(nil (|M| |M|))) "(M M)") (def-pprint-test format./.18 (format nil "~<~v:/pprint-tabular/~:>" '(3 (|M| |M|))) "(M M)") (declaim (special *expected-args*)) (def-pprint-test format./.19 (progn (setf (symbol-function 'function-for-format-slash-19) #'(lambda (stream &rest args) (assert (= (length args) (length *expected-args*))) (assert (equal (car args) (car *expected-args*))) (assert (if (cadr args) (cadr *expected-args*) (not (cadr *expected-args*)))) (assert (if (caddr args) (caddr *expected-args*) (not (caddr *expected-args*)))) (apply #'pprint-fill stream (subseq args 0 3)))) (list (let ((*expected-args* '(1 nil nil))) (format nil "~/cl-test::function-for-format-slash-19/" 1)) (let ((*expected-args* '(2 t nil))) (format nil "~:/cl-test::function-for-format-slash-19/" 2)) (let ((*expected-args* '(3 nil t))) (format nil "~@/cl-test::function-for-format-slash-19/" 3)) (let ((*expected-args* '(4 t t))) (format nil "~:@/cl-test::function-for-format-slash-19/" 4)) (let ((*expected-args* '(5 t t))) (format nil "~@:/cl-test::function-for-format-slash-19/" 5)) (let ((*expected-args* '(6 t t 18))) (format nil "~18@:/cl-test::function-for-format-slash-19/" 6)) (let ((*expected-args* '(7 nil nil 19))) (format nil "~v/cl-test::function-for-format-slash-19/" 19 7)) (let ((*expected-args* '(8 t nil #\X))) (format nil "~'X:/cl-test::function-for-format-slash-19/" 8)) (let ((*expected-args* '(9 nil t #\,))) (format nil "~',@/cl-test::function-for-format-slash-19/" 9)) (let ((*expected-args* '(10 nil t -1))) (format nil "~-1@/cl-test::function-for-format-slash-19/" 10)) (let ((*expected-args* '(11 nil t 1 2 3 4 5 6 7 8 9 10))) (format nil "~1,2,3,4,5,6,7,8,9,10@/cl-test::function-for-format-slash-19/" 11)) (let ((*expected-args* '(12 nil t 1 2 3 4 5 6 7 8 9 10))) (format nil "~v,v,v,v,v,v,v,v,v,v@/cl-test::function-for-format-slash-19/" 1 2 3 4 5 6 7 8 9 10 12)) )) ("1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12")) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-20.lsp0000644000000000000000000000013214542551762016327 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.545789417 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-20.lsp0000644000175000017500000002250214542551762015726 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/macro-function.lsp0000644000000000000000000000013214733440600017103 xustar0030 mtime=1735278976.990649923 30 atime=1744294960.545789417 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/macro-function.lsp0000644000175000017500000000632014733440600016502 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 3 22:17:34 2005 ;;;; Contains: Tests of MACRO-FUNCTION (in-package :cl-test) (deftest macro-function.1 (loop for n in *cl-macro-symbols* unless (macro-function n) collect n) nil) (deftest macro-function.2 (loop for n in *cl-macro-symbols* unless (macro-function n nil) collect n) nil) (deftest macro-function.3 (loop for n in *cl-macro-symbols* unless (eval `(macrolet ((%m (s &environment env) (list 'quote (macro-function s env)))) (%m ,n))) collect n) nil) (deftest macro-function.4 (macro-function (gensym)) nil) (deftest macro-function.5 (remove-if-not #'macro-function *cl-function-symbols*) nil) (deftest macro-function.6 (remove-if-not #'macro-function *cl-accessor-symbols*) nil) (deftest macro-function.7 (let ((fn (macrolet ((%m () 16)) (macrolet ((%n (&environment env) (list 'quote (macro-function '%m env)))) (%n))))) (values (notnot (functionp fn)) (funcall fn '(%m) nil))) t 16) (deftest macro-function.8 (let ((sym (gensym))) (setf (macro-function sym) (macro-function 'pop)) (eval `(let ((x '(a b c))) (values (,sym x) x)))) a (b c)) (deftest macro-function.9 (let ((sym (gensym))) (setf (macro-function sym nil) (macro-function 'pop)) (eval `(let ((x '(a b c))) (values (,sym x) x)))) a (b c)) (deftest macro-function.10 (let ((sym (gensym))) (eval `(defun ,sym (x) :bad)) (setf (macro-function sym) (macro-function 'pop)) (eval `(let ((x '(a b c))) (values (,sym x) x)))) a (b c)) (deftest macro-function.11 (let ((fn (flet ((%m () 16)) (macrolet ((%n (&environment env) (list 'quote (macro-function '%m env)))) (%n))))) fn) nil) (deftest macro-function.12 (let ((sym (gensym))) (eval `(defmacro ,sym () t)) (let ((i 0)) (values (funcall (macro-function (progn (incf i) sym)) (list sym) nil) i))) t 1) (deftest macro-function.13 (let ((sym (gensym))) (eval `(defmacro ,sym () t)) (let ((i 0) a b) (values (funcall (macro-function (progn (setf a (incf i)) sym) (progn (setf b (incf i)) nil)) (list sym) nil) i a b))) t 2 1 2) (deftest macro-function.14 (let ((sym (gensym)) (i 0)) (setf (macro-function (progn (incf i) sym)) (macro-function 'pop)) (values (eval `(let ((x '(a b c))) (list (,sym x) x))) i)) (a (b c)) 1) (deftest macro-function.15 (let ((sym (gensym)) (i 0) a b) (setf (macro-function (progn (setf a (incf i)) sym) (progn (setf b (incf i)) nil)) (macro-function 'pop)) (values (eval `(let ((x '(a b c))) (list (,sym x) x))) i a b)) (a (b c)) 2 1 2) (deftest macro-function.16 (progn (defmacro f nil nil) (prog1 (macrolet ((m (&environment env) (macro-function 'f env))) (macrolet ((f nil nil)) (flet ((f nil nil)) (m)))) (fmakunbound 'f))) nil) ;;; Error tests (deftest macro-function.error.1 (signals-error (macro-function) program-error) t) (deftest macro-function.error.2 (signals-error (macro-function 'pop nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/hash-table-size.lsp0000644000000000000000000000013114542551762017150 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.545789417 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table-size.lsp0000644000175000017500000000070414542551762016550 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:23:45 2003 ;;;; Contains: Tests for HASH-TABLE-SIZE (in-package :cl-test) (deftest hash-table-size.error.1 (signals-error (hash-table-size) program-error) t) (deftest hash-table-size.error.2 (signals-error (hash-table-size (make-hash-table) nil) program-error) t) (deftest hash-table-size.error.3 (check-type-error #'hash-table-size #'hash-table-p) nil) gcl-2.7.1/ansi-tests/PaxHeaders/readtablep.lsp0000644000000000000000000000013114542551763016274 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.545789417 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/readtablep.lsp0000644000175000017500000000307514542551763015700 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 19:19:42 2005 ;;;; Contains: Tests of READTABLEP (in-package :cl-test) (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 readtablep.2 (check-type-predicate #'readtablep 'readtable) nil) (deftest readtablep.3 (notnot-mv (readtablep *readtable*)) t) (deftest readtablep.4 (notnot-mv (readtablep (copy-readtable))) t) ;;; Error tests (deftest readtablep.error.1 (signals-error (readtablep) program-error) t) (deftest readtablep.error.2 (signals-error (readtablep *readtable* nil) program-error) t) (deftest readtablep.error.3 (signals-error (readtablep *readtable* nil t t t t) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/copy-alist.lsp0000644000000000000000000000013214542551762016255 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.545789417 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/copy-alist.lsp0000644000175000017500000000221614542551762015654 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:29:07 2003 ;;;; Contains: Tests of COPY-ALIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (eqlt (car p1) (car p2)) (eqlt (cdr p1) (cdr p2))))) x result) t)) t) (def-fold-test copy-alist.2 (copy-alist '((a . b) nil (c . d)))) (def-fold-test copy-alist.3 (car (copy-alist '((a . b) nil (c . d))))) (def-fold-test copy-alist.4 (caddr (copy-alist '((a . b) nil (c . d))))) ;;; Error tests (deftest copy-alist.error.1 (signals-error (copy-alist) program-error) t) (deftest copy-alist.error.2 (signals-error (copy-alist nil nil) program-error) t) (deftest copy-alist.error.3 (signals-error (copy-alist '((a . b) . c)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/force-output.lsp0000644000000000000000000000013214542551762016625 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.545789417 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/force-output.lsp0000644000175000017500000000224314542551762016224 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cons-test-08.lsp0000644000000000000000000000013214542551762016335 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.545789417 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-08.lsp0000644000175000017500000002037214542551762015737 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/array-aux.lsp0000644000000000000000000000013214542551762016102 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.545789417 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-aux.lsp0000644000175000017500000001516114542551762015504 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/notany.lsp0000644000000000000000000000013114542551763015501 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.549789434 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/notany.lsp0000644000175000017500000001676614542551763015120 0ustar00cammcamm;-*- 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) ;;; Other specialized sequences (deftest notany.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'plusp v)))) (nil nil nil nil nil t t t t t)) (deftest notany.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) collect (mod j (ash 1 i))) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'plusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest notany.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'minusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest notany.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest notany.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (not (notany #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest notany.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (notnot (notany #'digit-char-p v)) (setf (aref v 2) #\0) (notany #'digit-char-p v))) t #\0 nil) (deftest notany.23 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) when (notany #'zerop v) collect (list type v)) nil) (deftest notany.24 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :fill-pointer 6 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) unless (notany #'zerop v) collect (list type v)) nil) (deftest notany.25 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) unless (notany (complement #'complexp) v) collect (list type v)) nil) ;;; Displaced vectors (deftest notany.26 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (notany #'oddp v1) (notnot (notany #'oddp v2)))) nil t) (deftest notany.27 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (notany 'oddp v1)) (notany #'oddp v2))) collect i) nil) (deftest notany.28 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (not (notany 'oddp v1)) (notany #'oddp v2))) collect i) nil) (deftest notany.29 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (not (notany 'digit-char-p s2)))) (t t nil nil t t t)) (deftest notany.30 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (not (notany 'digit-char-p s2)))) (t t nil nil t t t)) (deftest notany.31 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (notnot (notany #'minusp v)) (progn (adjust-array v '(11) :initial-element -1) (notany #'minusp v)))) t nil) (deftest notany.32 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (notnot (notany #'minusp v)) (progn (adjust-array v '(11) :initial-element -1) (notnot (notany #'minusp v))))) t t) (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 (check-type-error #'(lambda (x) (notany x '(a b c))) (typef '(or symbol function))) nil) (deftest notany.error.4 (check-type-error #'(lambda (x) (notany #'null x)) #'sequencep) nil) (deftest notany.error.7 (check-type-error #'(lambda (x) (notany #'eql () x)) #'sequencep) nil) (deftest notany.error.8 (signals-error (notany) program-error) t) (deftest notany.error.9 (signals-error (notany #'null) program-error) t) (deftest notany.error.10 (signals-error (locally (notany 1 '(a b c)) t) type-error) t) (deftest notany.error.11 (signals-error (notany #'cons '(a b c)) program-error) t) (deftest notany.error.12 (signals-error (notany #'cons '(a b c) '(1 2 4) '(g h j)) program-error) t) (deftest notany.error.13 (signals-error (notany #'car '(a b c)) type-error) t)gcl-2.7.1/ansi-tests/PaxHeaders/gcd.lsp0000644000000000000000000000013114542551762014725 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.549789434 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/gcd.lsp0000644000175000017500000000372614542551762014334 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 3 06:51:03 2003 ;;;; Contains: Tests of GCD (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "gcd-aux.lsp") ;;; Error tests (deftest gcd.error.1 (check-type-error #'gcd #'integerp) nil) ;;; Non-error tests (deftest gcd.1 (gcd) 0) (deftest gcd.2 (loop for i = (random-fixnum) for a = (abs i) repeat 10000 unless (and (eql a (gcd i)) (eql a (gcd 0 i))) collect i) nil) (deftest gcd.3 (loop for i = (random-from-interval 10000000000000000) for a = (abs i) repeat 10000 unless (and (eql a (gcd i)) (eql a (gcd i 0))) collect i) nil) (deftest gcd.4 (loop for i = (random-fixnum) for j = (random-fixnum) repeat 1000 unless (eql (my-gcd i j) (gcd i j)) collect (list i j)) nil) (deftest gcd.5 (let ((bound (ash 1 200))) (loop for i = (random-from-interval bound) for j = (random-from-interval bound) repeat 1000 unless (eql (my-gcd i j) (gcd i j)) collect (list i j))) nil) (deftest gcd.6 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) repeat 1000 unless (eql (my-gcd i (my-gcd j k)) (gcd i j k)) collect (list i j k)) nil) (deftest gcd.7 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) for n = (random-fixnum) repeat 1000 unless (eql (my-gcd (my-gcd i j) (my-gcd k n)) (gcd i j k n)) collect (list i j k)) nil) (deftest gcd.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) always (eql (apply #'gcd (make-list i :initial-element 1)) 1)) t) (deftest gcd.order.1 (let ((i 0) x y) (values (gcd (progn (setf x (incf i)) 15) (progn (setf y (incf i)) 25)) i x y)) 5 2 1 2) (deftest gcd.order.2 (let ((i 0) x y) (values (gcd (progn (setf x (incf i)) 0) (progn (setf y (incf i)) 10)) i x y)) 10 2 1 2) (deftest gcd.order.3 (let ((i 0)) (values (gcd (progn (incf i) 0)) i)) 0 1) gcl-2.7.1/ansi-tests/PaxHeaders/types-aux.lsp0000644000000000000000000000013114542551763016130 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.549789434 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/types-aux.lsp0000644000175000017500000001372414542551763015536 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 21 20:14:38 2004 ;;;; Contains: Aux. functions for types tests (in-package :cl-test) (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) (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 occured: ~S~%" c tp2) t))))) (condition (c) (format t "Error ~S occured: ~S~%" c tp) 1)))))))) (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) :==> ,sub ,valid)) nil))) ;;; 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 subtypep-and-contrapositive-are-consistent (t1 t2) (multiple-value-bind (sub1 success1) (subtypep* t1 t2) (multiple-value-bind (sub2 success2) (subtypep* `(not ,t2) `(not ,t1)) (or (not success1) (not success2) (eqlt sub1 sub2))))) ;;; For use in deftype tests (deftype even-array (&optional type size) `(and (array ,type ,size) (satisfies even-size-p))) gcl-2.7.1/ansi-tests/PaxHeaders/endp.lsp0000644000000000000000000000013214542551762015117 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.549789434 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/endp.lsp0000644000175000017500000000131414542551762014514 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:34:40 1998 ;;;; Contains: Tests of ENDP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.error.1 (check-type-error #'endp #'listp) nil) (deftest endp.error.4 (signals-error (endp) program-error) t) (deftest endp.error.5 (signals-error (endp nil nil) program-error) t) (deftest endp.error.6 (signals-error (locally (endp 1)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/package-shadowing-symbols.lsp0000644000000000000000000000013114542551763021233 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.549789434 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-shadowing-symbols.lsp0000644000175000017500000000405214542551763020633 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:55:17 2004 ;;;; Contains: Tests of PACKAGE-SHADOWING-SYMBOLS (in-package :cl-test) ;;; Most tests of this function are in files for other package-related operators ;;; Specialized sequence tests (defmacro def-package-shadowing-symbols-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-shadowing-symbols p))) nil)) (def-package-shadowing-symbols-test package-shadowing-symbols.1 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.2 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-shadowing-symbols-test package-shadowing-symbols.3 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-shadowing-symbols-test package-shadowing-symbols.4 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.5 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.6 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-shadowing-symbols-test package-shadowing-symbols.7 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-shadowing-symbols.error.1 (signals-error (package-shadowing-symbols) program-error) t) (deftest package-shadowing-symbols.error.2 (signals-error (package-shadowing-symbols "CL" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/translate-logical-pathname.lsp0000644000000000000000000000013114542551763021371 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.549789434 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/translate-logical-pathname.lsp0000644000175000017500000000226714542551763020777 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/loop11.lsp0000644000000000000000000000013214542551763015305 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.549789434 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop11.lsp0000644000175000017500000000757414542551763014720 0ustar00cammcamm;-*- 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)) ;;; Enough implementors have complained about this test that ;;; I'm removing it. The standard is self-contradictory ;;; on whether REPEAT can occur later in a LOOP form. ;;; (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) ;;; More tests of a bug that showed up in c.l.l (deftest loop.11.29 (loop for i in '(4 8 9 A 13) when (eq i 'a) return :good while (< i 12) collect i) :good) (deftest loop.11.30 (loop for i in '(4 8 9 A 13) unless (numberp i) return :good while (< i 12) collect i) :good) (deftest loop.11.31 (loop for i in '(4 8 9 A 13) when (eq i 'a) return :good until (> i 12) collect i) :good) (deftest loop.11.32 (loop for i in '(4 8 9 A 13) unless (numberp i) return :good until (> i 12) collect i) :good) (deftest loop.11.33 (loop for i in '(4 8 9 A 13) if (not (numberp i)) return :good end while (< i 12) collect i) :good) (deftest loop.11.34 (loop for i in '(4 8 9 A 13) if (not (numberp i)) return :good end until (> i 12) collect i) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.11.35 (macrolet ((%m (z) z)) (loop repeat (expand-in-current-env (%m 5)) collect 'x)) (x x x x x)) gcl-2.7.1/ansi-tests/PaxHeaders/printer-aux.lsp0000644000000000000000000000013114542551763016447 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.549789434 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/printer-aux.lsp0000644000175000017500000004022414542551763016050 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 06:20:00 2004 ;;;; Contains: Auxiliary functions and macros for printer tests (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) (defmacro def-print-test (name form result &rest bindings) `(deftest ,name (if (equalpt (my-with-standard-io-syntax (let ((*print-readably* nil)) (let ,bindings (with-output-to-string (*standard-output*) (prin1 ,form))))) ,result) t ,result) t)) (defmacro def-pprint-test (name form expected-value &key (margin 100) (miser nil) (circle nil) (len nil) (pretty t) (escape nil) (readably nil) (package (find-package "CL-TEST"))) `(deftest ,name (with-standard-io-syntax (let ((*print-pretty* ,pretty) (*print-escape* ,escape) (*print-readably* ,readably) (*print-right-margin* ,margin) (*package* ,package) (*print-length* ,len) (*print-miser-width* ,miser) (*print-circle* ,circle)) ,form)) ,expected-value)) (defmacro def-ppblock-test (name form expected-value &rest key-args) `(def-pprint-test ,name (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) ,form)) ,expected-value ,@key-args)) ;;; Function to test readable of printed forms, under random settings ;;; of various printer control variables. ;;; ;;; Return NIL if obj printed and read properly, or a list containing ;;; the object and the printer variable bindings otherwise. They key ;;; argument TEST is used to compared the reread object and obj. (defvar *random-read-check-debug* nil "When set to true, RANDOMLY-CHECK-READABILITY will dump out parameter settings before trying a test. This is intended for cases where the error that occurs is fatal.") (defun randomly-check-readability (obj &key (can-fail nil) (test #'equal) (readable t) (circle nil circle-p) (escape nil escape-p) (gensym nil gensym-p) (debug *random-read-check-debug*)) (declare (type function test)) ;; Generate random printer-control values (my-with-standard-io-syntax (let ((*print-array* (coin)) (*print-base* (+ 2 (random 34))) (*print-radix* (coin)) (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) (*print-circle* (if circle-p circle (coin))) (*print-escape* (if escape-p escape (coin))) (*print-gensym* (if gensym-p gensym (coin))) (*print-level* (random 50)) (*print-length* (if readable (random 50) nil)) (*print-lines* (if readable (random 50) nil)) (*print-miser-width* (and (coin) (random 100))) (*print-pretty* (coin)) (*print-right-margin* (and (coin) (random 100))) (*print-readably* readable) (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) (1 'double-float) (1 'long-float) (1 *read-default-float-format*))) (*readtable* (copy-readtable)) (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) ) (flet ((%params () (list (list '*print-readably* *print-readably*) (list '*print-array* *print-array*) (list '*print-base* *print-base*) (list '*print-radix* *print-radix*) (list '*print-case* *print-case*) (list '*print-circle* *print-circle*) (list '*print-escape* *print-escape*) (list '*print-gensym* *print-gensym*) (list '*print-level* *print-level*) (list '*print-length* *print-length*) (list '*print-lines* *print-lines*) (list '*print-miser-width* *print-miser-width*) (list '*print-pretty* *print-pretty*) (list '*print-right-margin* *print-right-margin*) (list '*read-default-float-format* *read-default-float-format*) (list 'readtable-case readcase)))) (when debug (let ((params (%params))) (with-standard-io-syntax (format *debug-io* "~%~A~%" params))) (finish-output *debug-io*)) (setf (readtable-case *readtable*) readcase) (let* ((str (handler-case (with-output-to-string (s) (write obj :stream s)) (print-not-readable () (if can-fail (return-from randomly-check-readability nil) ":print-not-readable-error")))) (obj2 (let ((*read-base* *print-base*)) (handler-case (let ((*readtable* (if *print-readably* (copy-readtable nil) *readtable*))) (read-from-string str)) (reader-error () :reader-error) (end-of-file () :end-of-file) (stream-error () :stream-error) (file-error () :file-error) )))) (unless (funcall test obj obj2) (list (list* obj str obj2 (%params) )))))))) (defun parse-escaped-string (string) "Parse a string into a list of either characters (representing themselves unescaped) or lists ( :escape) (representing escaped characters.)" (assert (stringp string) () "Not a string: ~A" string) (let ((result nil) (len (length string)) (index 0)) (prog () normal ; parsing in normal mode (when (= index len) (return)) (let ((c (elt string index))) (cond ((eql c #\\) (assert (< (incf index) len) () "End of string after \\") (push `(,(elt string index) :escaped) result) (incf index) (go normal)) ((eql c #\|) (incf index) (go multiple-escaped)) (t (push c result) (incf index) (go normal)))) multiple-escaped ; parsing inside |s (assert (< index len) () "End of string inside |") (let ((c (elt string index))) (cond ((eq c #\|) (incf index) (go normal)) (t (push `(,c :escaped) result) (incf index) (go multiple-escaped))))) (nreverse result))) (defun escaped-equal (list1 list2) "Determine that everything escaped in list1 is also escaped in list2, and that the characters are also the same." (and (= (length list1) (length list2)) (loop for e1 in list1 for e2 in list2 for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped)) for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped)) for c1 = (if is-escaped1 (car e1) e1) for c2 = (if is-escaped2 (car e2) e2) always (and (if is-escaped1 is-escaped2 t) (char= c1 c2))))) (defun similar-uninterned-symbols (s1 s2) (and (symbolp s1) (symbolp s2) (null (symbol-package s1)) (null (symbol-package s2)) (string= (symbol-name s1) (symbol-name s2)))) (defun make-random-cons-tree (size) (if (<= size 1) (rcase (5 nil) (1 (random 1000)) (1 (random 1000.0)) (2 (random-from-seq #(a b c d e f g |1| |2| |.|)))) (let ((s1 (1+ (random (1- size))))) (cons (make-random-cons-tree s1) (make-random-cons-tree (- size s1)))))) (defun make-random-vector (size) (if (> size 1) (let* ((nelems (min (1- size) (1+ (random (max 2 (floor size 4)))))) (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems)))) (make-array nelems :initial-contents (mapcar #'make-random-vector sizes))) (rcase (1 (random-from-seq #(a b c d e f g))) (1 (- (random 2001) 1000)) (1 (random 1000.0)) ))) ;;; Random printing test for WRITE and related functions (defun funcall-with-print-bindings (fun &key ((:array *print-array*) *print-array*) ((:base *print-base*) *print-base*) ((:case *print-case*) *print-case*) ((:circle *print-circle*) *print-circle*) ((:escape *print-escape*) *print-escape*) ((:gensym *print-gensym*) *print-gensym*) ((:length *print-length*) *print-length*) ((:level *print-level*) *print-level*) ((:lines *print-lines*) *print-lines*) ((:miser-width *print-miser-width*) *print-miser-width*) ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*) ((:pretty *print-pretty*) *print-pretty*) ((:radix *print-radix*) *print-radix*) ((:readably *print-readably*) *print-readably*) ((:right-margin *print-right-margin*) *print-right-margin*) ((:stream *standard-output*) *standard-output*)) (funcall fun)) (defun output-test (obj &key (fun #'write) ((:array *print-array*) *print-array*) ((:base *print-base*) *print-base*) ((:case *print-case*) *print-case*) ((:circle *print-circle*) *print-circle*) ((:escape *print-escape*) *print-escape*) ((:gensym *print-gensym*) *print-gensym*) ((:length *print-length*) *print-length*) ((:level *print-level*) *print-level*) ((:lines *print-lines*) *print-lines*) ((:miser-width *print-miser-width*) *print-miser-width*) ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*) ((:pretty *print-pretty*) *print-pretty*) ((:radix *print-radix*) *print-radix*) ((:readably *print-readably*) *print-readably*) ((:right-margin *print-right-margin*) *print-right-margin*) ((:stream *standard-output*) *standard-output*)) (let ((results (multiple-value-list (funcall fun obj)))) (assert (= (length results) 1)) (assert (eql (car results) obj)) obj)) (defun make-random-key-param (name) (rcase (1 nil) (1 `(,name nil)) (1 `(,name t)))) (defun make-random-key-integer-or-nil-param (name bound) (rcase (1 nil) (1 `(,name nil)) (1 `(,name ,(random bound))))) (defun make-random-write-args () (let* ((arg-lists `(,@(mapcar #'make-random-key-param '(:array :circle :escape :gensym :pretty :radix :readably)) ,(rcase (1 nil) (1 `(:base ,(+ 2 (random 35))))) ,(and (coin) `(:case ,(random-from-seq #(:upcase :downcase :capitalize)))) ,@(mapcar #'make-random-key-integer-or-nil-param '(:length :level :lines :miser-width :right-margin) '(100 20 50 200 200))))) (reduce #'append (random-permute arg-lists) :from-end t))) (defun filter-unreadable-forms (string) "Find #<...> strings and replace with #<>." (let ((len (length string)) (pos 0)) (loop while (< pos len) do (let ((next (search "#<" string :start2 pos))) (unless next (return string)) (let ((end (position #\> string :start next))) (unless end (return string)) (setq string (concatenate 'string (subseq string 0 next) "#<>" (subseq string (1+ end))) pos (+ next 3) len (+ len (- next end) 3))))))) (defmacro def-random-write-test-fun (name write-args test-fn &key (prefix "") (suffix "")) `(defun ,name (n &key (size 10)) (loop for args = (make-random-write-args) for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) for obj = (let ((*random-readable* t)) (declare (special *random-readable*)) (random-thing (random size))) for s1 = (let ((*package* package)) (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) for s2 = (let ((*package* package)) (with-output-to-string (*standard-output*) (apply #'output-test obj :fun ,test-fn args))) repeat n ;; We filter the contents of #<...> forms since they may change with time ;; if they contain object addresses. unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) (filter-unreadable-forms s2)) collect (list obj s1 s2 args)))) (def-random-write-test-fun random-write-test nil #'write) (def-random-write-test-fun random-prin1-test (:escape t) #'prin1) (def-random-write-test-fun random-princ-test (:escape nil :readably nil) #'princ) (def-random-write-test-fun random-print-test (:escape t) #'print :prefix (string #\Newline) :suffix " ") (def-random-write-test-fun random-pprint-test (:escape t :pretty t) #'(lambda (obj) (assert (null (multiple-value-list (pprint obj)))) obj) :prefix (string #\Newline)) (defmacro def-random-write-to-string-test-fun (name write-args test-fn &key (prefix "") (suffix "")) `(defun ,name (n) (loop for args = (make-random-write-args) for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) for obj = (let ((*random-readable* t)) (declare (special *random-readable*)) (random-thing (random 10))) for s1 = (let ((*package* package)) (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) for s2 = (let ((*package* package)) (apply ,test-fn obj args)) repeat n unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) (filter-unreadable-forms s2)) collect (list obj s1 s2)))) (def-random-write-to-string-test-fun random-write-to-string-test nil #'write-to-string) (def-random-write-to-string-test-fun random-prin1-to-string-test (:escape t) #'(lambda (obj &rest args) (apply #'funcall-with-print-bindings #'(lambda () (prin1-to-string obj)) args))) (def-random-write-to-string-test-fun random-princ-to-string-test (:escape nil :readably nil) #'(lambda (obj &rest args) (apply #'funcall-with-print-bindings #'(lambda () (princ-to-string obj)) args))) ;;; Routines for testing floating point printing (defun decode-fixed-decimal-string (s) "Return a rational equal to the number represented by a decimal floating (without exponent). Trim off leading/trailing spaces." (setq s (string-trim " " s)) (assert (> (length s) 0)) (let (neg) (when (eql (elt s 0) #\-) (setq s (subseq s 1)) (setq neg t)) ;; Check it's of the form {digits}.{digits} (let ((dot-pos (position #\. s))) (assert dot-pos) (let ((prefix (subseq s 0 dot-pos)) (suffix (subseq s (1+ dot-pos)))) (assert (every #'digit-char-p prefix)) (assert (every #'digit-char-p suffix)) (let* ((prefix-len (length prefix)) (prefix-integer (if (eql prefix-len 0) 0 (parse-integer prefix))) (suffix-len (length suffix)) (suffix-integer (if (eql suffix-len 0) 0 (parse-integer suffix))) (magnitude (+ prefix-integer (* suffix-integer (expt 1/10 suffix-len))))) (if neg (- magnitude) magnitude)))))) ;;; Macro to define both FORMAT and FORMATTER tests (defmacro def-format-test (name string args expected-output &optional (num-left 0)) (assert (symbolp name)) (let* ((s (symbol-name name)) (expected-prefix (string 'format.)) (expected-prefix-length (length expected-prefix))) (assert (>= (length s) expected-prefix-length)) (assert (string-equal (subseq s 0 expected-prefix-length) expected-prefix)) (let* ((formatter-test-name-string (concatenate 'string (string 'formatter.) (subseq s expected-prefix-length))) (formatter-test-name (intern formatter-test-name-string (symbol-package name))) (formatter-form (if (stringp string) `(formatter ,string) (list 'formatter (eval string))))) `(progn (deftest ,name (with-standard-io-syntax (let ((*print-readably* nil) (*package* (symbol-package 'ABC))) (format nil ,string ,@args))) ,expected-output) (deftest ,formatter-test-name (let ((fn ,formatter-form) (args (list ,@args))) (with-standard-io-syntax (let ((*print-readably* nil) (*package* (symbol-package 'ABC))) (with-output-to-string (stream) (let ((tail (apply fn stream args))) ;; FIXME -- Need to check that TAIL really is a tail of ARGS (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A" tail ,num-left) ))))) ,expected-output))))) ;;; Macro used for an idiom in testing FORMATTER calls (defmacro formatter-call-to-string (fn &body args) (let ((stream (gensym "S"))) `(with-output-to-string (,stream) (assert (equal (funcall ,fn ,stream ,@args 'a) '(a)))))) gcl-2.7.1/ansi-tests/PaxHeaders/compile-file-test-file-3.lsp0000644000000000000000000000013014542551762020566 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.549789434 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-file-test-file-3.lsp0000644000175000017500000000004714542551762020167 0ustar00cammcamm(defun compile-file-test-fun.3 () nil) gcl-2.7.1/ansi-tests/PaxHeaders/eval-when.lsp0000644000000000000000000000013214542551762016057 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.549789434 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/eval-when.lsp0000644000175000017500000000735614542551762015470 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 6 17:00:30 2003 ;;;; Contains: Tests for EVAL-WHEN ;;; The following test was suggested by Sam Steingold, ;;; so I've created this file to hold it. (in-package :cl-test) (defvar *eval-when.1-collector*) (deftest eval-when.1 (let ((forms nil) all (ff "generated-eval-when-test-file.lisp")) (dolist (c '(nil (:compile-toplevel))) (dolist (l '(nil (:load-toplevel))) (dolist (x '(nil (:execute))) (push `(eval-when (,@c ,@l ,@x) (push '(,@c ,@l ,@x) *eval-when.1-collector*)) forms)))) (dolist (c '(nil (:compile-toplevel))) (dolist (l '(nil (:load-toplevel))) (dolist (x '(nil (:execute))) (push `(let () (eval-when (,@c ,@l ,@x) (push '(let ,@c ,@l ,@x) *eval-when.1-collector*))) forms)))) (with-open-file (o ff :direction :output :if-exists :supersede) (dolist (f forms) (prin1 f o) (terpri o))) (let ((*eval-when.1-collector* nil)) (load ff) (push (cons "load source" *eval-when.1-collector*) all)) (let ((*eval-when.1-collector* nil)) (compile-file ff) (push (cons "compile source" *eval-when.1-collector*) all)) (let ((*eval-when.1-collector* nil)) (load (compile-file-pathname ff)) (push (cons "load compiled" *eval-when.1-collector*) all)) (delete-file ff) (delete-file (compile-file-pathname ff)) #+clisp (delete-file (make-pathname :type "lib" :defaults ff)) (nreverse all)) (("load source" (:execute) (:load-toplevel :execute) (:compile-toplevel :execute) (:compile-toplevel :load-toplevel :execute) (let :execute) (let :load-toplevel :execute) (let :compile-toplevel :execute) (let :compile-toplevel :load-toplevel :execute)) ("compile source" (:compile-toplevel) (:compile-toplevel :execute) (:compile-toplevel :load-toplevel) (:compile-toplevel :load-toplevel :execute)) ("load compiled" (:load-toplevel) (:load-toplevel :execute) (:compile-toplevel :load-toplevel) (:compile-toplevel :load-toplevel :execute) (let :execute) (let :load-toplevel :execute) (let :compile-toplevel :execute) (let :compile-toplevel :load-toplevel :execute)))) ;;; More EVAL-WHEN tests to go here (deftest eval-when.2 (eval-when () :bad) nil) (deftest eval-when.3 (eval-when (:execute)) nil) (deftest eval-when.4 (eval-when (:execute) :good) :good) (deftest eval-when.5 (eval-when (:compile-toplevel) :bad) nil) (deftest eval-when.6 (eval-when (:load-toplevel) :bad) nil) (deftest eval-when.7 (eval-when (:compile-toplevel :execute) :good) :good) (deftest eval-when.8 (eval-when (:load-toplevel :execute) :good) :good) (deftest eval-when.9 (eval-when (:load-toplevel :compile-toplevel) :bad) nil) (deftest eval-when.10 (eval-when (:load-toplevel :compile-toplevel :execute) :good) :good) (deftest eval-when.11 (eval-when (:execute) (values 'a 'b 'c 'd)) a b c d) (deftest eval-when.12 (let ((x :good)) (values (eval-when (:load-toplevel) (setq x :bad)) x)) nil :good) (deftest eval-when.13 (let ((x :good)) (values (eval-when (:compile-toplevel) (setq x :bad)) x)) nil :good) (deftest eval-when.14 (let ((x :bad)) (values (eval-when (:execute) (setq x :good)) x)) :good :good) (deftest eval-when.15 (let ((x :good)) (values (eval-when (load) (setq x :bad)) x)) nil :good) (deftest eval-when.16 (let ((x :good)) (values (eval-when (compile) (setq x :bad)) x)) nil :good) (deftest eval-when.17 (let ((x :bad)) (values (eval-when (eval) (setq x :good)) x)) :good :good) ;;; Macros are expanded in the appropriate environment (deftest eval-when.18 (macrolet ((%m (z) z)) (eval-when (:execute) (expand-in-current-env (%m :good)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/make-list.lsp0000644000000000000000000000013214542551763016060 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.549789434 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-list.lsp0000644000175000017500000000444414542551763015464 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:04:27 2003 ;;;; Contains: Tests of MAKE-LIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test make-list.fold.1 (make-list 1)) (def-fold-test make-list.fold.2 (make-list 10 :initial-element 'x)) ;;; Error tests (deftest make-list.error.1 (check-type-error #'make-list (typef 'unsigned-byte)) nil) (deftest make-list.error.3 (signals-error (make-list) program-error) t) (deftest make-list.error.4 (signals-error (make-list 5 :bad t) program-error) t) (deftest make-list.error.5 (signals-error (make-list 5 :initial-element) program-error) t) (deftest make-list.error.6 (signals-error (make-list 5 1 2) program-error) t) (deftest make-list.error.7 (signals-error (make-list 5 :bad t :allow-other-keys nil) program-error) t) (deftest make-list.error.8 (signals-error (locally (make-list 'a) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/print.lsp0000644000000000000000000000013114542551763015325 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.549789434 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print.lsp0000644000175000017500000000155314542551763014730 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:41:16 2004 ;;;; Contains: Tests of PRINT (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest print.1 (random-print-test 1000) nil) (deftest print.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (print 2 t))))) " 2 ") (deftest print.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (print 3 nil))) " 3 ") ;;; Error tests (deftest print.error.1 (signals-error (with-output-to-string (*standard-output*) (print)) program-error) t) (deftest print.error.2 (signals-error (with-output-to-string (s) (print nil s nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/oddp.lsp0000644000000000000000000000013114542551763015117 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.549789434 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/oddp.lsp0000644000175000017500000000266314542551763014525 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 10:48:25 2003 ;;;; Contains: Tests of ODDP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest oddp.error.1 (signals-error (oddp) program-error) t) (deftest oddp.error.2 (signals-error (oddp 0 nil) program-error) t) (deftest oddp.error.3 (check-type-error #'oddp #'integerp) nil) ;;; Non-error tests (deftest oddp.1 (loop for x in *numbers* when (integerp x) do (oddp x)) nil) (deftest oddp.3 (loop for x = (random-fixnum) repeat 10000 when (or (oddp (+ x x)) (not (oddp (+ x x 1))) (if (oddp x) (or (oddp (1+ x)) (oddp (1- x)) (/= (mod x 2) 1)) (or (not (oddp (1+ x))) (not (oddp (1- x))) (/= (mod x 2) 0)))) collect x) nil) (deftest oddp.4 (let ((upper-bound 1000000000000000) (lower-bound -1000000000000000)) (loop for x = (random-from-interval upper-bound lower-bound) repeat 10000 when (or (oddp (+ x x)) (not (oddp (+ x x 1))) (if (oddp x) (or (oddp (1+ x)) (oddp (1- x)) (/= (mod x 2) 1)) (or (not (oddp (1+ x))) (not (oddp (1- x))) (/= (mod x 2) 0)))) collect x)) nil) (deftest oddp.5 (notnot-mv (oddp 1)) t) (deftest oddp.6 (oddp 0) nil) (deftest oddp.7 (notnot-mv (oddp 100000000000000000000000000000001)) t) (deftest oddp.8 (oddp 100000000000000000000000000000000) nil) gcl-2.7.1/ansi-tests/PaxHeaders/bit-nor.lsp0000644000000000000000000000013014542551762015541 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.549789434 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-nor.lsp0000644000175000017500000001532114542551762015143 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:20:40 2003 ;;;; Contains: Tests for BIT-NOR (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-nor (expand-in-current-env (%m #*0011)) #*0101)) #*1000) (deftest bit-nor.21 (macrolet ((%m (z) z)) (bit-nor #*1010 (expand-in-current-env (%m #*1100)))) #*0001) (deftest bit-nor.22 (macrolet ((%m (z) z)) (bit-nor #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*00010100) (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) (def-fold-test bit-nor.fold.1 (bit-nor #*00101 #*10100)) ;;; Random tests (deftest bit-nor.random.1 (bit-random-test-fn #'bit-nor #'lognor) nil) ;;; Error tests (deftest bit-nor.error.1 (signals-error (bit-nor) program-error) t) (deftest bit-nor.error.2 (signals-error (bit-nor #*000) program-error) t) (deftest bit-nor.error.3 (signals-error (bit-nor #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/arrayp.lsp0000644000000000000000000000013214542551762015467 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.553789452 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/arrayp.lsp0000644000175000017500000000163014542551762015065 0ustar00cammcamm;-*- 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 (check-type-predicate #'arrayp 'array) nil) (deftest arrayp.7 (macrolet ((%m (z) z)) (arrayp (expand-in-current-env (%m 0)))) 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 (signals-error (arrayp) program-error) t) (deftest arrayp.error.2 (signals-error (arrayp #(a b c) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/bit-andc2.lsp0000644000000000000000000000013014542551762015732 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.553789452 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-andc2.lsp0000644000175000017500000001550014542551762015333 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:01:38 2003 ;;;; Contains: Tests of BIT-ANDC2 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-andc2 (expand-in-current-env (%m #*0011)) #*0101)) #*0010) (deftest bit-andc2.21 (macrolet ((%m (z) z)) (bit-andc2 #*1010 (expand-in-current-env (%m #*1100)))) #*0010) (deftest bit-andc2.22 (macrolet ((%m (z) z)) (bit-andc2 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*10000001) (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) (def-fold-test bit-andc2.fold.1 (bit-andc2 #*01101 #*10100)) ;;; Random tests (deftest bit-andc2.random.1 (bit-random-test-fn #'bit-andc2 #'logandc2) nil) ;;; Error tests (deftest bit-andc2.error.1 (signals-error (bit-andc2) program-error) t) (deftest bit-andc2.error.2 (signals-error (bit-andc2 #*000) program-error) t) (deftest bit-andc2.error.3 (signals-error (bit-andc2 #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-load-form.lsp0000644000000000000000000000013214542551763016765 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.553789452 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-load-form.lsp0000644000175000017500000001407414542551763016371 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 09:16:20 2003 ;;;; Contains: Tests of MAKE-LOAD-FORM (in-package :cl-test) ;;; These tests are just of MAKE-LOAD-FORM itself; tests of file compilation ;;; that depend on MAKE-LOAD-FORM will be found elsewhere. (defclass make-load-form-class-01 () (a b c)) (deftest make-load-form.1 (let* ((fun #'make-load-form) (obj (make-instance 'make-load-form-class-01))) (if (eql (or (find-method fun nil '(standard-object) nil) (find-method fun nil (list (find-class t)) nil) :none) (car (compute-applicable-methods fun (list obj)))) ;; The default method applies (handler-case (progn (make-load-form obj) :bad) (error () :good)) :good)) :good) (defstruct make-load-form-struct-02 a b c) (deftest make-load-form.2 (let* ((fun #'make-load-form) (obj (make-make-load-form-struct-02))) (if (eql (or (find-method fun nil '(structure-object) nil) (find-method fun nil (list (find-class t)) nil) :none) (car (compute-applicable-methods fun (list obj)))) ;; The default method applies (handler-case (progn (make-load-form obj) :bad) (error () :good)) :good)) :good) (define-condition make-load-form-condition-03 () ((a) (b) (c))) (deftest make-load-form.3 (let* ((fun #'make-load-form) (obj (make-condition 'make-load-form-condition-03))) (if (eql (or (find-method fun nil '(condition) nil) (find-method fun nil (list (find-class t)) nil) :none) (car (compute-applicable-methods fun (list obj)))) ;; The default method applies (handler-case (progn (make-load-form obj :bad)) (error () :good)) :good)) :good) ;;; Make sure these errors are due to the method, not due to lack of ;;; methods (deftest make-load-form.4 (let* ((obj (make-instance 'make-load-form-class-01)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.5 (let* ((obj (make-make-load-form-struct-02)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.6 (let* ((obj (make-condition 'make-load-form-condition-03)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.7 (let* ((obj (make-instance 'make-load-form-class-01)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.8 (let* ((obj (make-make-load-form-struct-02)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.9 (let* ((obj (make-condition 'make-load-form-condition-03)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.10 (macrolet ((%m (&environment env) (let* ((obj (make-instance 'make-load-form-class-01)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj env)))) (notnot-mv methods)))) (%m)) t) (deftest make-load-form.11 (macrolet ((%m (&environment env) (let* ((obj (make-make-load-form-struct-02)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj env)))) (notnot-mv methods)))) (%m)) t) (deftest make-load-form.12 (macrolet ((%m (&environment env) (let* ((obj (make-condition 'make-load-form-condition-03)) (fun #'make-load-form) (methods (compute-applicable-methods fun (list obj env)))) (notnot-mv methods)))) (%m)) t) ;;; User-defined methods (defclass make-load-form-class-04 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (defmethod make-load-form ((obj make-load-form-class-04) &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(loop for slot-name in '(a b c) when (slot-boundp obj slot-name) collect `(setf (slot-value ,newobj ',slot-name) ',(slot-value obj slot-name))) ,newobj))) (deftest make-load-form.13 (let* ((obj (make-instance 'make-load-form-class-04)) (obj2 (eval (make-load-form obj)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)))) t (nil nil nil)) (deftest make-load-form.14 (let* ((obj (make-instance 'make-load-form-class-04 :a 1 :b '(a b c) :c 'a)) (obj2 (eval (make-load-form obj)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)) (map-slot-value obj2 '(a b c)))) t (t t t) (1 (a b c) a)) (deftest make-load-form.15 (let* ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a)) (obj2 (eval (make-load-form obj nil)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)) (map-slot-value obj2 '(b c)))) t (nil t t) ((a b c) a)) #| (defclass make-load-form-class-05a () ((a :initarg :a))) (defclass make-load-form-class-05b (make-load-form-class-05a) ((b :initarg :b))) (defmethod make-load-form ((obj make-load-form-class-05a) &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(when (slot-boundp obj 'a) `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) ,newobj))) (defmethod make-load-form :around ((obj make-load-form-class-05b) &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(when (slot-boundp obj 'a) `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) ,newobj))) |# ;;; Other error tests (deftest make-load-form.error.1 (signals-error (make-load-form) program-error) t) (deftest make-load-form.error.2 (signals-error (let ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a))) (make-load-form obj nil nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/packages-02.lsp0000644000000000000000000000013114542551763016166 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.553789452 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-02.lsp0000644000175000017500000000345514542551763015574 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/.cvsignore0000644000000000000000000000013214542551762015451 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.553789452 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/.cvsignore0000644000175000017500000000005714542551762015051 0ustar00cammcamm*.fn *.x86f *.fasl *.ufsl *.dfsl *.pfsl binary gcl-2.7.1/ansi-tests/PaxHeaders/char-compare.lsp0000644000000000000000000000013014542551762016530 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.553789452 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/char-compare.lsp0000644000175000017500000003637114542551762016142 0ustar00cammcamm;-*- 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 `(signals-error (funcall ',f) program-error))) (t t t t t t t t t t t t)) (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.7.1/ansi-tests/PaxHeaders/load-numbers.lsp0000644000000000000000000000013214772071554016562 xustar0030 mtime=1743287148.254904168 30 atime=1744294960.553789452 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-numbers.lsp0000644000175000017500000000422114772071554016157 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 7 07:16:44 2003 ;;;; Contains: Forms to load files containing tests of number concepts (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "random-aux.lsp") (load "number-comparison.lsp") (load "max.lsp") (load "min.lsp") (load "minusp.lsp") (load "plusp.lsp") (load "zerop.lsp") (load "floor.lsp") (load "ffloor.lsp") (load "ceiling.lsp") (load "fceiling.lsp") (load "truncate.lsp") (load "ftruncate.lsp") (load "round.lsp") (load "fround.lsp") ;;; transcendental functions go here (load "sin.lsp") (load "cos.lsp") (load "tan.lsp") (load "asin.lsp") (load "acos.lsp") (load "atan.lsp") (load "sinh.lsp") (load "cosh.lsp") (load "tanh.lsp") (load "asinh.lsp") (load "acosh.lsp") (load "atanh.lsp") (load "times.lsp") (load "plus.lsp") (load "minus.lsp") (load "divide.lsp") (load "oneplus.lsp") (load "oneminus.lsp") (load "abs.lsp") (load "exp.lsp") (load "expt.lsp") (load "gcd.lsp") (load "incf.lsp") (load "decf.lsp") (load "lcm.lsp") (load "log.lsp") (load "signum.lsp") (load "sqrt.lsp") (load "isqrt.lsp") (load "random.lsp") (load "random-state-p.lsp") (load "make-random-state.lsp") (load "numberp.lsp") (load "cis.lsp") (load "complex.lsp") (load "complexp.lsp") (load "conjugate.lsp") (load "phase.lsp") (load "realpart.lsp") (load "imagpart.lsp") (load "realp.lsp") (load "numerator-denominator.lsp") (load "rationalp.lsp") (load "ash.lsp") (load "integer-length.lsp") (load "integerp.lsp") (load "parse-integer.lsp") (load "boole.lsp") (load "logand.lsp") (load "logandc1.lsp") (load "logandc2.lsp") (load "logeqv.lsp") (load "logior.lsp") (load "lognand.lsp") (load "lognor.lsp") (load "logorc1.lsp") (load "logorc2.lsp") (load "lognot.lsp") (load "logxor.lsp") (load "logbitp.lsp") (load "logcount.lsp") (load "logtest.lsp") (load "byte.lsp") (load "deposit-field.lsp") (load "dpb.lsp") (load "ldb.lsp") (load "mask-field.lsp") (load "float.lsp") (load "floatp.lsp") (load "rational.lsp") (load "rationalize.lsp") (load "evenp.lsp") (load "oddp.lsp") (load "epsilons.lsp") (load "real.lsp") (load "upgraded-complex-part-type.lsp") (load "arithmetic-error.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/allocate-instance.lsp0000644000000000000000000000013214542551762017557 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.553789452 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/allocate-instance.lsp0000644000175000017500000000726314542551762017165 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 28 21:06:58 2003 ;;;; Contains: Tests of ALLOCATE-INSTANCE (in-package :cl-test) ;;; According to the CLHS, the meaning of adding methods to ;;; ALLOCATE-INSTANCE is unspecified, so this will not be tested ;;; here. (defclass allocate-instance-class-01 () ((a :initform 'x) (b :initarg :b) (c :type float) (d :allocation :class) (e :initarg :e) (f :documentation "foo")) (:default-initargs :b 'y)) (deftest allocate-instance.1 (let* ((class (find-class 'allocate-instance-class-01)) (obj (allocate-instance class))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) (map-slot-boundp* obj '(a b c d e f)))) t t t (nil nil nil nil nil nil)) (deftest allocate-instance.2 (let* ((class (find-class 'allocate-instance-class-01)) (obj (allocate-instance class :foo t :a 10 :b 12 :c 1.0 :d 'a :e 17 :f nil :bar t))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) (map-slot-boundp* obj '(a b c d e f)))) t t t (nil nil nil nil nil nil)) (deftest allocate-instance.3 (let* ((class (find-class 'allocate-instance-class-01)) (obj (allocate-instance class :allow-other-keys nil :xyzzy t))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) (map-slot-boundp* obj '(a b c d e f)))) t t t (nil nil nil nil nil nil)) (defclass allocate-instance-class-02 () (a (b :allocation :class))) (deftest allocate-instance.4 (let ((class (find-class 'allocate-instance-class-02))) (setf (slot-value (allocate-instance class) 'b) 'x) (let ((obj (allocate-instance class))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-02) (typep* obj class) (slot-boundp* obj 'a) (slot-value obj 'b)))) t t t nil x) (defstruct allocate-instance-struct-01 a (b 0 :type integer) (c #\a :type character) (d 'a :type symbol)) (deftest allocate-instance.5 (let* ((class (find-class 'allocate-instance-struct-01)) (obj (allocate-instance class))) (setf (allocate-instance-struct-01-a obj) 'x (allocate-instance-struct-01-b obj) 1234567890 (allocate-instance-struct-01-c obj) #\Z (allocate-instance-struct-01-d obj) 'foo) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-struct-01) (typep* obj class) (allocate-instance-struct-01-a obj) (allocate-instance-struct-01-b obj) (allocate-instance-struct-01-c obj) (allocate-instance-struct-01-d obj))) t t t x 1234567890 #\Z foo) ;;; Order of evaluation tests (deftest allocate-instance.order.1 (let* ((class (find-class 'allocate-instance-class-01)) (i 0) x y z w (obj (allocate-instance (progn (setf x (incf i)) class) :e (setf y (incf i)) :b (setf z (incf i)) :e (setf w (incf i))))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) (typep* obj class) i x y z w)) t t t 4 1 2 3 4) ;;; Error tests (deftest allocate-instance.error.1 (signals-error (allocate-instance) program-error) t) ;;; Duane Rettig made a convincing argument that the next two ;;; tests are bad, since the caller of allocate-instance ;;; is supposed to have checked that the initargs are valid #| (deftest allocate-instance.error.2 (signals-error (allocate-instance (find-class 'allocate-instance-class-01) :b) program-error) t) (deftest allocate-instance.error.3 (signals-error (allocate-instance (find-class 'allocate-instance-class-01) '(a b c) nil) program-error) t) |# gcl-2.7.1/ansi-tests/PaxHeaders/print-complex.lsp0000644000000000000000000000013114542551763016772 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.553789452 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-complex.lsp0000644000175000017500000000242714542551763016376 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Mar 3 06:44:04 2004 ;;;; Contains: Tests of printing complex numbers (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.complex.1 (equalt (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 (complex 1 2) s)))) "#C(1 2)") t) (deftest print.complex.2 (equalt (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) (prin1 (complex 1.0 2.0) s)))) "#C(1.0 2.0)") t) (deftest print.complex.random.1 (loop for numbits = (random 40) for bound = (ash 1 numbits) for r = (- (random (+ bound bound)) bound) for i = (- (random (+ bound bound)) bound) repeat 1000 unless (= i 0) nconc (randomly-check-readability (complex r i))) nil) (deftest print.complex.random.2 (loop for numbits = (random 40) for bound = (ash 1 numbits) for num1 = (- (random (+ bound bound)) bound) for num2 = (- (random (+ bound bound)) bound) for denom1 = (1+ (random bound)) for denom2 = (1+ (random bound)) for r = (/ num1 denom1) for i = (/ num2 denom2) repeat 1000 unless (= i 0) nconc (randomly-check-readability (complex r i))) nil) ;; General floating point complex printing tests will go here gcl-2.7.1/ansi-tests/PaxHeaders/when.lsp0000644000000000000000000000013214542551763015133 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.553789452 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/when.lsp0000644000175000017500000000270114542551763014531 0ustar00cammcamm;-*- 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) ;;; No implicit tagbody (deftest when.8 (block done (tagbody (when t (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest when.9 (macrolet ((%m (z) z)) (when (expand-in-current-env (%m t)) :good)) :good) (deftest when.10 (macrolet ((%m (z) z)) (when (expand-in-current-env (%m nil)) :bad)) nil) (deftest when.11 (macrolet ((%m (z) z)) (let ((x t)) (values (when x (expand-in-current-env (%m (setf x 'foo)))) x))) foo foo) ;;; Error tests (deftest when.error.1 (signals-error (funcall (macro-function 'when)) program-error) t) (deftest when.error.2 (signals-error (funcall (macro-function 'when) '(when t)) program-error) t) (deftest when.error.3 (signals-error (funcall (macro-function 'when) '(when t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ansi-aux.lsp0000644000000000000000000000013214542551762015716 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.553789452 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ansi-aux.lsp0000644000175000017500000010671214542551762015323 0ustar00cammcamm;-*- 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)))) (declaim (ftype (function (t) function) to-function)) (defun to-function (fn) (etypecase fn (function fn) (symbol (symbol-function fn)) ((cons (eql setf) (cons symbol null)) (fdefinition fn)))) ;;; 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 string=t (x y) (notnot-mv (string= 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 <=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)) (when (symbolp fn) (assert (fboundp fn)) (setf fn (symbol-function (the symbol fn)))) (let ((a (funcall (the function fn) n))) (declare (type (array * *) a)) (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 (regression-test::my-aref a1) (regression-test::my-aref a2)) (let ((ad (array-dimensions a1))) (and (equal ad (array-dimensions a2)) (locally (declare (type (array * *) a1 a2)) (if (= (array-rank a1) 1) (let ((as (first ad))) (loop for i from 0 below as always (equal (regression-test::my-aref a1 i) (regression-test::my-aref a2 i)))) (let ((as (array-total-size a1))) (and (= as (array-total-size a2)) (loop for i from 0 below as always (equal (regression-test::my-row-major-aref a1 i) (regression-test::my-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)))))) (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." (when (symbolp p) (assert (fboundp p)) (setf p (symbol-function p))) (assert (typep p 'function)) (loop for x in *universe* when (block failed (let ((p1 (handler-case (normally (funcall (the function p) x)) (error () (format t "(FUNCALL ~S ~S) failed~%" P x) (return-from failed t)))) (p2 (handler-case (normally (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))) collect x)) ;;; We have a common idiom where a guarded predicate should be ;;; true everywhere (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 (normally ,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 (normally ,form) (undefined-function () 'undefined-function) (program-error () 'program-error) (package-error () 'package-error) (type-error () 'type-error) (control-error () 'control-error) (parse-error () 'parse-error) (stream-error () 'stream-error) (reader-error () 'reader-error) (file-error () 'file-error) (cell-error () 'cell-error) (division-by-zero () 'division-by-zero) (floating-point-overflow () 'floating-point-overflow) (floating-point-underflow () 'floating-point-underflow) (arithmetic-error () 'arithmetic-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)) ;;; The above is badly designed, since it fails when some signals ;;; may be in more than one class/ (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))))) ;;; ;;; 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)))))) ;; (declaim (ftype (function (&rest function) (values function &optional)) ;; compose)) (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f in rfns do (setf x (funcall (the function 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 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+ (coerce "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ " 'simple-base-string)) (defparameter +base-chars+ #.(coerce (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") 'simple-base-string)) (declaim (type simple-base-string +base-chars+)) (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+ (coerce "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 'simple-base-string)) (declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ +standard-chars+)) (defparameter +code-chars+ (coerce (loop for i from 0 below 256 for c = (code-char i) when c collect c) 'simple-string)) (declaim (type simple-string +code-chars+)) (defparameter +rev-code-chars+ (reverse +code-chars+)) ;;; Used in checking for continuable errors (defun has-non-abort-restart (c) (throw 'handled (if (position 'abort (the list (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 even-size-p (a) (some #'evenp (array-dimensions a))) (defun safe-elt (x n) (classify-error* (elt x n))) (defmacro defstruct* (&body args) `(eval-when (:load-toplevel :compile-toplevel :execute) (handler-case (eval '(defstruct ,@args)) (serious-condition () nil)))) (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)))) #-(or allegro openmcl lispworks) (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))) ;;; This is a hack to get around an ACL bug; OpenMCL also apparently ;;; needs it #+(or allegro openmcl lispworks) (defun delete-all-versions (pathspec) (when (probe-file pathspec) (delete-file pathspec))) (defconstant +fail-count-limit+ 20) (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 collect-properties (plist prop) "Collect all the properties in plist for a property prop." (loop for e on plist by #'cddr when (eql (car e) prop) collect (cadr e))) (defmacro def-macro-test (test-name macro-form) (let ((macro-name (car macro-form))) (assert (symbolp macro-name)) `(deftest ,test-name (values (signals-error (funcall (macro-function ',macro-name)) program-error) (signals-error (funcall (macro-function ',macro-name) ',macro-form) program-error) (signals-error (funcall (macro-function ',macro-name) ',macro-form nil nil) program-error)) t t t))) (defun typep* (element type) (not (not (typep element type)))) (defun applyf (fn &rest args) (etypecase fn (symbol #'(lambda (&rest more-args) (apply (the symbol fn) (append args more-args)))) (function #'(lambda (&rest more-args) (apply (the function fn) (append args more-args)))))) (defun slot-boundp* (object slot) (notnot (slot-boundp object slot))) (defun slot-exists-p* (object slot) (notnot (slot-exists-p object slot))) (defun map-slot-boundp* (c slots) (mapcar (applyf #'slot-boundp c) slots)) (defun map-slot-exists-p* (c slots) (mapcar (applyf #'slot-exists-p* c) slots)) (defun map-slot-value (c slots) (mapcar (applyf #'slot-value c) slots)) (defun map-typep* (object types) (mapcar (applyf #'typep* object) types)) (defun slot-value-or-nil (object slot-name) (and (slot-exists-p object slot-name) (slot-boundp object slot-name) (slot-value object slot-name))) (defun is-noncontiguous-sublist-of (list1 list2) (loop for x in list1 do (loop when (null list2) do (return-from is-noncontiguous-sublist-of nil) when (eql x (pop list2)) do (return)) finally (return t))) ;;; This defines a new metaclass to allow us to get around ;;; the restriction in section 11.1.2.1.2, bullet 19 in some ;;; object system tests ;;; (when (typep (find-class 'standard-class) 'standard-class) ;;; (defclass substandard-class (standard-class) ()) ;;; (defparameter *can-define-metaclasses* t)) ;;; Macro for testing that something is undefined but 'harmless' (defmacro defharmless (name form) `(deftest ,name (block done (let ((*debugger-hook* #'(lambda (&rest args) (declare (ignore args)) (return-from done :good)))) (handler-case (unwind-protect (eval ',form) (return-from done :good)) (condition () :good)))) :good)) (defun rational-safely (x) "Rational a floating point number, making sure the rational number isn't 'too big'. This is important in implementations such as clisp where the floating bounds can be very large." (assert (floatp x)) (multiple-value-bind (significand exponent sign) (integer-decode-float x) (let ((limit 1000) (radix (float-radix x))) (cond ((< exponent (- limit)) (* significand (expt radix (- limit)) sign)) ((> exponent limit) (* significand (expt radix limit) sign)) (t (rational x)))))) (declaim (special *similarity-list*)) (defun is-similar (x y) (let ((*similarity-list* nil)) (is-similar* x y))) (defgeneric is-similar* (x y)) (defmethod is-similar* ((x number) (y number)) (and (eq (class-of x) (class-of y)) (= x y) t)) (defmethod is-similar* ((x character) (y character)) (and (char= x y) t)) (defmethod is-similar* ((x symbol) (y symbol)) (if (null (symbol-package x)) (and (null (symbol-package y)) (is-similar* (symbol-name x) (symbol-name y))) ;; I think the requirements for interned symbols in ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp (eq x y)) t) (defmethod is-similar* ((x random-state) (y random-state)) (let ((copy-of-x (make-random-state x)) (copy-of-y (make-random-state y)) (bound (1- (ash 1 24)))) (and ;; Try 50 values, and assume the random state are the same ;; if all the values are the same. Assuming the RNG is not ;; very pathological, this should be acceptable. (loop repeat 50 always (eql (random bound copy-of-x) (random bound copy-of-y))) t))) (defmethod is-similar* ((x cons) (y cons)) (or (and (eq x y) t) (and (loop for (x2 . y2) in *similarity-list* thereis (and (eq x x2) (eq y y2))) t) (let ((*similarity-list* (cons (cons x y) *similarity-list*))) (and (is-similar* (car x) (car y)) ;; If this causes stack problems, ;; convert to a loop (is-similar* (cdr x) (cdr y)))))) (defmethod is-similar* ((x vector) (y vector)) (or (and (eq x y) t) (and (or (not (typep x 'simple-array)) (typep x 'simple-array)) (= (length x) (length y)) (is-similar* (array-element-type x) (array-element-type y)) (loop for i below (length x) always (is-similar* (aref x i) (aref y i))) t))) (defmethod is-similar* ((x array) (y array)) (or (and (eq x y) t) (and (or (not (typep x 'simple-array)) (typep x 'simple-array)) (= (array-rank x) (array-rank y)) (equal (array-dimensions x) (array-dimensions y)) (is-similar* (array-element-type x) (array-element-type y)) (let ((*similarity-list* (cons (cons x y) *similarity-list*))) (loop for i below (array-total-size x) always (is-similar* (row-major-aref x i) (row-major-aref y i)))) t))) (defmethod is-similar* ((x hash-table) (y hash-table)) ;; FIXME Add similarity check for hash tables (error "Sorry, we're not computing this yet.")) (defmethod is-similar* ((x pathname) (y pathname)) (and (is-similar* (pathname-host x) (pathname-host y)) (is-similar* (pathname-device x) (pathname-device y)) (is-similar* (pathname-directory x) (pathname-directory y)) (is-similar* (pathname-name x) (pathname-name y)) (is-similar* (pathname-type x) (pathname-type y)) (is-similar* (pathname-version x) (pathname-version y)) t)) (defmethod is-similar* ((x t) (y t)) (and (eql x y) t)) (defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*) *print-pprint-dispatch* nil)) (defmacro my-with-standard-io-syntax (&body body) `(let ((*package* (find-package "COMMON-LISP-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* *initial-print-pprint-dispatch*) (*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 nil))) ,@body)) ;;; Function to produce a non-simple string (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)))))))) (defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer)) (let* ((len (length contents)) (min (reduce #'min contents)) (max (reduce #'max contents)) (len2 (if fill (+ len 4) len))) (unless (and (typep min etype) (typep max etype)) (setq etype `(integer ,min ,max))) (if displace (let ((s0 (make-array (+ len2 5) :initial-contents (concatenate 'list (make-list 2 :initial-element (if (typep 0 etype) 0 min)) contents (make-list (if fill 7 3) :initial-element (if (typep 1 etype) 1 max))) :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 'list contents (make-list 4 :initial-element (if (typep 2 etype) 2 (floor (+ min max) 2)))) contents) :fill-pointer (if fill len nil) :adjustable adjust)))) (defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms) (let ((vector (gensym)) (fill (gensym "FILL")) (adjust (gensym "ADJUST")) (etype (gensym "ETYPE")) (displace (gensym "DISPLACE"))) `(let ((,vector ,vec-form)) (dolist (,fill '(nil t) ,ret-form) (dolist (,adjust '(nil t)) (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) (loop for i from 2 to 32 collect `(signed-byte ,i)) '(integer))) (dolist (,displace '(nil t)) (let ((,var (make-special-integer-vector ,vector :fill ,fill :adjust ,adjust :etype ,etype :displace ,displace))) ,@forms)))))))) ;;; Return T if arg X is a string designator in this implementation (defun string-designator-p (x) (handler-case (progn (string x) t) (error nil))) ;;; Approximate comparison of numbers #| (defun approx= (x y) (let ((eps 1.0d-4)) (<= (abs (- x y)) (* eps (max (abs x) (abs y)))))) |# ;;; Approximate equality function (defun approx= (x y &optional (eps (epsilon x))) (<= (abs (/ (- x y) (max (abs x) 1))) eps)) (defun epsilon (number) (etypecase number (complex (* 2 (epsilon (realpart number)))) ;; crude (short-float short-float-epsilon) (single-float single-float-epsilon) (double-float double-float-epsilon) (long-float long-float-epsilon) (rational 0))) (defun negative-epsilon (number) (etypecase number (complex (* 2 (negative-epsilon (realpart number)))) ;; crude (short-float short-float-negative-epsilon) (single-float single-float-negative-epsilon) (double-float double-float-negative-epsilon) (long-float long-float-negative-epsilon) (rational 0))) (defun sequencep (x) (typep x 'sequence)) (defun typef (type) #'(lambda (x) (typep x type))) (defun package-designator-p (x) "TRUE if x could be a package designator. The package need not actually exist." (or (packagep x) (handler-case (and (locally (declare (optimize safety)) (string x)) t) (type-error () nil)))) (defmacro def-fold-test (name form) "Create a test that FORM, which should produce a fresh value, does not improperly introduce sharing during constant folding." `(deftest ,name (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) (debug 0))) ,form)) (eq (%f) (%f))) nil)) ;;; Macro used in tests of environments in system macros ;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP ;;; was being called in some system macros without the proper ;;; environment argument (defmacro expand-in-current-env (macro-form &environment env) (macroexpand macro-form env)) gcl-2.7.1/ansi-tests/PaxHeaders/packagep.lsp0000644000000000000000000000013114542551763015744 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.553789452 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packagep.lsp0000644000175000017500000000073014542551763015343 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:51:38 2004 ;;;; Contains: Tests of PACKAGEP (in-package :cl-test) (deftest packagep.1 (check-type-predicate #'packagep 'package) nil) ;;; *package* is always a package (deftest packagep.2 (not-mv (packagep *package*)) nil) (deftest packagep.error.1 (signals-error (packagep) program-error) t) (deftest packagep.error.2 (signals-error (packagep nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/sublis.lsp0000644000000000000000000000013214542551763015473 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.553789452 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sublis.lsp0000644000175000017500000001105314542551763015071 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:32:50 2003 ;;;; Contains: Tests of SUBLIS (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest sublis.9 (check-sublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (x y z 20)) (deftest sublis.10 (check-sublis (list 0 3 8 20) '((1 . x) (5 . y) (10 . z)) :test-not #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (x y z 20)) (defharmless sublis.test-and-test-not.1 (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'eql :test-not #'eql)) (defharmless sublis.test-and-test-not.2 (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'eql :test #'eql)) ;;; 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) ;;; Const fold tests (def-fold-test sublis.fold.1 (sublis '((a . b)) '(a x y . a))) ;;; 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 (signals-error (sublis) program-error) t) (deftest sublis.error.2 (signals-error (sublis nil) program-error) t) (deftest sublis.error.3 (signals-error (sublis nil 'a :test) program-error) t) (deftest sublis.error.4 (signals-error (sublis nil 'a :bad-keyword t) program-error) t) (deftest sublis.error.5 (signals-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity) program-error) t) (deftest sublis.error.6 (signals-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons) program-error) t) (deftest sublis.error.7 (signals-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity) program-error) t) (deftest sublis.error.8 (signals-error (sublis '((a . 1) . bad) (list 'a 'b 'c 'd)) type-error) t) (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))) gcl-2.7.1/ansi-tests/PaxHeaders/stream-external-format.lsp0000644000000000000000000000013214542551763020573 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.557789469 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/stream-external-format.lsp0000644000175000017500000000106414542551763020172 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/random-int-form.lsp0000644000000000000000000000013214542551763017203 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.557789469 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/random-int-form.lsp0000644000175000017500000034414314542551763016612 0ustar00cammcamm;-*- 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* *make-random-integer-form-cdf*)) ;;; 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 load-failures (&key (pathname "failures.lsp")) (length (setq $y (with-open-file (s pathname :direction :input) (loop for x = (read s nil) while x collect x))))) (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 *random-special-vars* #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) (defparameter *loop-random-int-form-period* 2000) (defmacro cl-handler-bind (&rest args) `(cl:handler-bind ,@args)) (defmacro cl-handler-case (&rest args) `(cl:handler-case ,@args)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun cumulate (vec) (loop for i from 1 below (length vec) do (incf (aref vec i) (aref vec (1- i)))) vec)) (defparameter *default-make-random-integer-form-cdf* (cumulate (copy-seq #(10 5 40 4 5 4 2 2 10 1 1 #-armedbead 1 #-armedbear 1 #-allegro 5 5 5 #-(or gcl ecl armedbear) 2 2 #-(or cmu allegro poplog) 5 4 30 4 20 3 2 2 1 1 5 30 #-poplog 5 #-(or allegro poplog) 10 50 4 4 10 20 10 10 3 20 5 #-(or armedbear) 20 2 2 2)))) (defparameter *make-random-integer-form-cdf* (copy-seq *default-make-random-integer-form-cdf*)) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-random-integer-form-params (&body forms) (let ((len (gensym "LEN")) (vec (gensym "VEC"))) `(let* ((,len (length *default-make-random-integer-form-cdf*)) (,vec (make-array ,len))) (loop for i from 0 below ,len do (setf (aref ,vec i) (1+ (min (random 100) (random 100))))) (setq ,vec (cumulate ,vec)) (let ((*make-random-integer-form-cdf* ,vec)) ,@forms))))) ;;; 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 *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))) (loop for i from 1 to n do (when (= (mod i 100) 0) ;; #+sbcl (print "Do gc...") ;; #+sbcl (sb-ext::gc :full t) ;; #+lispworks-personal-edition (cl-user::normal-gc) (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* nil)) (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) ) (with-random-integer-form-params (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) ) (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) (defun make-random-optimize-settings () (loop for settings = (list* (list 'speed (random 4)) #+sbcl '(sb-c:insert-step-conditions 0) (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 (random-permute 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 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 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 is-zero-rank-integer-array-type (type) "This function was introduced because of a bug in ACL 6.2" ; (subtypep type '(array integer 0)) (and (consp type) (eq (car type) 'array) (cddr type) (or (eq (cadr type) '*) (subtypep (cadr type) 'integer)) (or (eql (caddr type) 0) (null (caddr type))))) (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 0)) (is-zero-rank-integer-array-type type) `(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) (rselect *make-random-integer-form-cdf* ;; flet call (make-random-integer-flet-call-form size) (make-random-aref-form size) ;; Unary ops (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)))) (make-random-integer-unwind-protect-form size) (make-random-integer-mapping-form size) ;; prog1, multiple-value-prog1 (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 (let* ((nforms (random 4)) (sizes (random-partition (1- size) (+ nforms 2))) (args (mapcar #'make-random-integer-form sizes))) `(prog2 ,@args)) `(isqrt (abs ,(make-random-integer-form (- size 2)))) `(the integer ,(make-random-integer-form (1- size))) `(cl:handler-bind nil ,(make-random-integer-form (1- size))) `(restart-bind nil ,(make-random-integer-form (1- size))) #-armedbear `(macrolet () ,(make-random-integer-form (1- size))) #-armedbear `(symbol-macrolet () ,(make-random-integer-form (1- size))) ;; dotimes #-allegro (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 (make-random-loop-form (1- size)) (make-random-count-form size) #-(or gcl ecl armedbear) ;; load-time-value (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 (make-random-integer-eval-form size) #-(or cmu allegro poplog) (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 (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 (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 (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 (let* ((op (random-from-seq #(+ - * logand min max logior values lcm gcd logxor))) (nmax (case op ((* lcm gcd) 4) (values (1- multiple-values-limit)) (t (1+ (random 40))))) (nargs (1+ (min (random nmax) (random nmax)))) (sizes (random-partition (1- size) nargs)) (args (mapcar #'make-random-integer-form sizes))) `(,op ,@args)) ;; expt `(expt ,(make-random-integer-form (1- size)) ,(random 3)) ;; coerce `(coerce ,(make-random-integer-form (1- size)) 'integer) ;; complex (degenerate case) `(complex ,(make-random-integer-form (1- size)) 0) ;; quotient (degenerate cases) `(/ ,(make-random-integer-form (1- size)) 1) `(/ ,(make-random-integer-form (1- size)) -1) ;; tagbody (make-random-tagbody-and-progn size) ;; conditionals (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)) #-poplog (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))) #-(or allegro poplog) (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))) (make-random-integer-binding-form size) ;; progv (make-random-integer-progv-form size) `(let () ,(make-random-integer-form (1- size))) (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)))) (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)))) ;; setq and similar (make-random-integer-setq-form size) (make-random-integer-case-form size) (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)) (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)) (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) (make-random-flet-form size) (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)))))) (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)))))) (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-aref-form (size) (or (when *vars* (let* ((desc (random-var-desc)) (type (var-desc-type desc)) (name (var-desc-name desc))) (cond ((null type) nil) ((subtypep type '(array integer (*))) `(aref ,name (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form (- size 2)))))) ((subtypep type '(array integer (* *))) (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) `(aref ,name (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form s1))) (min ,(1- (second (third type))) (max 0 ,(make-random-integer-form s2)))))) (t nil)))) (make-random-integer-form size))) (defun make-random-count-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let ((arg1 (make-random-integer-form s1)) (arg2-args (loop repeat s2 collect (make-random-integer)))) (let ((op 'count) (test (random-from-seq #(eql = /= < > <= >=))) (arg2 (rcase (1 (make-array (list s2) :initial-contents arg2-args)) (1 (let* ((mask (1- (ash 1 (1+ (random 32)))))) (make-array (list s2) :initial-contents (mapcar #'(lambda (x) (logand x mask)) arg2-args) :element-type `(integer 0 ,mask)))) (1 `(quote ,arg2-args))))) `(,op ,arg1 ,arg2 ,@(rcase (2 nil) (1 (list :test `(quote ,test))) (1 (list :test-not `(quote ,test))))))))) (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) (find (var-desc-name s) *random-special-vars*)) *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 (find var *random-special-vars*) (setq desc (find var *vars* :key #'var-desc-name))) (var-desc-type desc)) (t (rcase (4 '(integer * *)) (1 (setq e1 `(make-array nil :initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) '(array integer nil)) (1 (let ((size (1+ (random 10)))) (setq e1 `(make-array '(,size):initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) `(array integer (,size)))) #| (1 (let ((size1 (1+ (random 10))) (size2 (1+ (random 10)))) (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) `(array integer (,size1 ,size2)))) |# (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 random2 (n) (min (random n) (random n))) (defun random-from-seq2 (seq) (elt seq (random2 (length seq)))) (defun make-random-integer-binding-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let* ((var (random-from-seq2 (rcase (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)) #-ecl (2 *random-special-vars*) ))) (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)))) (3 nil)) ,e2)) (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) (defun make-random-integer-progv-form (size) (let* ((num-vars (random 4)) (possible-vars *random-special-vars*) (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 shiftf)))) (cond ((subtypep '(integer * *) type) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (rcase (1 (when (find var *random-special-vars*) (setq op (random-from-seq #(setf shiftf)) var `(symbol-value ',var)))) (1 (setq op 'multiple-value-setq) (setq var (list var))) (5 (setf op (random-from-seq #(setq setf shiftf incf decf))))) `(,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)))) (rcase (1 (when (find var *random-special-vars*) (setq op (random-from-seq #(setf shiftf)) var `(symbol-value ',var)))) (1 (setq op 'multiple-value-setq) (setq var (list var))) (5 nil)) `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil)) (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)))) ((and type (subtypep type '(array integer (*)))) (when (eq op 'setq) (setq op (random-from-seq #(setf shiftf)))) (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) `(,op (aref ,var (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form s1)))) ,(make-random-integer-form s2)))) ((and type (subtypep type '(array integer (* *)))) (when (eq op 'setq) (setq op (random-from-seq #(setf shiftf)))) (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3) `(,op (aref ,var (min ,(1- (first (third type))) (max 0 ,(make-random-integer-form s1))) (min ,(1- (second (third type))) (max 0 ,(make-random-integer-form s2)))) ,(make-random-integer-form s3)))) ;; 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))) ) (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))) (s1 (car sizes)) (s2 (cadr sizes)) (opt-sizes (cddr sizes))) (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)))) (12 (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 (let* ((nsizes (+ 1 (random 3))) (sizes (random-partition (1- size) nsizes))) `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal) #(< <= > >= = /=))) ,@(mapcar #'make-random-integer-form sizes)))) (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))) #-poplog (1 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(ldb-test ,(make-random-byte-spec-form s1) ,(make-random-integer-form s2)))) (2 (let ((form (make-random-integer-form (1- size))) (op (random-from-seq #(evenp oddp minusp plusp zerop)))) `(,op ,form))) (2 (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let ((arg1 (make-random-integer-form s1)) (arg2-args (loop repeat s2 collect (make-random-integer)))) (let ((op (random-from-seq #(find position))) (test (random-from-seq #(eql = /= < > <= >=))) (arg2 (rcase (1 (make-array (list s2) :initial-contents arg2-args)) (1 (let* ((mask (1- (ash 1 (1+ (random 32)))))) (make-array (list s2) :initial-contents (mapcar #'(lambda (x) (logand x mask)) arg2-args) :element-type `(integer 0 ,mask)))) (1 `(quote ,arg2-args))))) `(,op ,arg1 ,arg2 ,@(rcase (2 nil) (1 (list :test `(quote ,test))) (1 (list :test-not `(quote ,test))))))))) (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 `(real ,@(make-random-integer-range))) (1 `(rational ,@(make-random-integer-range))) (1 `(rational ,(+ 1/2 (make-random-integer)))) (1 `(rational * ,(+ 1/2 (make-random-integer)))) (1 `(integer ,@(make-random-integer-range))) (1 `(integer ,(make-random-integer))) (1 `(integer * ,(make-random-integer))) (1 'fixnum) (1 'bignum) (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))) (defgeneric make-random-element-of-type (type) (:documentation "Create a random element of a lisp type.")) (defgeneric make-random-element-of-compound-type (type-op type-args) (:documentation "Create a random element of type `(,TYPE-OP ,@TYPE-ARGS)") (:method ((type-op (eql 'or)) type-args) (assert type-args) (make-random-element-of-type (random-from-seq type-args))) (:method ((type-op (eql 'and)) type-args) (assert type-args) (loop for x = (make-random-element-of-type (car type-args)) repeat 100 when (typep x (cons 'and (cdr type-args))) return x finally (error "Cannot generate random element of ~A" (cons type-op type-args)))) (:method ((type-op (eql 'not)) type-args) (assert (eql (length type-args) 1)) (make-random-element-of-type `(and t (not ,(car type-args))))) (:method ((type-op (eql 'integer)) type-args) (let ((lo (let ((lo (car type-args))) (cond ((consp lo) (1+ (car lo))) ((eq lo nil) '*) (t lo)))) (hi (let ((hi (cadr type-args))) (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))))) (:method ((type-op (eql 'rational)) type-args) (let ((type (cons type-op type-args))) (or (let ((r (make-random-element-of-type 'rational))) (and (typep r type) r)) (let ((lo (car type-args)) (hi (cadr type-args)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo nil) (setq lo= nil)) (t (assert (typep lo 'rational)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi nil) (setq hi= nil)) (t (assert (typep hi 'rational)) (setq hi= t))) (assert (or (null lo) (null hi) (<= lo hi))) (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) (cond ((null lo) (cond ((null hi) (make-random-rational)) (hi= (- hi (make-random-nonnegative-rational))) (t (- hi (make-random-positive-rational))))) ((null hi) (cond (lo= (+ lo (make-random-nonnegative-rational))) (t (+ lo (make-random-positive-rational))))) (t (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))) (:method ((type-op (eql 'ratio)) type-args) (let ((r 0)) (loop do (setq r (make-random-element-of-compound-type 'rational type-args)) while (integerp r)) r)) (:method ((type-op (eql 'real)) type-args) (rcase (1 (let ((lo (and (numberp (car type-args)) (rational (car type-args)))) (hi (and (numberp (cadr type-args)) (rational (cadr type-args))))) (make-random-element-of-compound-type 'rational `(,(or lo '*) ,(or hi '*))))) (1 (make-random-element-of-compound-type 'float `(,(or (car type-args) '*) ,(or (cadr type-args) '*)))))) (:method ((type-op (eql 'float)) type-args) (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) (lo (car type-args)) (hi (cadr type-args)) (most-neg (most-negative-float new-type-op)) (most-pos (most-positive-float new-type-op))) (cond ((or (and (realp lo) (< lo most-neg)) (and (realp hi) (> hi most-pos))) ;; try again (make-random-element-of-compound-type type-op type-args)) (t (when (and (realp lo) (not (typep lo new-type-op))) (cond ((< lo most-neg) (setq lo '*)) (t (setq lo (coerce lo new-type-op))))) (when (and (realp hi) (not (typep hi new-type-op))) (cond ((> hi most-pos) (setq hi '*)) (t (setq hi (coerce hi new-type-op))))) (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*))))))) (:method ((type-op (eql 'short-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'single-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'double-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'long-float)) type-args) (assert (<= (length type-args) 2)) (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'mod)) type-args) (let ((modulus (second type-args))) (assert (integerp modulus)) (assert (plusp modulus)) (make-random-element-of-compound-type 'integer `(0 (,modulus))))) (:method ((type-op (eql 'unsigned-byte)) type-args) (assert (<= (length type-args) 1)) (if (null type-args) (make-random-element-of-type '(integer 0 *)) (let ((bits (first type-args))) (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))))))))) (:method ((type-op (eql 'signed-byte)) type-args) (assert (<= (length type-args) 1)) (if (null type-args) (make-random-element-of-type 'integer) (let ((bits (car type-args))) (if (eq bits'*) (make-random-element-of-type 'integer) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of-type `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) (:method ((type-op (eql 'eql)) type-args) (assert (= (length type-args) 1)) (car type-args)) (:method ((type-op (eql 'member)) type-args) (assert type-args) (random-from-seq type-args)) (:method ((type-op (eql 'vector)) type-args) (assert (<= (length type-args) 2)) (let ((etype-spec (if type-args (car type-args) '*)) (size-spec (if (cdr type-args) (cadr type-args) '*))) (make-random-vector etype-spec size-spec))) (:method ((type-op (eql 'aimple-vector)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector t size-spec :simple t))) (:method ((type-op (eql 'array)) type-args) (assert (<= (length type-args) 2)) (let ((etype-spec (if type-args (car type-args) '*)) (size-spec (if (cdr type-args) (cadr type-args) '*))) (make-random-array etype-spec size-spec))) (:method ((type-op (eql 'simple-array)) type-args) (assert (<= (length type-args) 2)) (let ((etype-spec (if type-args (car type-args) '*)) (size-spec (if (cdr type-args) (cadr type-args) '*))) (make-random-array etype-spec size-spec :simple t))) (:method ((type-op (eql 'string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-string size-spec))) (:method ((type-op (eql 'simple-string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-string size-spec :simple t))) (:method ((type-op (eql 'base-string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'base-char size-spec))) (:method ((type-op (eql 'simple-base-string)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'base-char size-spec :simple t))) (:method ((type-op (eql 'bit-vector)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'bit size-spec))) (:method ((type-op (eql 'simple-bit-vector)) type-args) (assert (<= (length type-args) 1)) (let ((size-spec (if type-args (car type-args) '*))) (make-random-vector 'bit size-spec :simple t))) (:method ((type-op (eql 'cons)) type-args) (assert (<= (length type-args) 2)) (cons (make-random-element-of-type (if type-args (car type-args) t)) (make-random-element-of-type (if (cdr type-args) (cadr type-args) t)))) (:method ((type-op (eql 'complex)) type-args) (cond ((null type-args) (make-random-element-of-type 'complex)) (t (assert (null (cdr type-args))) (let ((etype (car type-args))) (loop for v1 = (make-random-element-of-type etype) for v2 = (make-random-element-of-type etype) for c = (complex v1 v2) when (typep c (cons 'complex type-args)) return c))))) ) (defmethod make-random-element-of-type ((type cons)) (make-random-element-of-compound-type (car type) (cdr type))) (defun make-random-element-of-float-type (type-op &optional lo hi) (let (lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo (most-negative-float type-op)) (setq lo= t)) (t (assert (typep lo type-op)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi (most-positive-float type-op)) (setq hi= t)) (t (assert (typep hi type-op)) (setq hi= t))) (assert (<= lo hi)) (assert (or (< lo hi) (and lo= hi=))) (let ((limit 100000)) (cond ((or (<= hi 0) (>= lo 0) (and (<= (- limit) hi limit) (<= (- limit) lo limit))) (loop for x = (+ (random (- hi lo)) lo) do (when (or lo= (/= x lo)) (return x)))) (t (rcase (1 (random (min hi (float limit hi)))) (1 (- (random (min (float limit lo) (- lo))))))))))) #| (defmethod make-random-element-of-type ((type cons)) (let ((type-op (first type))) (ecase type-op (or (assert (cdr type)) (make-random-element-of-type (random-from-seq (cdr type)))) (and (assert (cdr type)) (loop for x = (make-random-element-of-type (cadr type)) repeat 100 when (typep x (cons 'and (cddr type))) return x finally (error "Cannot generate random element of ~A" type))) (not (assert (cdr type)) (assert (not (cddr type))) (make-random-element-of-type `(and t ,type))) (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))))) (rational (or (let ((r (make-random-element-of-type 'rational))) (and (typep r type) r)) (let ((lo (cadr type)) (hi (caddr type)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo nil) (setq lo= nil)) (t (assert (typep lo 'rational)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi nil) (setq hi= nil)) (t (assert (typep hi 'rational)) (setq hi= t))) (assert (or (null lo) (null hi) (<= lo hi))) (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) (cond ((null lo) (cond ((null hi) (make-random-rational)) (hi= (- hi (make-random-nonnegative-rational))) (t (- hi (make-random-positive-rational))))) ((null hi) (cond (lo= (+ lo (make-random-nonnegative-rational))) (t (+ lo (make-random-positive-rational))))) (t (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) (ratio (let ((r 0)) (loop do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) while (integerp r)) r)) (real (rcase (1 (let ((lo (and (numberp (cadr type)) (rational (cadr type)))) (hi (and (numberp (caddr type)) (rational (caddr type))))) (make-random-element-of-type `(rational ,(or lo '*) ,(or hi '*))))) (1 (make-random-element-of-type `(float ,(or (cadr type) '*) ,(or (caddr type) '*)))))) ((float) (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) (lo (cadr type)) (hi (caddr type)) (most-neg (most-negative-float new-type-op)) (most-pos (most-positive-float new-type-op))) (cond ((or (and (realp lo) (< lo most-neg)) (and (realp hi) (> hi most-pos))) ;; try again (make-random-element-of-type type)) (t (when (and (realp lo) (not (typep lo new-type-op))) (cond ((< lo most-neg) (setq lo '*)) (t (setq lo (coerce lo new-type-op))))) (when (and (realp hi) (not (typep hi new-type-op))) (cond ((> hi most-pos) (setq hi '*)) (t (setq hi (coerce hi new-type-op))))) (make-random-element-of-type `(,new-type-op ,(or lo '*) ,(or hi '*))))))) ((single-float double-float long-float short-float) (let ((lo (cadr type)) (hi (caddr type)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo (most-negative-float type-op)) (setq lo= t)) (t (assert (typep lo type-op)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi (most-positive-float type-op)) (setq hi= t)) (t (assert (typep hi type-op)) (setq hi= t))) (assert (<= lo hi)) (assert (or (< lo hi) (and lo= hi=))) (let ((limit 100000)) (cond ((or (<= hi 0) (>= lo 0) (and (<= (- limit) hi limit) (<= (- limit) lo limit))) (loop for x = (+ (random (- hi lo)) lo) do (when (or lo= (/= x lo)) (return x)))) (t (rcase (1 (random (min hi (float limit hi)))) (1 (- (random (min (float limit lo) (- 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))))))))) (signed-byte (if (null (cdr type)) (make-random-element-of-type 'integer) (let ((bits (second type))) (if (eq bits'*) (make-random-element-of-type 'integer) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of-type `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) (eql (assert (= (length type) 2)) (cadr type)) (member (assert (cdr type)) (random-from-seq (cdr type))) ((vector) (let ((etype-spec (if (cdr type) (cadr type) '*)) (size-spec (if (cddr type) (caddr type) '*))) (make-random-vector etype-spec size-spec))) ((simple-vector) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-vector t size-spec :simple t))) ((array simple-array) (let ((etype-spec (if (cdr type) (cadr type) '*)) (size-spec (if (cddr type) (caddr type) '*))) (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) ((string simple-string) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-string size-spec :simple (eql (car type) 'simple-string)))) ((base-string simple-base-string) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) ((bit-vector simple-bit-vector) (let ((size-spec (if (cdr type) (cadr type) '*))) (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) ((cons) (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) (make-random-element-of-type (if (cddr type) (caddr type) t)))) ((complex) (cond ((null (cdr type)) (make-random-element-of-type 'complex)) (t (assert (null (cddr type))) (let ((etype (cadr type))) (loop for v1 = (make-random-element-of-type etype) for v2 = (make-random-element-of-type etype) for c = (complex v1 v2) when (typep c type) return c))))) ))) |# (defmethod make-random-element-of-type ((type class)) (make-random-element-of-type (class-name type))) (defmethod make-random-element-of-type ((type (eql 'bit))) (random 2)) (defmethod make-random-element-of-type ((type (eql 'boolean))) (random-from-seq #(nil t))) (defmethod make-random-element-of-type ((type (eql 'symbol))) (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) (defmethod make-random-element-of-type ((type (eql 'keyword))) (random-from-seq #(:a :b :c :d :e :f :g :h :i :j))) (defmethod make-random-element-of-type ((type (eql 'unsigned-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) (defmethod make-random-element-of-type ((type (eql 'signed-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) (- (ash 1 (random *maximum-random-int-bits*))))) (defmethod make-random-element-of-type ((type (eql 'rational))) (make-random-rational)) (defmethod make-random-element-of-type ((type (eql 'ratio))) (let ((r 0)) (loop do (setq r (make-random-element-of-type 'rational)) while (integerp r)) r)) (defmethod make-random-element-of-type ((type (eql 'integer))) (let ((x (ash 1 (random *maximum-random-int-bits*)))) (random-from-interval (1+ x) (- x)))) (defmethod make-random-element-of-type ((type (eql 'float))) (make-random-element-of-type (random-from-seq #(short-float single-float double-float long-float)))) (defmethod make-random-element-of-type ((type (eql 'real))) (make-random-element-of-type (random-from-seq #(integer rational float)))) (defmethod make-random-element-of-type ((type (eql 'number))) (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex)))) (defmethod make-random-element-of-type ((type (eql 'bit-vector))) (make-random-vector 'bit '*)) (defmethod make-random-element-of-type ((type (eql 'simple-bit-vector))) (make-random-vector 'bit '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'vector))) (make-random-vector '* '*)) (defmethod make-random-element-of-type ((type (eql 'simple-vector))) (make-random-vector 't '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'array))) (make-random-array '* '*)) (defmethod make-random-element-of-type ((type (eql 'simple-array))) (make-random-array '* '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'string))) (make-random-string '*)) (defmethod make-random-element-of-type ((type (eql 'simple-string))) (make-random-string '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'base-string))) (make-random-vector 'base-char '*)) (defmethod make-random-element-of-type ((type (eql 'simple-base-string))) (make-random-vector 'base-char '* :simple t)) (defmethod make-random-element-of-type ((type (eql 'character))) (make-random-character)) (defmethod make-random-element-of-type ((type (eql 'extended-char))) (loop for x = (make-random-character) when (typep x 'extended-char) return x)) (defmethod make-random-element-of-type ((type (eql 'null))) nil) (defmethod make-random-element-of-type ((type (eql 'fixnum))) (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum)) (defmethod make-random-element-of-type ((type (eql 'complex))) (make-random-element-of-type '(complex real))) (defmethod make-random-element-of-type ((type (eql 'cons))) (make-random-element-of-type '(cons t t))) (defmethod make-random-element-of-type ((type (eql 'list))) ;; Should modify this to allow non-proper lists? (let ((len (min (random 10) (random 10)))) (loop repeat len collect (make-random-element-of-type t)))) (defmethod make-random-element-of-type ((type (eql 'sequence))) (make-random-element-of-type '(or list vector))) (defmethod make-random-element-of-type ((type (eql 'function))) (rcase (5 (symbol-function (random-from-seq *cl-function-symbols*))) (5 (symbol-function (random-from-seq *cl-accessor-symbols*))) (1 #'(lambda (x) (cons x x))) (1 (eval '#'(lambda (x) (cons x x)))))) (defmethod make-random-element-of-type ((type symbol)) (case type ((single-float short-float double-float long-float) (make-random-element-of-type (list type))) ((base-char standard-char) (random-from-seq +standard-chars+)) ;; Default ((atom t *) (make-random-element-of-type (random-from-seq #(real symbol boolean integer unsigned-byte #-ecl complex character (string 1) (bit-vector 1))))) (t (call-next-method type)) )) (defun make-random-character () (loop when (rcase (3 (random-from-seq +standard-chars+)) (3 (code-char (random (min 256 char-code-limit)))) (1 (code-char (random (min (ash 1 16) char-code-limit)))) (1 (code-char (random (min (ash 1 24) char-code-limit)))) (1 (code-char (random char-code-limit)))) return it)) (defun make-random-array-element-type () ;; Create random types for array elements (let ((bits 40)) (rcase (2 t) (1 'symbol) (1 `(unsigned-byte ,(1+ (random bits)))) (1 `(signed-byte ,(1+ (random bits)))) (1 'character) (1 'base-char) (1 'bit) (1 (random-from-seq #(short-float single-float double-float long-float)))))) (defun make-random-vector (etype-spec size-spec &key simple) (let* ((etype (if (eql etype-spec '*) (make-random-array-element-type) etype-spec)) (size (if (eql size-spec '*) (random (ash 1 (+ 2 (random 8)))) size-spec)) (displaced? (and (not simple) (coin 4))) (displaced-size (+ size (random (max 6 size)))) (displacement (random (1+ (- displaced-size size)))) (adjustable (and (not simple) (coin 3))) (fill-pointer (and (not simple) (rcase (3 nil) (1 t) (1 (random (1+ size))))))) (assert (<= size 1000000)) (if displaced? (let ((displaced-vector (make-array displaced-size :element-type etype :initial-contents (loop repeat displaced-size collect (make-random-element-of-type etype))))) (make-array size :element-type etype :adjustable adjustable :fill-pointer fill-pointer :displaced-to displaced-vector :displaced-index-offset displacement)) (make-array size :element-type etype :initial-contents (loop repeat size collect (make-random-element-of-type etype)) :adjustable adjustable :fill-pointer fill-pointer )))) (defun make-random-array (etype-spec dim-specs &key simple) (when (eql dim-specs '*) (setq dim-specs (random 10))) (when (numberp dim-specs) (setq dim-specs (make-list dim-specs :initial-element '*))) (let* ((etype (if (eql etype-spec '*) t etype-spec)) (rank (length dim-specs)) (dims (loop for dim in dim-specs collect (if (eql dim '*) (1+ (random (ash 1 (floor 9 rank)))) dim)))) (assert (<= (reduce '* dims :initial-value 1) 1000000)) (assert (<= (reduce 'max dims :initial-value 1) 1000000)) (make-array dims :element-type etype :initial-contents (labels ((%init (dims) (if (null dims) (make-random-element-of-type etype) (loop repeat (car dims) collect (%init (cdr dims)))))) (%init dims)) :adjustable (and (not simple) (coin)) ;; Do displacements later ))) (defun most-negative-float (float-type-symbol) (ecase float-type-symbol (short-float most-negative-short-float) (single-float most-negative-single-float) (double-float most-negative-double-float) (long-float most-negative-long-float) (float (min most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float)))) (defun most-positive-float (float-type-symbol) (ecase float-type-symbol (short-float most-positive-short-float) (single-float most-positive-single-float) (double-float most-positive-double-float) (long-float most-positive-long-float) (float (max most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)))) (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 *compile-using-defgeneric* nil "If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form for the function and compile that.") (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) ((or error serious-condition) #'(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)) (clf (cdr lambda-form))) (prog1 (cond (*compile-using-defun* (fmakunbound opt-defun-name) (eval `(defun ,opt-defun-name ,@clf)) (compile opt-defun-name) (symbol-function opt-defun-name)) (*compile-using-defgeneric* (fmakunbound opt-defun-name) (eval `(defgeneric ,opt-defun-name ,(car clf))) (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf)) ,@(cdr clf))) (compile opt-defun-name) (symbol-function opt-defun-name)) (t (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 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 values) (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))))))) ((expt rationalize rational numberator denominator) (try 0) (mapc try-fn args) (prune-fn form try-fn)) ((coerce) (try 0) (try (car args)) (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr 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))) (try arg2.2) (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))) ((incf decf) (try 0) (assert (member (length form) '(2 3))) (try (first args)) (when (> (length args) 1) (try (second args)) (try `(,op ,(first args))) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form))))))) ((setq setf shiftf) (try 0) ;; Assumes only one assignment (assert (= (length form) 3)) (try (first args)) (try (second args)) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form)))))) ((rotatef) (try 0) (mapc try-fn (cdr 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 (and (listp (car case)) (> (length (car case)) 1)) ;; try removing constants (loop for i below (length (car case)) do (funcall try-fn `((,@(subseq (car case) 0 i) ,@(subseq (car case) (1+ i))) ,@(cdr case))))) (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)) ) (when (> body-len 1) (funcall try-fn `(,op ,binding-list ,@(cdr body)))) ;; 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)))) |# (when (>= len 1) (let ((val-form (cadar binding-list))) (when (consp val-form) (case (car val-form) ((make-array) (let ((init (getf (cddr val-form) :initial-element))) (when init (funcall try-fn init)))) ((cons) (funcall try-fn (cadr val-form)) (funcall try-fn (caddr 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)))) ;; Prune off unused variable (when (and binding-list (not (rest binding-list)) (let ((name (caar binding-list))) (and (symbolp name) (not (find-if-subtree #'(lambda (x) (eq x name)) body))))) (funcall try-fn `(progn ,@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 incf decf) :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.7.1/ansi-tests/PaxHeaders/format-f.lsp0000644000000000000000000000013214542551762015704 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.557789469 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-f.lsp0000644000175000017500000004031714542551762015307 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 07:14:17 2004 ;;;; Contains: Tests of the ~f format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Equivalent to PRIN1 for 0 or (abs x) in range [10^-3,10^7). (deftest format.f.1 (let ((*print-readably* nil) (fn (formatter "~F"))) (loop for type in '(short-float single-float double-float long-float short-float single-float double-float long-float) for x in '(0.0s0 0.0f0 0.0d0 0.0l0 -0.0s0 -0.0f0 -0.0d0 -0.0l0) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) (formatter-call-to-string fn x)) unless (and (string= s1 s2) (string= s1 s3)) collect (list x type s1 s2 s3))) nil) (deftest format.f.2 (let ((*print-readably* nil) (fn (formatter "~f"))) (loop for i = (random 4) for type = (elt #(short-float single-float double-float long-float) i) for x = (expt (coerce 10 type) (- (random 10.0s0) 3)) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) (formatter-call-to-string fn x)) repeat 1000 when (and (<= 1/1000 x) (< x 10000000) (or (not (string= s1 s2)) (not (string= s1 s3)))) collect (list x s1 s2 s3))) nil) (deftest format.f.3 (let ((*print-readably* nil) (fn (formatter "~F"))) (loop for i = (random 4) for type = (elt #(short-float single-float double-float long-float) i) for x = (- (expt (coerce 10 type) (- (random 10.0s0) 3))) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) (formatter-call-to-string fn x)) repeat 1000 when (and (>= -1/1000 x) (> x -10000000) (not (and (string= s1 s2) (string= s1 s3)))) collect (list x s1 s2 s3))) nil) (deftest format.f.4 (let ((fn (formatter "~3f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~3f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "1.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.5 (let ((fn (formatter "~2f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "1.") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.6 (let ((fn (formatter "~4F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~4F" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s " 1.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.7 (let ((fn (formatter "~4@F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~4@f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "+1.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.8 (let ((fn (formatter "~3@F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~3@F" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "+1.") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.9 (let ((fn (formatter "~4f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) for s = (format nil "~4f" (- x)) for s2 = (formatter-call-to-string fn (- x)) unless (and (string= s "-1.0") (string= s s2)) collect (list (- x) s s2))) nil) (deftest format.f.10 (let ((fn (formatter "~3F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~3f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.5") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.11 (let ((fn (formatter "~4f"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s " 0.5") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.12 (let ((fn (formatter "~4,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.13 (let ((fn (formatter "~3,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~3,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s ".50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.14 (let ((fn (formatter "~2,1F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~2,1f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s ".5") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.15 (let ((fn (formatter "~4,2@F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4,2@f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "+.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.16 (let ((fn (formatter "~2,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~2,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s ".50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.17 (let ((fn (formatter "~,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.18 (let ((fn (formatter "~,2F"))) (loop for xn in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for x = (- xn) for s = (format nil "~,2f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "-0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.19 (let ((fn (formatter "~4,2,-1F"))) (loop for x in (remove-duplicates '(5 5.0s0 5.0f0 5.0d0 5.0l0)) for s = (format nil "~4,2,-1f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.20 (let ((fn (formatter "~4,2,0F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) for s = (format nil "~4,2,0f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.21 (let ((fn (formatter "~4,2,1f"))) (loop for x in (remove-duplicates '(1/20 0.05s0 0.05f0 0.05d0 0.05l0)) for s = (format nil "~4,2,1f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "0.50") (string= s s2)) collect (list x s s2))) nil) ;;; overflow (deftest format.f.22 (let ((fn (formatter "~5,1,,'*F"))) (loop for x in (remove-duplicates '(1000 1000.0s0 1000.0f0 1000.0d0 1000.0l0)) for s = (format nil "~5,1,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "*****") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.23 (let ((fn (formatter "~5,1,,'*f"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~5,1,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "100.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.24 (let ((fn (formatter "~4,0,,'*F"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~4,0,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "100.") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.25 (let ((fn (formatter "~1,1,,f"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~1,1,,f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "100.0") (string= s s2)) collect (list x s s2))) nil) ;;; padchar (deftest format.f.26 (let ((fn (formatter "~10,1,,f"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~10,1,,f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s " 100.0") (string= s s2)) collect (list x s s2))) nil) (deftest format.f.27 (let ((fn (formatter "~10,1,,,'*F"))) (loop for x in (remove-duplicates '(100 100.0s0 100.0f0 100.0d0 100.0l0)) for s = (format nil "~10,1,,,'*f" x) for s2 = (formatter-call-to-string fn x) unless (and (string= s "*****100.0") (string= s s2)) collect (list x s s2))) nil) ;;; v parameters (deftest format.f.28 (let ((fn (formatter "~VF"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.29 (let ((fn (formatter "~,vf"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.30 (let ((fn (formatter "~,,Vf"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.31 (let ((fn (formatter "~,,,vF"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,,,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) (deftest format.f.32 (let ((fn (formatter "~,,,,VF"))) (loop for x = (random 100.0) for s1 = (format nil "~f" x) for s2 = (format nil "~,,,,vf" nil x) for s3 = (formatter-call-to-string fn nil x) repeat 100 unless (and (string= s1 s2) (string= s2 s3)) collect (list x s1 s2 s3))) nil) ;;; Randomized tests #| (deftest format.f.33 (let ((bound (if (> 10000000 most-positive-short-float) most-positive-short-float (coerce 10000000 'short-float)))) (loop for d = (random 10) for w = (+ 1 d (random 10)) for x = (random bound) for xr = (rational x) for s = (format nil "~v,vf" w d x) for sr = (decode-fixed-decimal-string s) for eps = (expt 1/10 d) for abs-xr-sr = (abs (- xr sr)) for abs-xr-sr-hi = (abs (- xr (+ sr eps))) for abs-xr-sr-lo = (abs (- xr (- sr eps))) repeat 100 unless (and (<= abs-xr-sr abs-xr-sr-hi) (<= abs-xr-sr abs-xr-sr-lo)) collect (list d w x xr s sr eps abs-xr-sr abs-xr-sr-hi abs-xr-sr-lo))) nil) |# (deftest format.f.34 (with-standard-io-syntax (let ((*read-default-float-format* 'short-float)) (loop for i from (- 1 (ash 1 13)) below (ash 1 13) for sf = (coerce i 'short-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.35 (with-standard-io-syntax (let ((*read-default-float-format* 'single-float)) (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) for sf = (coerce i 'single-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.36 (with-standard-io-syntax (let ((*read-default-float-format* 'double-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'double-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.37 (with-standard-io-syntax (let ((*read-default-float-format* 'long-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'long-float) for s = (format nil "~f" sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf s i2)))) nil) (deftest format.f.38 (funcall (compile nil '(lambda () (with-standard-io-syntax (let ((*read-default-float-format* 'short-float) (total 0) (len 0)) (loop for i from (- 1 (ash 1 13)) below (ash 1 13) unless (zerop i) nconc (loop for sf = (coerce i 'short-float) for w = (random 8) for d = (random 4) for s = (format nil "~v,vf" w d sf) for i2 = (ignore-errors (floor (read-from-string s))) repeat 5 ; do (print (list w d s i i2)) unless (eql i i2) do (incf total) and collect (list i sf w d s i2)) when (> total 100) collect "count limit exceeded" and do (loop-finish))))))) nil) (deftest format.f.39 (with-standard-io-syntax (let ((*read-default-float-format* 'single-float)) (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) for sf = (coerce i 'single-float) for w = (and (coin) (random 16)) for d = (random 4) for s = (format nil "~v,vf" w d sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf w d s i2)))) nil) (deftest format.f.40 (with-standard-io-syntax (let ((*read-default-float-format* 'double-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'double-float) for w = (and (coin) (random 30)) for d = (random 6) for s = (format nil "~v,vf" w d sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf w d s i2)))) nil) (deftest format.f.41 (with-standard-io-syntax (let ((*read-default-float-format* 'long-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) for sf = (coerce i 'long-float) for w = (and (coin) (random 30)) for d = (random 6) for s = (format nil "~v,vf" w d sf) for i2 = (floor (read-from-string s)) repeat 2000 unless (or (zerop i) (eql i i2)) collect (list i sf w d s i2)))) nil) (deftest format.f.42 (let ((chars +standard-chars+)) (loop for k = (and (coin) (random 6)) for x = (random (/ (random-from-seq #(#.(coerce (* 32 (1- (ash 1 13))) 'short-float) #.(coerce (* 256 (1- (ash 1 24))) 'single-float) #.(coerce (* 256 (1- (ash 1 50))) 'double-float) #.(coerce (* 256 (1- (ash 1 50))) 'long-float))) (if k (expt 10 k) 1))) for w = (and (coin) (random 30)) for d = (and (coin) (random 10)) for overflowchar = (and (coin) (random-from-seq chars)) for padchar = (and (coin) (random-from-seq chars)) for f1 = (concatenate 'string "~" (if w (format nil "~d" w) "") "," (if d (format nil "~d" d) "") "," (if k (format nil "~d" k) "") "," (if overflowchar (format nil "'~c" overflowchar) "") "," (if padchar (format nil "'~c" padchar) "") (string (random-from-seq "fF"))) for s1 = (format nil f1 x) for s2 = (format nil "~v,v,v,v,vf" w d k overflowchar padchar x) repeat 2000 unless (string= s1 s2) collect (list x w d k overflowchar padchar f1 s1 s2))) nil) ;;; This failed in sbcl 0.8.12.25 (def-format-test format.f.43 "~,,,,',f" (0.0) "0.0") (deftest format.f.44 (loop for i from 0 below (min #x10000 char-code-limit) for x = 2312.9817 for c = (code-char i) for f1 = (and c (format nil "~~,,,,'~cf" c)) for s1 = (and c (ignore-errors (format nil f1 x))) for s2 = (and c (format nil "~,,,,vf" c x)) unless (equal s1 s2) collect (list i c f1 s1 s2)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/realpart.lsp0000644000000000000000000000013114542551763016003 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.557789469 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/realpart.lsp0000644000175000017500000000200214542551763015374 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 07:41:15 2003 ;;;; Contains: Tests of REALPART (in-package :cl-test) (deftest realpart.error.1 (signals-error (realpart) program-error) t) (deftest realpart.error.2 (signals-error (realpart #c(1.0 2.0) nil) program-error) t) (deftest realpart.error.3 (check-type-error #'realpart #'numberp) nil) (deftest realpart.1 (loop for x in *reals* for c = (complex x 0) for rp = (realpart c) unless (eql x rp) collect (list x c rp)) nil) (deftest realpart.2 (loop for x in *reals* for c = (complex x 1) for rp = (realpart c) unless (eql x rp) collect (list x c rp)) nil) (deftest realpart.3 (loop for x in *reals* for c = (complex x x) for rp = (realpart c) unless (eql x rp) collect (list x c rp)) nil) ;;; Should move this to complex.lsp (deftest realpart.4 (loop for c in *complexes* for rp = (realpart c) for ip = (imagpart c) for c2 = (complex rp ip) unless (eql c c2) collect (list c rp ip c2)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/pairlis.lsp0000644000000000000000000000013114542551763015634 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.557789469 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pairlis.lsp0000644000175000017500000000443214542551763015236 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:30:55 2003 ;;;; Contains: Tests of PAIRLIS (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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) (def-fold-test pairlis.fold.1 (pairlis '(a b) '(c d))) ;;; Error tests (deftest pairlis.error.1 (signals-error (pairlis) program-error) t) (deftest pairlis.error.2 (signals-error (pairlis nil) program-error) t) (deftest pairlis.error.3 (signals-error (pairlis nil nil nil nil) program-error) t) (deftest pairlis.error.4 (signals-error (pairlis 'a '(1)) type-error) t) (deftest pairlis.error.5 (signals-error (pairlis '(a) 'b) type-error) t) (deftest pairlis.error.6 (signals-error (pairlis '(a . b) '(c . d)) type-error) t) (deftest pairlis.error.7 (check-type-error #'(lambda (x) (pairlis x '(a b))) #'listp) nil) (deftest pairlis.error.8 (check-type-error #'(lambda (x) (pairlis '(a b) x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/subseq-aux.lsp0000644000000000000000000000013214542551763016267 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.557789469 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subseq-aux.lsp0000644000175000017500000001545314542551763015675 0ustar00cammcamm;-*- 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 (elt x i) 'b)) (unless (every #'(lambda (e) (eqt e 'a)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2)) (unless (every #'(lambda (e) (eqlt e 1)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0d0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0s0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt x i) 2.0l0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt 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 (elt s1 i)) 'bit-vector))))))) gcl-2.7.1/ansi-tests/PaxHeaders/incf.lsp0000644000000000000000000000013114542551762015107 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.557789469 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/incf.lsp0000644000175000017500000000707314542551762014515 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 20:01:15 2003 ;;;; Contains: Tests of INCF (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest incf.1 (let ((x 12)) (values (incf x) x)) 13 13) (deftest incf.2 (let ((x 3.0s0)) (values (incf x) x)) 4.0s0 4.0s0) (deftest incf.3 (let ((x 19.0f0)) (values (incf x) x)) 20.0f0 20.0f0) (deftest incf.4 (let ((x 813.0d0)) (values (incf x) x)) 814.0d0 814.0d0) (deftest incf.5 (let ((x -17.0l0)) (values (incf x) x)) -16.0l0 -16.0l0) (deftest incf.6 (loop for x from 1 to 5 collect (let ((y x)) (list (incf y) y))) ((2 2) (3 3) (4 4) (5 5) (6 6))) (deftest incf.7 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) collect (let ((y x)) (list (incf y) y))) ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) (deftest incf.8 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0f0) for y = (complex x 0) for z = (incf y) for x1c = (complex (1+ x) 0) unless (and (eql y z) (eql x1c y)) collect (list x y z x1c)) nil) (deftest incf.9 (let ((x most-positive-fixnum)) (values (incf x) x)) #.(1+ most-positive-fixnum) #.(1+ most-positive-fixnum)) (deftest incf.10 (let ((x (1+ most-positive-fixnum))) (values (incf x) x)) #.(+ 2 most-positive-fixnum) #.(+ 2 most-positive-fixnum)) (deftest incf.11 (loop for x in *numbers* unless (let* ((y x) (z (incf y))) (and (eql y (1+ x)) (eql y z))) collect x) nil) ;;; Increment by other than 1 (deftest incf.12 (loop for x in *numbers* unless (let* ((y x) (z (incf y 0))) (and (eql x y) (eql y z))) collect x) nil) (deftest incf.13 (loop for x in *numbers* nconc (loop for r = (random-from-interval 1000000) repeat 100 when (let* ((y x) (z (incf y r))) (and (not (and (eql (+ x r) y) (eql y z))) (list x y r))) collect it)) nil) (deftest incf.14 (let ((x 1)) (values (incf x 0.0s0) x)) 1.0s0 1.0s0) (deftest incf.15 (let ((x 1)) (values (incf x 0.0f0) x)) 1.0f0 1.0f0) (deftest incf.16 (let ((x 2)) (values (incf x 0.0d0) x)) 2.0d0 2.0d0) (deftest incf.17 (let ((x 10)) (values (incf x 0.0l0) x)) 10.0l0 10.0l0) (deftest incf.18 (let ((x 1)) (values (incf x #c(0.0s0 0.0s0)) x)) #c(1.0s0 0.0s0) #c(1.0s0 0.0s0)) (deftest incf.19 (let ((x 1)) (values (incf x #c(0.0f0 2.0f0)) x)) #c(1.0f0 2.0f0) #c(1.0f0 2.0f0)) (deftest incf.20 (let ((x 1)) (values (incf x #c(0.0d0 2.0d0)) x)) #c(1.0d0 2.0d0) #c(1.0d0 2.0d0)) (deftest incf.21 (let ((x 1)) (values (incf x #c(0.0l0 -2.0l0)) x)) #c(1.0l0 -2.0l0) #c(1.0l0 -2.0l0)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest incf.22 (macrolet ((%m (z) z)) (let ((x 2)) (values (incf (expand-in-current-env (%m x))) x))) 3 3) (deftest incf.23 (macrolet ((%m (z) z)) (let ((x 2)) (values (incf x (expand-in-current-env (%m 4))) x))) 6 6) (deftest incf.order.2 (let ((a (vector 1 2 3 4)) (i 0) x y z) (values (incf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0)) (progn (setf z (incf i)) 17)) i x y z a)) 18 3 1 2 3 #(18 2 3 4)) (deftest incf.order.3 (let ((a (vector 10 2 3 4)) (i 0) x y) (values (incf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0))) i x y a)) 11 2 1 2 #(11 2 3 4)) (deftest incf.order.4 (let ((x 0)) (progn "See CLtS 5.1.3" (values (incf x (setf x 1)) x))) 2 2) gcl-2.7.1/ansi-tests/PaxHeaders/syntax.lsp0000644000000000000000000000013114542551763015517 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.557789469 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/syntax.lsp0000644000175000017500000007373314542551763015133 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 2 08:12:51 2005 ;;;; Contains: Tests of standard syntax (in-package :cl-test) (compile-and-load "reader-aux.lsp") (def-syntax-test syntax.whitespace.1 ;; Check that various standard or semistandard characters are whitespace[2] (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names for c = (name-char name) nconc (when c (let* ((s (concatenate 'string (string c) "123")) (val (read-from-string s))) (unless (eql val 123) (list (list name c s val))))))) nil) (def-syntax-test syntax.constituent.1 ;; Tests of various characters that they are constituent characters, ;; and parse to symbols (let ((chars (concatenate 'string "!$%&*<=>?@[]^_-{}+/" "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) (loop for c across chars for s = (string c) for sym = (read-from-string s) unless (string= (symbol-name sym) (string-upcase s)) collect (list c sym))) nil) ;;; Backspace is an invalid constituent character (def-syntax-test syntax.backspace.invalid (let ((c (name-char "Backspace"))) (if (not c) t (eval `(signals-error (read-from-string (string ,c)) reader-error)))) t) ;;; Rubout is an invalid constituent character (def-syntax-test syntax.rubout.invalid (let ((c (name-char "Rubout"))) (if (not c) t (eval `(signals-error (read-from-string (string ,c)) reader-error)))) t) ;;; Digits are alphabetic if >= the read base (def-syntax-test syntax.digits.alphabetic.1 (loop for base from 2 to 9 nconc (let ((*read-base* base)) (loop for digit-val from base to 9 for c = (elt "0123456789" digit-val) for s = (string c) for val = (read-from-string s) unless (and (symbolp val) (string= s (symbol-name val))) collect (list base digit-val c s val)))) nil) ;;; Reading escaped characters (def-syntax-test syntax.escaped.1 (loop for c across +standard-chars+ for s0 = (string c) for s = (concatenate 'string "\\" s0) for sym = (read-from-string s) unless (and (symbolp sym) (string= (symbol-name sym) s0)) collect (list c s0 s sym)) nil) (def-syntax-test syntax.escaped.2 (let ((count 0)) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) for s0 = (and c (string c)) for s = (and c (concatenate 'string "\\" s0)) for sym = (and c (read-from-string s)) unless (or (not c) (and (symbolp sym) (string= (symbol-name sym) s0))) collect (progn (when (> (incf count) 100) (loop-finish)) (list i c s0 s sym)))) nil) (def-syntax-test syntax.escaped.3 (loop for i = (random (min char-code-limit (ash 1 24))) for c = (code-char i) for s0 = (and c (string c)) for s = (and c (concatenate 'string "\\" s0)) for sym = (and c (read-from-string s)) repeat 1000 unless (or (not c) (and (symbolp sym) (string= (symbol-name sym) s0))) collect (list i c s0 s sym)) nil) (def-syntax-test syntax.escaped.4 (loop for c across +standard-chars+ for bad = (find c "\\|") for s0 = (string c) for s = (concatenate 'string "|" s0 "|") for sym = (and (not bad) (read-from-string s)) unless (or bad (and (symbolp sym) (string= (symbol-name sym) s0))) collect (list c s0 s sym)) nil) (def-syntax-test syntax.escaped.5 (let ((count 0)) (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) for bad = (or (not c) (find c "\\|")) for s0 = (and c (string c)) for s = (and c (concatenate 'string "|" s0 "|")) for sym = (and c (not bad) (read-from-string s)) unless (or bad (and (symbolp sym) (string= (symbol-name sym) s0))) collect (progn (when (> (incf count) 100) (loop-finish)) (list c s0 s sym)))) nil) (def-syntax-test syntax.escaped.6 (loop for i = (random (min char-code-limit (ash 1 24))) for c = (code-char i) for bad = (or (not c) (find c "\\|")) for s0 = (and c (string c)) for s = (and c (concatenate 'string "|" s0 "|")) for sym = (and (not bad) (read-from-string s)) repeat 1000 unless (or bad (and (symbolp sym) (string= (symbol-name sym) s0))) collect (list c s0 s sym)) nil) (def-syntax-test syntax.escape.whitespace.1 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page" "Rubout" "Backspace"))) (loop for name in names for c = (name-char name) nconc (when c (let* ((s (concatenate 'string "\\" (string c))) (val (read-from-string s))) (unless (eql val (intern (string c))) (list (list name c s val))))))) nil) ;;; ;;; CLtS appears to be inconsistent on the next test. ;;; Compare the definition of 'invalid' with the specification ;;; of the token reading algorithm. ;;; (def-syntax-test syntax.escape.whitespace.2 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names for c = (name-char name) nconc (when c (let* ((s (concatenate 'string "|" (string c) "|")) (val (read-from-string s))) (unless (eql val (intern (string c))) (list (list name c s val))))))) nil) #| (def-syntax-test syntax.multiple-escape.invalid.backspace (let ((c (name-char "Backspace"))) (or (not c) (let ((s (concatenate 'string "|" (string c) "|"))) (eval `(signals-error (read-from-string ',s) reader-error))))) t) (def-syntax-test syntax.multiple-escape.invalid.rubout (let ((c (name-char "Rubout"))) (or (not c) (let ((s (concatenate 'string "|" (string c) "|"))) (eval `(signals-error (read-from-string ',s) reader-error))))) t) |# ;;; Tests of #\ (def-syntax-test syntax.sharp-backslash.1 (loop for c across +standard-chars+ for s = (concatenate 'string "#\\" (string c)) for c2 = (read-from-string s) unless (eql c c2) collect (list c s c2)) nil) (def-syntax-test syntax.sharp-backslash.2 (let ((count 0)) (loop for i below (min 65536 char-code-limit) for c = (code-char i) for s = (and c (concatenate 'string "#\\" (string c))) for c2 = (and c (read-from-string s)) unless (eql c c2) collect (progn (when (> (incf count) 100) (loop-finish)) (list c s c2)))) nil) (def-syntax-test syntax.sharp-backslash.3 (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for s = (and c (concatenate 'string "#\\" (string c))) for c2 = (and c (read-from-string s)) repeat 1000 unless (eql c c2) collect (list i c s c2)) nil) (def-syntax-test syntax.sharp-backslash.4 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (loop for s in '("SPACE" "NEWLINE" "TAB" "RUBOUT" "BACKSPACE" "PAGE" "LINEFEED" "RETURN") for c = (name-char s) unless (or (null c) (and (eql (%f s) c) (eql (%f (string-downcase s)) c) (eql (%f (string-capitalize s)) c))) collect (list s c))) nil) (def-syntax-test syntax.sharp-backslash.5 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for c across +standard-chars+ for name = (char-name c) unless (or (null name) (string/= "" (string-trim good-chars name)) (and (eql (%f name) c) (eql (%f (string-downcase name)) c) (eql (%f (string-upcase name)) c) (eql (%f (string-capitalize name)) c))) collect (list c name)))) nil) (def-syntax-test syntax.sharp-backslash.6 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for i below (min 65536 char-code-limit) for c = (code-char i) for name = (and c (char-name c)) unless (or (null name) (string/= "" (string-trim good-chars name)) (and (eql (%f name) c) (eql (%f (string-downcase name)) c) (eql (%f (string-upcase name)) c) (eql (%f (string-capitalize name)) c))) collect (list i c name)))) nil) (def-syntax-test syntax.sharp-backslash.7 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for name = (and c (char-name c)) repeat 1000 unless (or (null name) (string/= "" (string-trim good-chars name)) (and (eql (%f name) c) (eql (%f (string-downcase name)) c) (eql (%f (string-upcase name)) c) (eql (%f (string-capitalize name)) c))) collect (list i c name)))) nil) ;;; Tests of #' (def-syntax-test syntax.sharp-quote.1 (read-from-string "#'X") (function |X|) 3) (def-syntax-test syntax.sharp-quote.2 (read-from-string "#':X") (function :|X|) 4) (def-syntax-test syntax.sharp-quote.3 (read-from-string "#'17") (function 17) 4) (def-syntax-test syntax.sharp-quote.error.1 (signals-error (read-from-string "#'") end-of-file) t) (def-syntax-test syntax.sharp-quote.error.2 (signals-error (read-from-string "(#'" nil nil) end-of-file) t) ;;; Tess of #(...) (def-syntax-vector-test syntax.sharp-left-paren.1 "#()") (def-syntax-vector-test syntax.sharp-left-paren.2 "#0()") (def-syntax-vector-test syntax.sharp-left-paren.3 "#(a)" a) (def-syntax-vector-test syntax.sharp-left-paren.4 "#(a b c)" a b c) (def-syntax-vector-test syntax.sharp-left-paren.5 "#2(a)" a a) (def-syntax-vector-test syntax.sharp-left-paren.6 "#5(a b)" a b b b b) (def-syntax-vector-test syntax.sharp-left-paren.7 "#5(a b c d e)" a b c d e) (def-syntax-vector-test syntax.sharp-left-paren.8 "#9(a b c d e)" a b c d e e e e e) (def-syntax-test syntax.sharp-left-paren.9 (let ((*read-base* 2)) (read-from-string "#10(a)")) #(a a a a a a a a a a) 6) (def-syntax-test syntax.sharp-left-paren.error.1 (signals-error (read-from-string "#(") end-of-file) t) (def-syntax-test syntax.sharp-left-paren.error.2 (signals-error (read-from-string "(#(" nil nil) end-of-file) t) ;;; Tests of #* (def-syntax-bit-vector-test syntax.sharp-asterisk.1 "#*") (def-syntax-bit-vector-test syntax.sharp-asterisk.2 "#0*") (def-syntax-bit-vector-test syntax.sharp-asterisk.3 "#1*0" 0) (def-syntax-bit-vector-test syntax.sharp-asterisk.4 "#1*1" 1) (def-syntax-bit-vector-test syntax.sharp-asterisk.5 "#2*1" 1 1) (def-syntax-bit-vector-test syntax.sharp-asterisk.6 "#2*0" 0 0) (def-syntax-bit-vector-test syntax.sharp-asterisk.7 "#5*010" 0 1 0 0 0) (def-syntax-bit-vector-test syntax.sharp-asterisk.8 "#7*0101" 0 1 0 1 1 1 1) (def-syntax-bit-vector-test syntax.sharp-asterisk.9 "#10*01010" 0 1 0 1 0 0 0 0 0 0) (def-syntax-test syntax.sharp-asterisk.10 (let ((*read-base* 3)) (read-from-string "#10*01")) #*0111111111 6) (def-syntax-test syntax.sharp-asterisk.11 (let ((*read-suppress* t)) (values (read-from-string "#1* "))) nil) (def-syntax-test syntax.sharp-asterisk.12 (let ((*read-suppress* t)) (values (read-from-string "#1*00"))) nil) (def-syntax-test syntax.sharp-asterisk.13 (let ((*read-suppress* t)) (values (read-from-string "#*012"))) nil) (def-syntax-test syntax.sharp-asterisk.error.1 (signals-error (read-from-string "#1* X") reader-error) t) (def-syntax-test syntax.sharp-asterisk.error.2 (signals-error (read-from-string "#2*011") reader-error) t) (def-syntax-test syntax.sharp-asterisk.error.3 (signals-error (read-from-string "#*012") reader-error) t) ;;; Tests of #: ... ; (def-syntax-unintern-test syntax.sharp-colon.1 "") ; (def-syntax-unintern-test syntax.sharp-colon.2 "#") (def-syntax-unintern-test syntax.sharp-colon.3 "a") (def-syntax-unintern-test syntax.sharp-colon.4 "A") (def-syntax-unintern-test syntax.sharp-colon.5 "NIL") (def-syntax-unintern-test syntax.sharp-colon.6 "T") (def-syntax-unintern-test syntax.sharp-colon.7 ".") ;;; Tests of #. (def-syntax-test syntax.sharp-dot.1 (read-from-string "#.(+ 1 2)") 3 9) (def-syntax-test syntax.sharp-dot.2 (read-from-string "#.'X") X 4) (def-syntax-test syntax.sharp-dot.error.1 (signals-error (read-from-string "#.") end-of-file) t) (def-syntax-test syntax.sharp-dot.error.2 (signals-error (read-from-string "(#." nil nil) end-of-file) t) (def-syntax-test syntax.sharp-dot.error.3 (signals-error (let ((*read-eval* nil)) (read-from-string "#.1")) reader-error) t) ;;; Tests of #B (def-syntax-test syntax.sharp-b.1 (read-from-string "#b0") 0 3) (def-syntax-test syntax.sharp-b.2 (read-from-string "#B1") 1 3) (def-syntax-test syntax.sharp-b.3 (read-from-string "#b101101") 45 8) (def-syntax-test syntax.sharp-b.4 (read-from-string "#B101101") 45 8) (def-syntax-test syntax.sharp-b.5 (read-from-string "#b010001/100") 17/4 12) (def-syntax-test syntax.sharp-b.6 (read-from-string "#b-10011") -19 8) (def-syntax-test syntax.sharp-b.7 (read-from-string "#B-1/10") -1/2 7) (def-syntax-test syntax.sharp-b.8 (read-from-string "#B-0/10") 0 7) (def-syntax-test syntax.sharp-b.9 (read-from-string "#b0/111") 0 7) (def-syntax-test syntax.sharp-b.10 (let ((*read-eval* nil)) (read-from-string "#b-10/11")) -2/3 8) ;;; Tests of #O (def-syntax-test syntax.sharp-o.1 (read-from-string "#o0") 0 3) (def-syntax-test syntax.sharp-o.2 (read-from-string "#O7") 7 3) (def-syntax-test syntax.sharp-o.3 (read-from-string "#o10") 8 4) (def-syntax-test syntax.sharp-o.4 (read-from-string "#O011") 9 5) (def-syntax-test syntax.sharp-o.5 (read-from-string "#o-0") 0 4) (def-syntax-test syntax.sharp-o.6 (read-from-string "#O-1") -1 4) (def-syntax-test syntax.sharp-o.7 (read-from-string "#O11/10") 9/8 7) (def-syntax-test syntax.sharp-o.8 (read-from-string "#o-1/10") -1/8 7) (def-syntax-test syntax.sharp-o.9 (read-from-string "#O0/10") 0 6) (def-syntax-test syntax.sharp-o.10 (let ((*read-eval* nil)) (read-from-string "#o-10/11")) -8/9 8) ;;; Tests of #X (def-syntax-test syntax.sharp-x.1 (read-from-string "#x0") 0 3) (def-syntax-test syntax.sharp-x.2 (read-from-string "#X1") 1 3) (def-syntax-test syntax.sharp-x.3 (read-from-string "#xa") 10 3) (def-syntax-test syntax.sharp-x.4 (read-from-string "#Xb") 11 3) (def-syntax-test syntax.sharp-x.5 (read-from-string "#XC") 12 3) (def-syntax-test syntax.sharp-x.6 (read-from-string "#xD") 13 3) (def-syntax-test syntax.sharp-x.7 (read-from-string "#xe") 14 3) (def-syntax-test syntax.sharp-x.8 (read-from-string "#Xf") 15 3) (def-syntax-test syntax.sharp-x.9 (read-from-string "#x10") 16 4) (def-syntax-test syntax.sharp-x.10 (read-from-string "#X1ab") 427 5) (def-syntax-test syntax.sharp-x.11 (read-from-string "#x-1") -1 4) (def-syntax-test syntax.sharp-x.12 (read-from-string "#X-0") 0 4) (def-syntax-test syntax.sharp-x.13 (read-from-string "#xa/B") 10/11 5) (def-syntax-test syntax.sharp-x.14 (read-from-string "#X-1/1c") -1/28 7) (def-syntax-test syntax.sharp-x.15 (let ((*read-eval* nil)) (read-from-string "#x-10/11")) -16/17 8) ;;; Tests of #nR (def-syntax-test syntax.sharp-r.1 (loop for i = (random (ash 1 (+ 2 (random 32)))) for base = (+ 2 (random 35)) for s = (write-to-string i :radix nil :base base :readably nil) for c = (random-from-seq "rR") for s2 = (format nil "#~d~c~a" base c s) for s3 = (rcase (1 (string-upcase s2)) (1 (string-downcase s2)) (1 (string-capitalize s2)) (1 s2)) for base2 = (+ 2 (random 35)) for vals = (let ((*read-base* base2)) (multiple-value-list (read-from-string s3))) repeat 1000 unless (equal vals (list i (length s3) )) collect (list i base s c s2 s3 base2 vals)) nil) (def-syntax-test syntax.sharp-r.2 (read-from-string "#2r0") 0 4) (def-syntax-test syntax.sharp-r.3 (read-from-string "#36r0") 0 5) (def-syntax-test syntax.sharp-r.4 (read-from-string "#29R-0") 0 6) (def-syntax-test syntax.sharp-r.5 (read-from-string "#23r-1") -1 6) (def-syntax-test syntax.sharp-r.6 (read-from-string "#17r11") 18 6) (def-syntax-test syntax.sharp-t.7 (read-from-string "#3r10/11") 3/4 8) (def-syntax-test syntax.sharp-t.8 (read-from-string "#5R-10/11") -5/6 9) ;;; Tests of #c (def-syntax-test syntax.sharp-c.1 (read-from-string "#c(1 1)") #.(complex 1 1) 7) (def-syntax-test syntax.sharp-c.2 (read-from-string "#C(1 0)") 1 7) (def-syntax-test syntax.sharp-c.3 (read-from-string "#c(0 1)") #.(complex 0 1) 7) (def-syntax-test syntax.sharp-c.4 (read-from-string "#c(-1/2 1)") #.(complex -1/2 1) 10) (def-syntax-test syntax.sharp-c.5 (read-from-string "#c (1 1)") #.(complex 1 1) 8) (def-syntax-test syntax.sharp-c.6 (loop for format in '(short-float single-float double-float long-float) for c = (let ((*read-default-float-format* format)) (read-from-string "#c(1.0 0.0)")) unless (eql c (complex (coerce 1 format) (coerce 0 format))) collect (list format c)) nil) (def-syntax-test syntax.sharp-c.7 (loop for format in '(short-float single-float double-float long-float) for c = (let ((*read-default-float-format* format)) (read-from-string "#C(0.0 1.0)")) unless (eql c (complex (coerce 0 format) (coerce 1 format))) collect (list format c)) nil) ;;; Tests of #a (def-syntax-array-test syntax.sharp-a.1 "#0anil" (make-array nil :initial-element nil)) (def-syntax-array-test syntax.sharp-a.2 "#0a1" (make-array nil :initial-element 1)) (def-syntax-array-test syntax.sharp-a.3 "#1a(1 2 3 5)" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.4 "#1a\"abcd\"" (make-array '(4) :initial-contents '(#\a #\b #\c #\d))) (def-syntax-array-test syntax.sharp-a.5 "#1a#1a(:a :b :c)" (make-array '(3) :initial-contents '(:a :b :c))) (def-syntax-array-test syntax.sharp-a.6 "#1a#.(coerce \"abcd\" 'simple-base-string)" (make-array '(4) :initial-contents '(#\a #\b #\c #\d))) (def-syntax-array-test syntax.sharp-a.7 "#1a#*000110" (make-array '(6) :initial-contents '(0 0 0 1 1 0))) (def-syntax-array-test syntax.sharp-a.8 "#1a#.(make-array 4 :element-type '(unsigned-byte 8) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.9 "#1a#.(make-array 4 :element-type '(unsigned-byte 4) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.10 "#1a#.(make-array 4 :element-type '(signed-byte 4) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.11 "#1a#.(make-array 4 :element-type '(signed-byte 8) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.12 "#1a#.(make-array 4 :element-type '(unsigned-byte 16) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.13 "#1a#.(make-array 4 :element-type '(signed-byte 16) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.14 "#1a#.(make-array 4 :element-type '(unsigned-byte 32) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.15 "#1a#.(make-array 4 :element-type '(signed-byte 32) :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.16 "#1a#.(make-array 4 :element-type 'fixnum :initial-contents '(1 2 3 5))" (make-array '(4) :initial-contents '(1 2 3 5))) (def-syntax-array-test syntax.sharp-a.17 "#1anil" (make-array '(0))) (def-syntax-array-test syntax.sharp-a.18 "#2anil" (make-array '(0 0))) (def-syntax-array-test syntax.sharp-a.19 "#2a((2))" (make-array '(1 1) :initial-element 2)) (def-syntax-array-test syntax.sharp-a.20 "#2a((1 2 3)(4 5 6))" (make-array '(2 3) :initial-contents #(#(1 2 3) #(4 5 6)))) (def-syntax-array-test syntax.sharp-a.21 "#2a#(#(1 2 3)#(4 5 6))" (make-array '(2 3) :initial-contents '((1 2 3) (4 5 6)))) (def-syntax-array-test syntax.sharp-a.22 "#2a\"\"" (make-array '(0 0))) (def-syntax-array-test syntax.sharp-a.23 "#2a#*" (make-array '(0 0))) (def-syntax-array-test syntax.sharp-a.24 "#1a#.(make-array '(10) :fill-pointer 5 :initial-element 17)" (make-array '(5) :initial-contents '(17 17 17 17 17))) (def-syntax-array-test syntax.sharp-a.25 "#1a#.(make-array '(5) :adjustable t :initial-element 17)" (make-array '(5) :initial-contents '(17 17 17 17 17))) (def-syntax-array-test syntax.sharp-a.26 "#1A#.(let ((x (make-array '(10) :adjustable t :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (make-array '(5) :displaced-to x :displaced-index-offset 2))" (make-array '(5) :initial-contents '(3 4 5 6 7))) ;;; Tests of #S (unless (find-class 'syntax-test-struct-1 nil) (defstruct syntax-test-struct-1 a b c)) (def-syntax-test syntax.sharp-s.1 (let ((v (read-from-string "#s(syntax-test-struct-1)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t nil nil nil) (def-syntax-test syntax.sharp-s.2 (let ((v (read-from-string "#S(syntax-test-struct-1 :a x :c y :b z)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z y) (def-syntax-test syntax.sharp-s.3 (let ((v (read-from-string "#s(syntax-test-struct-1 \"A\" x)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.4 (let ((v (read-from-string "#S(syntax-test-struct-1 #\\A x)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.5 (let ((v (read-from-string "#s(syntax-test-struct-1 :a x :a y)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.6 (let ((v (read-from-string "#S(syntax-test-struct-1 :a x :allow-other-keys 1)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x nil nil) (def-syntax-test syntax.sharp-s.7 (let ((v (read-from-string "#s(syntax-test-struct-1 :b z :allow-other-keys nil)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t nil z nil) (def-syntax-test syntax.sharp-s.8 (let ((v (read-from-string "#S(syntax-test-struct-1 :b z :allow-other-keys t :a x :foo bar)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z nil) (def-syntax-test syntax.sharp-s.9 (let ((v (read-from-string "#s(syntax-test-struct-1 a x c y b z :a :bad :b bad2 :c bad3)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z y) (def-syntax-test syntax.sharp-s.10 (let ((v (read-from-string "#S(syntax-test-struct-1 #:a x #:c y #:b z)"))) (values (notnot (typep v 'syntax-test-struct-1)) (syntax-test-struct-1-a v) (syntax-test-struct-1-b v) (syntax-test-struct-1-c v))) t x z y) ;; (Put more tests of this in the structure tests) ;;; Tests of #P (def-syntax-test syntax.sharp-p.1 (read-from-string "#p\"\"") #.(parse-namestring "") 4) (def-syntax-test syntax.sharp-p.2 (read-from-string "#P\"syntax.lsp\"") #.(parse-namestring "syntax.lsp") 14) (def-syntax-test syntax.sharp-p.3 (read-from-string "#P \"syntax.lsp\"") #.(parse-namestring "syntax.lsp") 15) (def-syntax-test syntax.sharp-p.4 (let ((*read-eval* nil)) (read-from-string "#p\"syntax.lsp\"")) #.(parse-namestring "syntax.lsp") 14) (def-syntax-test syntax.sharp-p.5 (read-from-string "#P#.(make-array '(10) :initial-contents \"syntax.lsp\" :element-type 'base-char)") #.(parse-namestring "syntax.lsp") 78) ;;; ## and #= (def-syntax-test syntax.sharp-circle.1 (let ((x (read-from-string "(#1=(17) #1#)"))) (assert (eq (car x) (cadr x))) x) ((17) (17))) (def-syntax-test syntax.sharp-circle.2 (let ((x (read-from-string "(#0=(17) #0#)"))) (assert (eq (car x) (cadr x))) x) ((17) (17))) (def-syntax-test syntax.sharp-circle.3 (let ((x (read-from-string "(#123456789123456789=(17) #123456789123456789#)"))) (assert (eq (car x) (cadr x))) x) ((17) (17))) (def-syntax-test syntax.sharp-circle.4 (let ((x (read-from-string "#1=(A B . #1#)"))) (assert (eq (cddr x) x)) (values (car x) (cadr x))) a b) (def-syntax-test syntax.sharp-circle.5 (let ((x (read-from-string "#1=#(A B #1#)"))) (assert (typep x '(simple-vector 3))) (assert (eq (elt x 2) x)) (values (elt x 0) (elt x 1))) a b) (def-syntax-test syntax.sharp-circle.6 (let ((x (read-from-string "((#1=(17)) #1#)"))) (assert (eq (caar x) (cadr x))) x) (((17)) (17))) (def-syntax-test syntax.sharp-circle.7 (let ((x (read-from-string "((#1=#2=(:x)) #1# #2#)"))) (assert (eq (caar x) (cadr x))) (assert (eq (caar x) (caddr x))) x) (((:x)) (:x) (:x))) ;;; #+ (def-syntax-test syntax.sharp-plus.1 (let ((*features* nil)) (read-from-string "#+X :bad :good")) :good 14) (def-syntax-test syntax.sharp-plus.2 (let ((*features* '(:a :x :b))) (read-from-string "#+X :good :bad")) :good 10) (def-syntax-test syntax.sharp-plus.3 (let ((*features* '(:a :x :b))) (read-from-string "#+:x :good :bad")) :good 11) (def-syntax-test syntax.sharp-plus.4 (let ((*features* '(:a :x :b))) (read-from-string "#+(and):good :bad")) :good 13) (def-syntax-test syntax.sharp-plus.5 (let ((*features* '(:a :x :b))) (read-from-string "#+(:and):good :bad")) :good 14) (def-syntax-test syntax.sharp-plus.6 (let ((*features* '(:a :x :b))) (read-from-string "#+(or) :bad :good")) :good 17) (def-syntax-test syntax.sharp-plus.7 (let ((*features* '(:a :x :b))) (read-from-string "#+(:or) :bad :good")) :good 18) (def-syntax-test syntax.sharp-plus.8 (let ((*features* '(x))) (read-from-string "#+X :bad :good")) :good 14) (def-syntax-test syntax.sharp-plus.9 (let ((*features* '(x))) (read-from-string "#+CL-TEST::X :good :bad")) :good 19) (def-syntax-test syntax.sharp-plus.10 (let ((*features* nil)) (read-from-string "#+(not x) :good :bad")) :good 16) (def-syntax-test syntax.sharp-plus.11 (let ((*features* '(:x))) (read-from-string "#+(not x) :bad :good")) :good 20) (def-syntax-test syntax.sharp-plus.12 (let ((*features* nil)) (read-from-string "#+(:not :x) :good :bad")) :good 18) (def-syntax-test syntax.sharp-plus.13 (let ((*features* '(:a :x :b))) (read-from-string "#+(and a b) :good :bad")) :good 18) (def-syntax-test syntax.sharp-plus.14 (let ((*features* '(:a :x :b))) (read-from-string "#+(and a c) :bad :good")) :good 22) (def-syntax-test syntax.sharp-plus.15 (let ((*features* '(:a :x :b))) (read-from-string "#+(or c b) :good :bad")) :good 17) (def-syntax-test syntax.sharp-plus.16 (let ((*features* '(:a :x :b))) (read-from-string "#+(or c d) :bad :good")) :good 21) ;;; Tests of #| |# (def-syntax-test syntax.sharp-bar.1 (read-from-string "#||#1") 1 5) (def-syntax-test syntax.sharp-bar.2 (read-from-string "1#||#2") |1##2| 6) (def-syntax-test syntax.sharp-bar.3 (read-from-string "#| #| |# |#1") 1 12) (def-syntax-test syntax.sharp-bar.4 (read-from-string "#| ; |#1") 1 8) (def-syntax-test syntax.sharp-bar.5 (read-from-string "#| ( |#1") 1 8) (def-syntax-test syntax.sharp-bar.6 (read-from-string "#| # |#1") 1 8) (def-syntax-test syntax.sharp-bar.7 (read-from-string "#| .. |#1") 1 9) (def-syntax-test syntax.sharp-bar.8 (loop for c across +standard-chars+ for s = (concatenate 'string "\#| " (string c) " |\#1") for vals = (multiple-value-list (read-from-string s)) unless (equal vals '(1 8)) collect (list c s vals)) nil) (def-syntax-test syntax.sharp-bar.9 (loop for i below (min (ash 1 16) char-code-limit) for c = (code-char i) for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) for vals = (and c (multiple-value-list (read-from-string s))) unless (or (not c) (equal vals '(1 8))) collect (list i c s vals)) nil) (def-syntax-test syntax.sharp-bar.10 (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) for vals = (and c (multiple-value-list (read-from-string s))) repeat 1000 unless (or (not c) (equal vals '(1 8))) collect (list i c s vals)) nil) ;;;; Various error cases (def-syntax-test syntax.sharp-whitespace.1 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names for c = (name-char name) when c nconc (let* ((form `(signals-error (read-from-string ,(concatenate 'string "#" (string c))) reader-error)) (vals (multiple-value-list (eval form)))) (unless (equal vals '(t)) (list (list name c form vals)))))) nil) (def-syntax-test syntax.sharp-less-than.1 (signals-error (read-from-string "#<" nil nil) reader-error) t) (def-syntax-test syntax.sharp-close-paren.1 (signals-error (read-from-string "#)" nil nil) reader-error) t) (def-syntax-test syntax.single-escape-eof.1 (signals-error (read-from-string "\\") end-of-file) t) (def-syntax-test syntax.single-escape-eof.2 (signals-error (read-from-string "\\" nil nil) end-of-file) t) (def-syntax-test syntax.multiple-escape-eof.1 (signals-error (read-from-string "|") end-of-file) t) (def-syntax-test syntax.multiple-escape-eof.2 (signals-error (read-from-string "|" nil nil) end-of-file) t) gcl-2.7.1/ansi-tests/PaxHeaders/mapl.lsp0000644000000000000000000000013114542551763015122 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.565789505 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/mapl.lsp0000644000175000017500000000534614542551763014531 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:23:23 2003 ;;;; Contains: Tests of MAPL (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (check-type-error #'(lambda (x) (mapl #'identity x)) #'sequencep) nil) (deftest mapl.error.2 (signals-error (mapl) program-error) t) (deftest mapl.error.3 (signals-error (mapl #'append) program-error) t) (deftest mapl.error.4 (signals-error (locally (mapl #'identity 1) t) type-error) t) (deftest mapl.error.5 (signals-error (mapl #'cons '(a b c)) program-error) t) (deftest mapl.error.6 (signals-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapl.error.7 (signals-error (mapl #'caar '(a b c)) type-error) t) (deftest mapl.error.8 (signals-error (mapl #'identity (list* (list 1) (list 2) 3)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/rationalp.lsp0000644000000000000000000000013114542551763016162 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.565789505 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rationalp.lsp0000644000175000017500000000154414542551763015565 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:36:31 2003 ;;;; Contains: Tests of RATIONALP (in-package :cl-test) (deftest rationalp.error.1 (signals-error (rationalp) program-error) t) (deftest rationalp.error.2 (signals-error (rationalp 0 nil) program-error) t) (deftest rationalp.error.3 (signals-error (rationalp 'a 0) program-error) t) (deftest rationalp.1 (loop for x in *rationals* for vals = (multiple-value-list (rationalp x)) unless (and (= (length vals) 1) (first vals)) collect (cons x vals)) nil) (deftest rationalp.2 (loop for x in (set-difference *universe* *rationals*) for vals = (multiple-value-list (rationalp x)) unless (and (= (length vals) 1) (null (first vals))) collect (cons x vals)) nil) (deftest rationalp.3 (check-type-predicate #'rationalp 'rational) nil) gcl-2.7.1/ansi-tests/PaxHeaders/random-class.lsp0000644000000000000000000000013114542551763016554 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.565789505 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-class.lsp0000644000175000017500000000031014542551763016145 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 10 07:13:47 2004 ;;;; Contains: Randomized tests on classes (in-package :cl-test) (compile-and-load "random-class-aux.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/base-string.lsp0000644000000000000000000000013214542551762016407 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.569789522 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/base-string.lsp0000644000175000017500000000122614542551762016006 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:26:57 2004 ;;;; Contains: Tests associated with BASE-STRING (in-package :cl-test) (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) (deftest base-string.5 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(array nil (*)) 'base-string) nil t) (deftest base-string.6 :notes (:nil-vectors-are-strings) (subtypep* 'string 'base-string) nil t) gcl-2.7.1/ansi-tests/PaxHeaders/hash-table.lsp0000644000000000000000000000013114542551762016200 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.569789522 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table.lsp0000644000175000017500000000152314542551762015600 0ustar00cammcamm;-*- 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) gcl-2.7.1/ansi-tests/PaxHeaders/nstring-capitalize.lsp0000644000000000000000000000013114542551763020000 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.569789522 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nstring-capitalize.lsp0000644000175000017500000001101614542551763017376 0ustar00cammcamm;-*- 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.11 (nstring-capitalize "") "") (deftest nstring-capitalize.12 :notes (:nil-vectors-are-strings) (nstring-capitalize (make-array '(0) :element-type nil)) "") (deftest nstring-capitalize.13 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list (copy-seq s) (copy-seq (nstring-capitalize s)) (copy-seq s) (progn (setf (fill-pointer s) 10) (copy-seq s)) )) (("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi"))) (deftest nstring-capitalize.14 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list (copy-seq s) (nstring-capitalize s) (copy-seq s) s0)) (("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG"))) (deftest nstring-capitalize.15 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list (copy-seq s) (nstring-capitalize s) (copy-seq s))) (("aB0cD" "Ab0cd" "Ab0cd") ("aB0cD" "Ab0cd" "Ab0cd") ("aB0cD" "Ab0cd" "Ab0cd"))) ;;; Order of evaluation tests (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 (signals-error (nstring-capitalize) program-error) t) (deftest nstring-capitalize.error.2 (signals-error (nstring-capitalize (copy-seq "abc") :bad t) program-error) t) (deftest nstring-capitalize.error.3 (signals-error (nstring-capitalize (copy-seq "abc") :start) program-error) t) (deftest nstring-capitalize.error.4 (signals-error (nstring-capitalize (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest nstring-capitalize.error.5 (signals-error (nstring-capitalize (copy-seq "abc") :end) program-error) t) (deftest nstring-capitalize.error.6 (signals-error (nstring-capitalize (copy-seq "abc") 1 2) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-eval-and-compile.lsp0000644000000000000000000000013214772071551020221 xustar0030 mtime=1743287145.930901991 30 atime=1744294960.569789522 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-eval-and-compile.lsp0000644000175000017500000000120114772071551017611 0ustar00cammcamm;;; 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") (load "eval-when.lsp") (load "define-compiler-macro.lsp") (load "define-symbol-macro.lsp") (load "defmacro.lsp") (load "the.lsp") (load "symbol-macrolet.lsp") (load "proclaim.lsp") (load "declaim.lsp") (load "locally.lsp") (load "ignore.lsp") (load "ignorable.lsp") (load "dynamic-extent.lsp") (load "optimize.lsp") (load "special.lsp") (load "macroexpand.lsp") (load "macroexpand-1.lsp") (load "declaration.lsp") (load "type.lsp") (load "macro-function.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/plus.lsp0000644000000000000000000000013014542551763015153 xustar0030 mtime=1703597043.012022445 29 atime=1744294960.57378954 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/plus.lsp0000644000175000017500000002554314542551763014564 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 04:34:17 2003 ;;;; Contains: Tests of the function + (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; (compile-and-load "plus-aux.lsp") (deftest plus.1 (+) 0) (deftest plus.2 (loop for x in *numbers* unless (eql x (+ x)) collect x) nil) (deftest plus.3 (loop for x in *numbers* for x1 = (+ x 0) for x2 = (+ 0 x) unless (and (eql x x1) (eql x x2) (eql x1 x2)) collect (list x x1 x2)) nil) (deftest plus.4 (loop for x in *numbers* for x1 = (- x x) unless (= x1 0) collect (list x x1)) nil) (deftest plus.5 (let* ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (%r) for y = (%r) for z = (%r) for s1 = (+ x y z) for s2 = (+ z y x) for s3 = (+ y x z) for s4 = (+ x z y) for s5 = (+ z x y) for s6 = (+ y z x) repeat 1000 unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) (eql s1 s5) (eql s1 s6)) collect (list x y z s1 s2 s3 s4 s5 s6)))) nil) (deftest plus.6 (let* ((upper-bound 1000000000000000) (lower-bound -1000000000000000) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (%r) for y = (%r) for z = (%r) for s1 = (+ x y z) for s2 = (+ z y x) for s3 = (+ y x z) for s4 = (+ x z y) for s5 = (+ z x y) for s6 = (+ y z x) repeat 1000 unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) (eql s1 s5) (eql s1 s6)) collect (list x y z s1 s2 s3 s4 s5 s6)))) nil) (deftest plus.7 (let* ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (/ (%r) (max 1 (%r))) for y = (/ (%r) (max 1 (%r))) for z = (/ (%r) (max 1 (%r))) for s1 = (+ x y z) for s2 = (+ z y x) for s3 = (+ y x z) for s4 = (+ x z y) for s5 = (+ z x y) for s6 = (+ y z x) repeat 1000 unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) (eql s1 s5) (eql s1 s6)) collect (list x y z s1 s2 s3 s4 s5 s6) unless (= (+ x y) (let ((xn (numerator x)) (xd (denominator x)) (yn (numerator y)) (yd (denominator y))) (/ (+ (* xn yd) (* xd yn)) (* xd yd)))) collect (list x y)))) nil) (deftest plus.8 (let (args) (loop for i from 0 to (min 256 (1- call-arguments-limit)) unless (eql (apply #'+ args) (/ (* i (1+ i)) 2)) collect i do (push (1+ i) args))) nil) (deftest plus.9 (let* ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum) (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for xr = (%r) for xi = (%r) for yr = (%r) for yi = (%r) for x = (complex xr xi) for y = (complex yr yi) for s = (+ x y) repeat 1000 unless (eql s (complex (+ xr yr) (+ xi yi))) collect (list x y s)))) nil) (deftest plus.10 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for radix = (float-radix x) for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k for e1 = (expt radix (- i)) for y = (+ x e1) nconc (loop for j from 1 to (- k i) for e2 = (expt radix (- j)) for z = (+ x e2) unless (eql (+ y z) (+ x e1 e2)) collect (list x i j)))) nil) (deftest plus.11 (flet ((%r () (- (random most-positive-short-float) (/ most-positive-short-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'short-float)) collect (list x y s))) nil) (deftest plus.12 (flet ((%r () (- (random most-positive-single-float) (/ most-positive-single-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'single-float)) collect (list x y s))) nil) (deftest plus.13 (flet ((%r () (- (random most-positive-double-float) (/ most-positive-double-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'double-float)) collect (list x y s))) nil) (deftest plus.14 (flet ((%r () (- (random most-positive-long-float) (/ most-positive-long-float 2)))) (loop for x = (%r) for y = (%r) for s = (+ x y) repeat 1000 unless (and (eql s (+ y x)) (typep s 'long-float)) collect (list x y s))) nil) (deftest plus.15 (let ((bound most-positive-short-float) (bound2 most-positive-single-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'single-float)) collect (list x y p))) nil) (deftest plus.16 (let ((bound most-positive-short-float) (bound2 most-positive-double-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest plus.17 (let ((bound most-positive-short-float) (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest plus.18 (let ((bound most-positive-single-float) (bound2 most-positive-double-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'double-float)) collect (list x y p))) nil) (deftest plus.19 (let ((bound most-positive-single-float) (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest plus.20 (let ((bound most-positive-double-float) (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) for y = (- (random bound2)(/ bound2 2)) for p = (+ x y) repeat 1000 unless (and (eql p (+ y x)) (typep p 'long-float)) collect (list x y p))) nil) (deftest plus.21 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (1- bits)) nconc (loop for i = (random bound) for x = (coerce i type) for j = (random bound) for y = (coerce j type) for sum = (+ x y) repeat 1000 unless (and (eql sum (coerce (+ i j) type)) (eql sum (+ y x))) collect (list i j x y sum (coerce (+ i j) type)))) nil) (deftest plus.22 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (1- bits)) nconc (loop for one = (coerce 1 type) for i = (random bound) for x = (complex (coerce i type) one) for j = (random bound) for y = (complex (coerce j type) one) for sum = (+ x y) repeat 1000 unless (and (eql sum (complex (coerce (+ i j) type) (coerce 2 type))) (eql sum (+ y x))) collect (list i j x y sum))) nil) (deftest plus.23 (loop for type in '(short-float single-float double-float long-float) for bits in '(13 24 50 50) for bound = (ash 1 (1- bits)) nconc (loop for one = (coerce 1 type) for i = (random bound) for x = (complex one (coerce i type)) for j = (random bound) for y = (complex one (coerce j type)) for sum = (+ x y) repeat 1000 unless (and (eql sum (complex (coerce 2 type) (coerce (+ i j) type))) (eql sum (+ y x))) collect (list i j x y sum))) nil) ;;; Negative zero tests (suggested by R. Toy) (deftest plus.24 (funcall (compile nil '(lambda (x) (declare (type short-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0s0 x))) -0.0s0) 0.0s0) (deftest plus.25 (funcall (compile nil '(lambda (x) (declare (type single-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0f0 x))) -0.0f0) 0.0f0) (deftest plus.26 (funcall (compile nil '(lambda (x) (declare (type double-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0d0 x))) -0.0d0) 0.0d0) (deftest plus.27 (funcall (compile nil '(lambda (x) (declare (type long-float x) (optimize (speed 3) (safety 0) (debug 0))) (+ 0.0l0 x))) -0.0l0) 0.0l0) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest plus.28 (macrolet ((%m (z) z)) (values (+ (expand-in-current-env (%m 1))) (+ (expand-in-current-env (%m 2)) 3) (+ 4 (expand-in-current-env (%m 5))) (+ 1/2 (expand-in-current-env (%m 6)) 2/3))) 1 5 9 43/6) ;;; Must test combinations of reals and complex arguments. ;;; Order of evaluation tests (deftest plus.order.1 (let ((i 0) x y) (values (+ (progn (setf x (incf i)) '8) (progn (setf y (incf i)) '11)) i x y)) 19 2 1 2) (deftest plus.order.2 (let ((i 0) x y z) (values (+ (progn (setf x (incf i)) '8) (progn (setf y (incf i)) '11) (progn (setf z (incf i)) '100)) i x y z)) 119 3 1 2 3) ;;; Test that compilation does not reassociate float additions (deftest plus.reassociation.1 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) when (eql (funcall (compile nil `(lambda () (+ ,x (+ ,eps2 ,eps2))))) x) collect (list x eps eps2)) nil) (deftest plus.reassociation.2 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) unless (equal (funcall (compile nil `(lambda () (list (+ (+ ,x ,eps2) ,eps2) (+ ,eps2 (+ ,eps2 ,x)))))) (list x x)) collect (list x eps eps2)) nil) (deftest plus.reassociation.3 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) when (eql (funcall (compile nil `(lambda (y e) (+ y (+ e e)))) x eps2) x) collect (list x eps eps2)) nil) (deftest plus.reassociation.4 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) unless (equal (funcall (compile nil `(lambda (y e) (list (+ (+ y e) e) (+ e (+ e y))))) x eps2) (list x x)) collect (list x eps eps2)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/intern.lsp0000644000000000000000000000013014542551762015466 xustar0029 mtime=1703597042.99602242 29 atime=1744294960.57378954 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/intern.lsp0000644000175000017500000001150514542551762015070 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:10 1998 ;;;; Contains: Tests of INTERN (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; intern (deftest intern.1 (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1" :use nil)) (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" :use nil))) (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.3 :notes (:nil-vectors-are-strings) (let ((cl-user-package (find-package "CL-USER"))) (eqt (intern "" cl-user-package) (intern (make-array 0 :element-type nil) cl-user-package))) t) (deftest intern.4 (let ((cl-user-package (find-package "CL-USER"))) (eqt (intern (make-array 5 :element-type 'character :initial-contents "XYZZY") cl-user-package) (intern (make-array 5 :element-type 'base-char :initial-contents "XYZZY") cl-user-package))) t) ;;; String is a specialized sequence type (defmacro def-intern-test (test-name &key (symbol-name "FOO") (package-name "TEMP1")) `(deftest ,test-name (let ((sname ,symbol-name) (pname ,package-name)) (safely-delete-package pname) (let ((p (make-package pname :use nil))) (multiple-value-bind* (sym1 status1) (find-symbol sname pname) (intern sname pname) (multiple-value-bind* (sym2 status2) (find-symbol sname p) (and (null sym1) (null status1) (string= (symbol-name sym2) sname) (eqt (symbol-package sym2) p) (eqt status2 :internal) (progn (delete-package p) t)))))) t)) (def-intern-test intern.5 :symbol-name (make-array 3 :element-type 'base-char :initial-contents "BAR")) (def-intern-test intern.6 :symbol-name (make-array 13 :element-type 'base-char :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.7 :symbol-name (make-array 13 :element-type 'character :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.8 :symbol-name (make-array 3 :element-type 'base-char :adjustable t :initial-contents "BAR")) (def-intern-test intern.9 :symbol-name (make-array 3 :element-type 'character :adjustable t :initial-contents "BAR")) (def-intern-test intern.10 :symbol-name (let* ((etype 'base-char) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-intern-test intern.11 :symbol-name (let* ((etype 'character) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-intern-test intern.12 :package-name (make-array 3 :element-type 'base-char :initial-contents "BAR")) (def-intern-test intern.13 :package-name (make-array 13 :element-type 'base-char :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.14 :package-name (make-array 13 :element-type 'character :fill-pointer 3 :initial-contents "BAR1234567890")) (def-intern-test intern.15 :package-name (make-array 3 :element-type 'base-char :adjustable t :initial-contents "BAR")) (def-intern-test intern.16 :package-name (make-array 3 :element-type 'character :adjustable t :initial-contents "BAR")) (def-intern-test intern.17 :package-name (let* ((etype 'base-char) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-intern-test intern.18 :package-name (let* ((etype 'character) (name0 (make-array 8 :element-type etype :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Error tests (deftest intern.error.1 (signals-error (intern) program-error) t) (deftest intern.error.2 (signals-error (intern "X" "CL" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/compute-restarts.lsp0000644000000000000000000000013014542551762017510 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.577789557 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compute-restarts.lsp0000644000175000017500000000574214542551762017120 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 22 23:48:53 2003 ;;;; Contains: Tests of COMPUTE-RESTARTS (in-package :cl-test) (deftest compute-restarts.1 (loop for r in (compute-restarts) always (typep r 'restart)) t) (deftest compute-restarts.2 (loop for r in (compute-restarts) always (typep r (find-class 'restart))) t) (deftest compute-restarts.3 (restart-case (let ((r (find-restart 'foo))) (eqt r (find 'foo (compute-restarts) :key #'restart-name))) (foo () nil)) t) (deftest compute-restarts.4 (loop for r1 in (compute-restarts) for r2 in (compute-restarts) always (eq r1 r2)) t) (deftest compute-restarts.5 (restart-case (loop for r1 in (compute-restarts) for r2 in (compute-restarts) always (eq r1 r2)) (foo () t) (bar () t) (foo () nil)) t) (deftest compute-restarts.6 (restart-case (let* ((restarts (compute-restarts)) (p (position 'foo restarts :key #'restart-name)) (r (find 'foo restarts :start (1+ p) :key #'restart-name))) (invoke-restart r)) (foo () 'bad) (foo () 'good) (foo () 'bad)) good) (deftest compute-restarts.7 (handler-bind ((error #'(lambda (c) (let* ((restarts (compute-restarts c)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) (invoke-restart (second r)))))) (restart-case (error "an error") (foo () 'bad) (foo () 'good) (foo () 'bad))) good) (deftest compute-restarts.8 (handler-bind ((error #'(lambda (c) (declare (ignore c)) (let* ((restarts (compute-restarts)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) (invoke-restart (second r)))))) (restart-case (error "an error") (foo () 'bad) (foo () 'good) (foo () 'bad))) good) (deftest compute-restarts.9 (let ((c2 (make-condition 'error))) (block done (handler-bind ((error #'(lambda (c) (declare (ignore c)) (let* ((restarts (compute-restarts c2)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) ;; (write restarts) (return-from done (values r (mapcar #'restart-name r))))))) (restart-case (error "an error") (foo () 'bad) (foo () 'also-bad))))) nil nil) ;;; This test is disabled until I figure out how to fix ;;; it. See sbcl-devel mailing list, Oct 2005 #| (deftest compute-restarts.10 (let ((c2 (make-condition 'error))) (block done (handler-bind ((error #'(lambda (c) (declare (ignore c)) (let* ((restarts (compute-restarts c2)) (r (remove 'foo restarts :test-not #'eq :key #'restart-name))) ;; (write restarts) (return-from done (values r (mapcar #'restart-name r))))))) (restart-case (progn (error "an error")) (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) 'bad) (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) 'also-bad))))) nil nil) |# gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-02.lsp0000644000000000000000000000013114542551763020765 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.577789557 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-02.lsp0000644000175000017500000001303514542551763020366 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 20:37:57 2005 ;;;; Contains: Tests that invoke the random type prop infrastructure, part 2 (in-package :cl-test) (def-type-prop-test =.1 '= '(number number) 2) (def-type-prop-test =.2 '= '(number number number) 3) (def-type-prop-test =.3 '= nil 4 :maxargs 10 :rest-type 'number) (def-type-prop-test =.4 '= '(integer integer) 2) (def-type-prop-test =.5 '= (list 'number #'(lambda (x) (if (coin) 'number `(eql ,x)))) 2) (def-type-prop-test =.6 '= (list 'number 'number #'(lambda (x y) (rcase (2 'number) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test /=.1 '/= '(number number) 2) (def-type-prop-test /=.2 '/= '(number number number) 3) (def-type-prop-test /=.3 '/= nil 4 :maxargs 10 :rest-type 'number) (def-type-prop-test /=.4 '/= '(integer integer) 2) (def-type-prop-test /=.5 '/= (list 'number #'(lambda (x) (if (coin) 'number `(eql ,x)))) 2) (def-type-prop-test /=.6 '/= (list 'number 'number #'(lambda (x y) (rcase (2 'number) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test <.1 '< '(real real) 2) (def-type-prop-test <.2 '< '(real real real) 3) (def-type-prop-test <.3 '< nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test <.4 '< '(integer integer) 2) (def-type-prop-test <.5 '< (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test <.6 '< (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test >.1 '> '(real real) 2) (def-type-prop-test >.2 '> '(real real real) 3) (def-type-prop-test >.3 '> nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test >.4 '> '(integer integer) 2) (def-type-prop-test >.5 '> (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test >.6 '> (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test <=.1 '<= '(real real) 2) (def-type-prop-test <=.2 '<= '(real real real) 3) (def-type-prop-test <=.3 '<= nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test <=.4 '<= '(integer integer) 2) (def-type-prop-test <=.5 '<= (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test <=.6 '<= (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test >=.1 '>= '(real real) 2) (def-type-prop-test >=.2 '>= '(real real real) 3) (def-type-prop-test >=.3 '>= nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test >=.4 '>= '(integer integer) 2) (def-type-prop-test >=.5 '>= (list 'real #'(lambda (x) (if (coin) 'real `(eql ,x)))) 2) (def-type-prop-test >=.6 '>= (list 'real 'real #'(lambda (x y) (rcase (2 'real) (1 `(eql ,x)) (1 `(eql ,y))))) 3) (def-type-prop-test min.1 'min nil 2 :maxargs 6 :rest-type 'integer) (def-type-prop-test min.2 'min nil 2 :maxargs 6 :rest-type 'rational) (def-type-prop-test min.3 'min nil 2 :maxargs 6 :rest-type 'real) (def-type-prop-test max.1 'max nil 2 :maxargs 6 :rest-type 'integer) (def-type-prop-test max.2 'max nil 2 :maxargs 6 :rest-type 'rational) (def-type-prop-test max.3 'max nil 2 :maxargs 6 :rest-type 'real) (def-type-prop-test minusp 'minusp '(real) 1) (def-type-prop-test plusp 'plusp '(real) 1) (def-type-prop-test zerop 'zerop '(number) 1) (def-type-prop-test floor.1 'floor '(real) 1) (def-type-prop-test floor.2 'floor '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test floor.3 'floor '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test ffloor.1 'ffloor '(real) 1) (def-type-prop-test ffloor.2 'ffloor '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test ffloor.3 'ffloor '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test ceiling.1 'ceiling '(real) 1) (def-type-prop-test ceiling.2 'ceiling '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test ceiling.3 'ceiling '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test fceiling.1 'fceiling '(real) 1) (def-type-prop-test fceiling.2 'fceiling '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test fceiling.3 'fceiling '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test truncate.1 'truncate '(real) 1) (def-type-prop-test truncate.2 'truncate '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test truncate.3 'truncate '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test ftruncate.1 'ftruncate '(real) 1) (def-type-prop-test ftruncate.2 'ftruncate '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test ftruncate.3 'ftruncate '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test round.1 'round '(real) 1) (def-type-prop-test round.2 'round '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test round.3 'round '(real (and real (not (satisfies zerop)))) 2) (def-type-prop-test fround.1 'fround '(real) 1) (def-type-prop-test fround.2 'fround '(real (and integer (not (satisfies zerop)))) 2) (def-type-prop-test fround.3 'fround '(real (and real (not (satisfies zerop)))) 2) gcl-2.7.1/ansi-tests/PaxHeaders/assoc-if.lsp0000644000000000000000000000013214542551762015675 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.577789557 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/assoc-if.lsp0000644000175000017500000001044214542551762015274 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:27:57 2003 ;;;; Contains: Tests of ASSOC-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (deftest assoc-if.5 (let () (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)) ;;; Macro env tests (deftest assoc-if.env.1 (macrolet ((%m (z) z)) (let ((alist '((1 . a) (3 . b) (6 . c) (8 . d) (-1 . e)))) (values (assoc-if (expand-in-current-env (%m 'evenp)) alist) (assoc-if (expand-in-current-env (%m #'evenp)) alist) (assoc-if #'evenp (expand-in-current-env (%m alist))) (assoc-if 'oddp alist (expand-in-current-env (%m :key)) '1+) (assoc-if 'oddp alist :key (expand-in-current-env (%m #'1+))) ))) (6 . c) (6 . c) (6 . c) (6 . c) (6 . c)) ;;; Error cases (deftest assoc-if.error.1 (signals-error (assoc-if) program-error) t) (deftest assoc-if.error.2 (signals-error (assoc-if #'null) program-error) t) (deftest assoc-if.error.3 (signals-error (assoc-if #'null nil :bad t) program-error) t) (deftest assoc-if.error.4 (signals-error (assoc-if #'null nil :key) program-error) t) (deftest assoc-if.error.5 (signals-error (assoc-if #'null nil 1 1) program-error) t) (deftest assoc-if.error.6 (signals-error (assoc-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest assoc-if.error.7 (signals-error (assoc-if #'cons '((a b)(c d))) program-error) t) (deftest assoc-if.error.8 (signals-error (assoc-if #'identity '((a b)(c d)) :key #'cons) program-error) t) (deftest assoc-if.error.9 (signals-type-error x 'a (assoc-if #'car '((a b)(c d)))) t) (deftest assoc-if.error.10 (signals-type-error x 'a (assoc-if #'identity '((a b)(c d)) :key #'car)) t) (deftest assoc-if.error.11 (signals-error (assoc-if #'null '((a . b) . c)) type-error) t) (deftest assoc-if.error.12 (signals-error (assoc-if #'null '((a . b) :bad (c . d))) type-error) t) (deftest assoc-if.error.13 (signals-type-error x 'y (assoc-if #'null x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests.lsp0000644000000000000000000000013114542551763020546 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.577789557 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests.lsp0000644000175000017500000000123014542551763020141 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 20 11:50:26 2005 ;;;; Contains: Randomized tests of type propagation during compilation (compile-and-load "random-type-prop.lsp") (in-package :cl-test) (load "random-type-prop-tests-01.lsp") (load "random-type-prop-tests-02.lsp") (load "random-type-prop-tests-03.lsp") (load "random-type-prop-tests-04.lsp") (load "random-type-prop-tests-05.lsp") (load "random-type-prop-tests-06.lsp") (load "random-type-prop-tests-07.lsp") (load "random-type-prop-tests-08.lsp") (load "random-type-prop-tests-09.lsp") (load "random-type-prop-tests-10.lsp") (load "random-type-prop-tests-structs.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/zerop.lsp0000644000000000000000000000013214542551763015331 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.577789557 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/zerop.lsp0000644000175000017500000000371214542551763014732 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 21:47:34 2003 ;;;; Contains: Tests of ZEROP (in-package :cl-test) (deftest zerop.error.1 (signals-error (zerop) program-error) t) (deftest zerop.error.2 (signals-error (zerop 0 1) program-error) t) (deftest zerop.error.3 (signals-error (zerop 1 0) program-error) t) (deftest zerop.error.4 (check-type-error #'zerop #'numberp) nil) (deftest zerop.1 (loop for x in *numbers* when (if (zerop x) (/= x 0) (= x 0)) collect x) nil) (deftest zerop.2 (zerop 1) nil) (deftest zerop.3 (zerop -1) nil) (deftest zerop.4 (notnot-mv (zerop 0)) t) (deftest zerop.5 (notnot-mv (zerop 0.0s0)) t) (deftest zerop.6 (notnot-mv (zerop 0.0f0)) t) (deftest zerop.7 (notnot-mv (zerop 0.0d0)) t) (deftest zerop.7a (notnot-mv (zerop 0.0l0)) t) (deftest zerop.8 (remove-if-not #'zerop (list 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 most-negative-short-float most-negative-single-float most-negative-double-float most-negative-long-float)) nil) (deftest zerop.9 (remove-if-not #'zerop (list 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 most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float)) nil) (deftest zerop.10 (notevery #'zerop (list -0.0s0 -0.0f0 -0.0d0 -0.0l0)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/structures-01.lsp0000644000000000000000000000013214542551763016633 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.581789575 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/structures-01.lsp0000644000175000017500000000440714542551763016236 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cons-test-06.lsp0000644000000000000000000000013214542551762016333 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.585789593 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-06.lsp0000644000175000017500000000167414542551762015741 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/eval-and-compile.lsp0000644000000000000000000000013214542551762017306 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.585789593 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/eval-and-compile.lsp0000644000175000017500000000114114542551762016701 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/warn.lsp0000644000000000000000000000013214542551763015141 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.585789593 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/warn.lsp0000644000175000017500000000756214542551763014551 0ustar00cammcamm;-*- 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 (signals-error (warn 'condition) type-error) t) (deftest warn.13 (signals-error (warn 'simple-condition) type-error) t) (deftest warn.14 (signals-error (warn (make-condition 'simple-warning) :format-control "Foo") type-error) t) (deftest warn.15 (signals-error (warn) program-error) t) (deftest warn.16 (signals-error (warn (make-condition 'condition)) type-error) t) (deftest warn.17 (signals-error (warn (make-condition 'simple-condition)) type-error) t) (deftest warn.18 (signals-error (warn (make-condition 'simple-error)) type-error) t) (deftest warn.19 (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 (formatter "Foo!")))) warned))) (nil) t)gcl-2.7.1/ansi-tests/PaxHeaders/minus.lsp0000644000000000000000000000013114542551763015324 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.585789593 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/minus.lsp0000644000175000017500000001070514542551763014726 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 11:15:14 2003 ;;;; Contains: Tests of the - function (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest minus.error.1 (signals-error (-) program-error) t) ;;; Unary minus tests (deftest minus.1 (loop for x in *numbers* unless (eql (- (- x)) x) collect x) nil) (deftest minus.2 (locally (declare (notinline -)) (loop for x in *numbers* unless (eql (- (- x)) x) collect x)) nil) (deftest minus.3 (loop for x in *reals* when (and (integerp x) (not (eql (- x) (- 0 x)))) collect x) nil) (deftest minus.4 (loop for x in *reals* for neg = (- x) when (and (floatp x) (not (zerop x)) (not (eql neg (- 0.0s0 x))) (eql (float 1.0s0 x) (float 1.0s0 neg))) collect x) nil) (deftest minus.5 (loop for x in *numbers* when (and (complexp x) (rationalp (realpart x)) (not (eql (- x) (- 0 x)))) collect x) nil) (deftest minus.6 (loop for x in *numbers* for neg = (- x) when (and (complexp x) (floatp (realpart x)) (eql (float 1.0s0 (realpart x)) (float 1.0s0 (realpart neg))) (or (/= neg (- 0 x)) (and (not (zerop (realpart x))) (not (eqlzt neg (- 0 x)))))) collect x) nil) (deftest minus.7 (let ((upper-bound most-positive-fixnum) (lower-bound most-negative-fixnum)) (loop for x = (+ (random (- upper-bound lower-bound)) lower-bound) for neg = (- x) repeat 1000 unless (and (integerp neg) (eql (abs x) (abs neg)) (if (> x 0) (< neg 0) (>= neg 0)) (zerop (+ x neg)) (eql x (- neg))) collect x)) nil) (deftest minus.8 (let ((upper-bound (ash 1 1000)) (lower-bound (- (ash 1 1000)))) (loop for x = (+ (random (- upper-bound lower-bound)) lower-bound) for neg = (- x) repeat 1000 unless (and (integerp neg) (eql (abs x) (abs neg)) (if (> x 0) (< neg 0) (>= neg 0)) (zerop (+ x neg)) (eql x (- neg))) collect x)) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest minus.9 (macrolet ((%m (z) z)) (- (expand-in-current-env (%m 1)))) -1) ;;; Binary minus tests (deftest subtract.1 (loop for x = (random-fixnum) for y = (random-fixnum) repeat 1000 unless (and (eql (+ x (- y)) (- x y)) (eql (+ 1 x (- y)) (- x (1- y))) (eql (+ -1 x (- y)) (- x (1+ y)))) collect (list x y)) nil) (deftest subtract.2 (let ((bound (ash 1 1000))) (loop for x = (random-from-interval bound (- bound)) for y = (random-from-interval bound (- bound)) repeat 1000 unless (and (eql (+ x (- y)) (- x y)) (eql (+ 1 x (- y)) (- x (1- y))) (eql (+ -1 x (- y)) (- x (1+ y)))) collect (list x y))) nil) (deftest subtract.3 (let ((args nil)) (loop for i from 1 below (min 256 (1- call-arguments-limit)) do (push 1 args) always (eql (apply #'- 1000 args) (- 1000 i)))) t) ;;; Float contagion (deftest subtract.4 (loop for type1 in '(short-float single-float double-float long-float) for bits1 in '(13 24 50 50) for bound1 = (ash 1 (- bits1 2)) for c1 from 1 nconc (loop for type2 in '(short-float single-float double-float long-float) for bits2 in '(13 24 50 50) for bound2 = (ash 1 (- bits2 2)) for c2 from 1 nconc (loop for i = (random-from-interval bound1) for x = (coerce i type1) for j = (random-from-interval bound2) for y = (coerce j type2) for idiff1 = (- i j) for idiff2 = (- j i) for diff1 = (- x y) for diff2 = (- y x) repeat 1000 unless (or (zerop idiff1) (and (eql idiff1 (- idiff2)) (eql diff1 (- diff2)) (if (<= c1 c2) (eql (float diff1 y) diff1) (eql (float diff1 x) diff1)) (eql (float idiff1 diff1) diff1))) collect (list i x j y idiff1 idiff2 diff1 diff2)))) nil) ;;; Complex subtraction (deftest subtract.5 (loop for i = (random-fixnum) for ci = (complex i (+ i 100)) for j = (random-fixnum) for cj = (complex j (- j 200)) for diff = (- ci cj) repeat 1000 unless (eql diff (complex (- i j) (+ (- i j) 300))) collect (list i ci j cj (- ci cj))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest subtract.6 (macrolet ((%m (z) z)) (values (- (expand-in-current-env (%m 2)) 1) (- 17 (expand-in-current-env (%m 5))) (- 1/2 (expand-in-current-env (%m 1/6)) (expand-in-current-env (%m 0))))) 1 12 1/3) gcl-2.7.1/ansi-tests/PaxHeaders/rctest0000644000000000000000000000013214776006046014677 xustar0030 mtime=1744309286.150034344 30 atime=1744351538.814879383 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/0000755000175000017500000000000014776006046014352 5ustar00cammcammgcl-2.7.1/ansi-tests/rctest/PaxHeaders/rctest-util.lsp0000644000000000000000000000013114542551763017754 xustar0030 mtime=1703597043.020022457 29 atime=1744294960.58978961 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/rctest-util.lsp0000644000175000017500000000111614542551763017352 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 7 21:42:23 2003 ;;;; Contains: Utility functions for RCTEST (in-package :rctest) (defun randomly-partition (size &optional (limit 1)) "Return a randomly generated list of positive integers whose sum is SIZE. Try to make no element be < LIMIT." (declare (type unsigned-byte size limit)) (let ((result nil)) (loop while (> size 0) do (let* ((e0 (min size (max limit (1+ (min (random size) (random size))))))) (push e0 result) (decf size e0))) (random-permute result))) gcl-2.7.1/ansi-tests/rctest/PaxHeaders/generator.lsp0000644000000000000000000000013214542551763017464 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.593789628 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/generator.lsp0000644000175000017500000000742114542551763017066 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 6 18:15:50 2003 ;;;; Contains: Generator class and associated generic function definitions (in-package :rctest) (compile-and-load "rctest-util.lsp") (defvar *prototype-class-table* (make-hash-table) "Contains a map from names of classes to prototype instances for those classes.") (defgeneric prototype (class) ;; Map a class to a prototype instance of the class. Cache using ;; *prototype-class-table*. (:method ((class standard-class) &aux (name (class-name class))) (or (gethash name *prototype-class-table*) (setf (gethash name *prototype-class-table*) (make-instance class)))) (:method ((class symbol)) (prototype (find-class class)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Generators are objects that are used to create random instances. (defclass generator () ()) (defclass composite-generator (generator) ((subgenerators :type array :initform (make-array '(10) :adjustable t :fill-pointer 0)) (cumulative-weights :type array :initform (make-array '(10) :fill-pointer 0 :adjustable t :element-type 'single-float :initial-element 0.0f0)) )) (defclass simple-generator (generator) ()) (defgeneric generate (gen size &rest ctxt &key &allow-other-keys) (:method ((gen composite-generator) (size real) &rest ctxt) (let* ((subgens (slot-value gen 'subgenerators)) (n (fill-pointer subgens))) (when (<= n 0) (return-from generate (values nil nil))) (let* ((cum-weights (slot-value gen 'cumulative-weights)) (total-weight (aref cum-weights (1- n))) (random-weight (random total-weight)) ;; Replace POSITION call with a binary search if necessary (index (position random-weight cum-weights :test #'>=))) (loop for i from 1 to 10 do (multiple-value-bind (val success?) (apply #'generate (aref subgens index) size ctxt) (when success? (return (values val t)))) finally (return (values nil nil)))))) ) (defmethod generate ((gen symbol) size &rest ctxt &key &allow-other-keys) (apply #'generate (prototype gen) size ctxt)) (defgeneric add-subgenerator (gen subgen weight) (:method ((gen composite-generator) (subgen generator) weight) (let* ((subgens (slot-value gen 'subgenerators)) (n (fill-pointer subgens)) (cum-weights (slot-value gen 'cumulative-weights)) (total-weight (if (> n 0) (aref cum-weights (1- n)) 0.0f0))) (vector-push-extend gen subgens n) (vector-push-extend (+ total-weight weight) cum-weights n) (values)))) (defclass iterative-generator (generator) ((subgenerator :initarg :sub))) (defclass random-iterative-generator (iterative-generator) ()) (defmethod generate ((gen random-iterative-generator) size &rest ctxt) (if (<= size 1) nil (let ((subgen (slot-value gen 'subgenerator)) (subsizes (randomly-partition (1- size) (min (isqrt size) 10)))) (loop for subsize in subsizes for (element success) = (multiple-value-list (apply #'generate subgen subsize ctxt)) when success collect element)))) ;;; Macro for defining simple generator objects ;;; BODY is the body of the method with arguments (gen ctxt size) ;;; for computing the result. Inside the body the function FAIL causes ;;; the generator to return (nil nil). (defmacro defgenerator (name &key keys body (superclass 'simple-generator) slots) (let ((rtag (gensym))) (unless (listp keys) (setf keys (list keys))) `(progn (defclass ,name (,superclass) ,slots) (defmethod generate ((gen ,name) (size real) &rest ctxt &key ,@keys) (declare (ignorable gen size ctxt)) (block ,rtag (flet ((fail () (return-from ,rtag (values nil nil)))) ,body)))))) gcl-2.7.1/ansi-tests/rctest/PaxHeaders/makefile.old0000644000000000000000000000013214776006046017231 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/makefile.old0000644000175000017500000000010514776006046016623 0ustar00cammcamm clean: rm -f test.out *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl gcl-2.7.1/ansi-tests/rctest/PaxHeaders/README0000644000000000000000000000013214542551763015636 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.593789628 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/README0000644000175000017500000000025114542551763015232 0ustar00cammcammThis directory contains (or will contain) a program for generating random Lisp code. The intent is to generate random input cases to test for compile and/or eval bugs. gcl-2.7.1/ansi-tests/rctest/PaxHeaders/lambda-generator.lsp0000644000000000000000000000013214542551763020702 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.593789628 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/lambda-generator.lsp0000644000175000017500000000170614542551763020304 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 9 20:57:34 2003 ;;;; Contains: Generators for lambda expressions (in-package :rctest) (compile-and-load "generator.lsp") (defgenerator lambda-list-generator :body (let ((vars (loop for i from 1 to size collect (gensym)))) (values vars t vars))) (defvar *lambda-list-generator* (make-instance 'lambda-list-generator)) (defgenerator lambda-generator.1 :keys (vars) :body (let* ((s1 (random (min 5 size))) (s2 (- size s1))) (multiple-value-bind (lambda-list success1 lambda-vars) (apply #'generate *lambda-list-generator* s1 ctxt) (let ((vars (append (mapcar #'list lambda-vars) vars))) (multiple-value-bind (body success2) (apply #'generate 'implicit-progn-generator s2 :vars vars ctxt) (if (and success1 success2) (values `(lambda ,lambda-list ,@body)) (values nil nil))))))) (defvar *lambda-generator* (make-instance 'lambda-generator.1)) gcl-2.7.1/ansi-tests/rctest/PaxHeaders/rctest-package.lsp0000644000000000000000000000013214542551763020373 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.593789628 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/rctest-package.lsp0000644000175000017500000000044414542551763017773 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 6 16:46:31 2003 ;;;; Contains: Definition of the RCTEST package (defpackage :rctest (:use :cl :cl-test) (:import-from "COMMON-LISP-USER" #:compile-and-load) (:export #:generate )) ;; (in-package :rctest) gcl-2.7.1/ansi-tests/rctest/PaxHeaders/load.lsp0000644000000000000000000000013214542551763016415 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.597789645 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/load.lsp0000644000175000017500000000060114542551763016010 0ustar00cammcamm;;; Compile and load the rctest system (load "../compile-and-load.lsp") (load "../rt-package.lsp") (compile-and-load "../rt.lsp") (load "../cl-test-package.lsp") (compile-and-load "../random-aux.lsp") (load "rctest-package.lsp") (compile-and-load "rctest-util.lsp") (compile-and-load "generator.lsp") (compile-and-load "lambda-generator.lsp") (compile-and-load "form-generators.lsp") gcl-2.7.1/ansi-tests/rctest/PaxHeaders/form-generators.lsp0000644000000000000000000000013214542551763020610 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.597789645 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/rctest/form-generators.lsp0000644000175000017500000000156514542551763020215 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 21 10:56:09 2003 ;;;; Contains: Generators for forms (in-package :rctest) (defclass form-generator (composite-generator) ()) (defparameter *form-generator* (make-instance 'composite-generator)) (defclass implicit-progn-generator (random-iterative-generator) ((subgenerator :initform *form-generator*))) (defgenerator var-form-generator :keys (vars) :body (random-from-seq vars)) (defgenerator int-form-generator :body (random-case 0 (random-from-seq #.(apply #'vector (loop for i from 0 to 31 collect (ash 1 i)))) (random-from-seq #.(apply #'vector (loop for i from 0 to 31 collect (- (ash 1 i))))) (random-from-seq #.(make-array 128 :initial-contents (loop for i from 0 to 31 for x = (ash 1 i) nconc (list (1- x) (1+ x) (- 1 x) (- -1 x))))) (random 1000))) gcl-2.7.1/ansi-tests/PaxHeaders/loop17.lsp0000644000000000000000000000013214542551763015313 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.597789645 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop17.lsp0000644000175000017500000000455514542551763014722 0ustar00cammcamm;-*- 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.17.22 (macrolet ((%m (z) z)) (loop with x = 0 initially (expand-in-current-env (%m (incf x))) until t finally (expand-in-current-env (%m (return x))))) 1) gcl-2.7.1/ansi-tests/PaxHeaders/input-stream-p.lsp0000644000000000000000000000013114542551762017055 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.597789645 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/input-stream-p.lsp0000644000175000017500000000156014542551762016456 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/compile-file-test-file-4.lsp0000644000000000000000000000013014542551762020567 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.597789645 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-file-test-file-4.lsp0000644000175000017500000000010014542551762020156 0ustar00cammcamm(in-package "CL-TEST") (defun compile-file-test-fun.4 () !foo) gcl-2.7.1/ansi-tests/PaxHeaders/load-printer.lsp0000644000000000000000000000013214772071555016573 xustar0030 mtime=1743287149.694905541 30 atime=1744294960.597789645 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-printer.lsp0000644000175000017500000000234314772071555016173 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 04:40:33 2004 ;;;; Contains: File to load tests of the lisp printer (in-package :cl-test) (compile-and-load "printer-aux.lsp") (load "copy-pprint-dispatch.lsp") (load "print-integers.lsp") (load "print-ratios.lsp") (load "print-floats.lsp") (load "print-complex.lsp") (load "print-characters.lsp") (load "print-symbols.lsp") (load "print-strings.lsp") (load "print-cons.lsp") (load "print-backquote.lsp") (load "print-bit-vector.lsp") (load "print-vector.lsp") (load "print-array.lsp") (load "print-random-state.lsp") (load "print-pathname.lsp") (load "print-structure.lsp") (load "printer-control-vars.lsp") (load "pprint-dispatch.lsp") (load "pprint-fill.lsp") (load "pprint-linear.lsp") (load "pprint-tabular.lsp") (load "pprint-indent.lsp") (load "pprint-logical-block.lsp") (load "pprint-exit-if-list-exhausted.lsp") (load "pprint-newline.lsp") (load "pprint-tab.lsp") (load "print-unreadable-object.lsp") (load "write.lsp") (load "print.lsp") (load "pprint.lsp") (load "prin1.lsp") (load "princ.lsp") (load "write-to-string.lsp") (load "prin1-to-string.lsp") (load "princ-to-string.lsp") (load "print-level.lsp") (load "print-length.lsp") (load "load-format.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/make-pathname.lsp0000644000000000000000000000013214542551763016702 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.597789645 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-pathname.lsp0000644000175000017500000001042314542551763016300 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/progv.lsp0000644000000000000000000000013114542551763015326 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.601789663 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/progv.lsp0000644000175000017500000000460214542551763014727 0ustar00cammcamm;-*- 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) ;;; No tagbody (deftest progv.11 (block nil (tagbody (progv nil nil (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Variables that are not bound don't have any type constraints (deftest progv.12 (progv '(x y) '(1) (locally (declare (special x y) (type nil y)) (values x (boundp 'y)))) 1 nil) ;;; Macros are expanded in the appropriate environment (deftest progv.13 (macrolet ((%m (z) z)) (progv (expand-in-current-env (%m '(x))) '(:good) (locally (declare (special x)) x))) :good) (deftest progv.14 (macrolet ((%m (z) z)) (progv (list (expand-in-current-env (%m 'x))) '(:good) (locally (declare (special x)) x))) :good) (deftest progv.15 (macrolet ((%m (z) z)) (progv '(x) (expand-in-current-env (%m '(:good))) (locally (declare (special x)) x))) :good) (deftest progv.16 (macrolet ((%m (z) z)) (progv '(x) (list (expand-in-current-env (%m :good))) (locally (declare (special x)) x))) :good) (deftest progv.17 (macrolet ((%m (z) z)) (progv nil nil (expand-in-current-env (%m :good)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/print-ratios.lsp0000644000000000000000000000013114542551763016624 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.601789663 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-ratios.lsp0000644000175000017500000000071514542551763016226 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 1 22:03:58 2004 ;;;; Contains: Tests for printing ratios (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.ratios.random (loop for i from 1 to 1000 for numbits = (1+ (random 40)) for bound = (ash 1 numbits) for num = (- (random (+ bound bound)) bound) for denom = (1+ (random bound)) for r = (/ num denom) nconc (randomly-check-readability r)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/nconc.lsp0000644000000000000000000000013114542551763015271 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.601789663 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nconc.lsp0000644000175000017500000000267114542551763014676 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:35:53 2003 ;;;; Contains: Tests of NCONC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (list 'a) (incf i)) i)) (a . 1) 1) gcl-2.7.1/ansi-tests/PaxHeaders/atom-errors.lsp0000644000000000000000000000013214542551762016443 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.601789663 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/atom-errors.lsp0000644000175000017500000000123114542551762016036 0ustar00cammcamm(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.7.1/ansi-tests/PaxHeaders/load-logical-pathname-translations.lsp0000644000000000000000000000013114542551762023031 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.601789663 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/load-logical-pathname-translations.lsp0000644000175000017500000000163714542551762022437 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/print-vector.lsp0000644000000000000000000000013114542551763016625 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.601789663 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-vector.lsp0000644000175000017500000002663414542551763016237 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 20 22:36:53 2004 ;;;; Contains: Tests of vector printing (compile-and-load "printer-aux.lsp") (in-package :cl-test) ;;; Empty vector tests (deftest print.vector.1 (with-standard-io-syntax (write-to-string #() :readably nil :array t)) "#()") (deftest print.vector.2 (with-standard-io-syntax (loop for i from 2 to 100 for a = (make-array '(0) :element-type `(unsigned-byte ,i)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#()") collect (list i s))) nil) (deftest print.vector.3 (with-standard-io-syntax (loop for i from 1 to 100 for a = (make-array '(0) :element-type `(signed-byte ,i)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#()") collect (list i s))) nil) (deftest print.vector.4 (with-standard-io-syntax (loop for type in '(short-float single-float double-float long-float) for a = (make-array '(0) :element-type type) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#()") collect (list type s))) nil) ;;; Nonempty vectors (deftest print.vector.5 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) (result (write-to-string #(a b c) :readably nil :array t :pretty nil :case :downcase))) (or (and (string= result "#(a b c)") t) result))) t) (deftest print.vector.6 (with-standard-io-syntax (loop for i from 2 to 100 for a = (make-array '(4) :element-type `(unsigned-byte ,i) :initial-contents '(3 0 2 1)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#(3 0 2 1)") collect (list i a s))) nil) (deftest print.vector.7 (with-standard-io-syntax (loop for i from 2 to 100 for a = (make-array '(4) :element-type `(signed-byte ,i) :initial-contents '(-2 -1 0 1)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#(-2 -1 0 1)") collect (list i a s))) nil) ;;; Vectors with fill pointers (deftest print.vector.fill.1 (with-standard-io-syntax (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 0)) (*package* (find-package "CL-TEST"))) (loop for i from 0 to 10 do (setf (fill-pointer v) i) collect (write-to-string v :readably nil :array t :pretty nil :case :downcase)))) ("#()" "#(a)" "#(a b)" "#(a b c)" "#(a b c d)" "#(a b c d e)" "#(a b c d e f)" "#(a b c d e f g)" "#(a b c d e f g h)" "#(a b c d e f g h i)" "#(a b c d e f g h i j)")) (deftest print.vector.fill.2 (with-standard-io-syntax (let ((expected '("#()" "#(0)" "#(0 1)" "#(0 1 2)" "#(0 1 2 3)"))) (loop for i from 2 to 100 nconc (let ((v (make-array '(4) :initial-contents '(0 1 2 3) :element-type `(unsigned-byte ,i) :fill-pointer 0))) (loop for fp from 0 to 4 for expected-result in expected for actual-result = (progn (setf (fill-pointer v) fp) (write-to-string v :readably nil :array t :pretty nil)) unless (string= expected-result actual-result) collect (list i fp expected-result actual-result)))))) nil) (deftest print.vector.fill.3 (with-standard-io-syntax (let ((expected '("#()" "#(0)" "#(0 -1)" "#(0 -1 -2)" "#(0 -1 -2 1)"))) (loop for i from 2 to 100 nconc (let ((v (make-array '(4) :initial-contents '(0 -1 -2 1) :element-type `(signed-byte ,i) :fill-pointer 0))) (loop for fp from 0 to 4 for expected-result in expected for actual-result = (progn (setf (fill-pointer v) fp) (write-to-string v :readably nil :array t :pretty nil)) unless (string= expected-result actual-result) collect (list i fp expected-result actual-result)))))) nil) ;;; Displaced vectors (deftest print.vector.displaced.1 (let* ((v1 (vector 'a 'b 'c 'd 'e 'f 'g)) (v2 (make-array 3 :displaced-to v1 :displaced-index-offset 4))) (with-standard-io-syntax (write-to-string v2 :readably nil :array t :case :downcase :pretty nil :escape nil))) "#(e f g)") (deftest print.vector.displaced.2 (with-standard-io-syntax (loop for i from 2 to 100 nconc (let* ((type `(unsigned-byte ,i)) (v1 (make-array 8 :element-type type :initial-contents '(0 1 2 3 0 1 2 3))) (v2 (make-array 5 :displaced-to v1 :displaced-index-offset 2 :element-type type)) (result (write-to-string v2 :readably nil :array t :pretty nil))) (unless (string= result "#(2 3 0 1 2)") (list (list i v1 v2 result)))))) nil) (deftest print.vector.displaced.3 (with-standard-io-syntax (loop for i from 2 to 100 nconc (let* ((type `(signed-byte ,i)) (v1 (make-array 8 :element-type type :initial-contents '(0 1 -1 -2 0 1 -1 -2))) (v2 (make-array 5 :displaced-to v1 :displaced-index-offset 2 :element-type type)) (result (write-to-string v2 :readably nil :array t :pretty nil))) (unless (string= result "#(-1 -2 0 1 -1)") (list (list i v1 v2 result)))))) nil) ;;; Adjustable vectors (deftest print.vector.adjustable.1 (with-standard-io-syntax (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) :adjustable t))) (write-to-string v :readably nil :array t :case :downcase :pretty nil :escape nil))) "#(a b c d e f g h i j)") (deftest print.vector.adjustable.2 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(8) :initial-contents '(0 1 2 3 3 0 2 1) :adjustable t) for s = (write-to-string v :readably nil :array t :case :downcase :pretty nil :escape nil) unless (string= s "#(0 1 2 3 3 0 2 1)") collect (list i v s))) nil) (deftest print.vector.adjustable.3 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(8) :initial-contents '(0 1 -1 -2 -1 0 -2 1) :adjustable t) for s = (write-to-string v :readably nil :array t :case :downcase :pretty nil :escape nil) unless (string= s "#(0 1 -1 -2 -1 0 -2 1)") collect (list i v s))) nil) ;;; Printing with *print-array* and *print-readably* bound to nil (deftest print.vector.unreadable.1 (with-standard-io-syntax (subseq (write-to-string #(a b c d e) :array nil :readably nil) 0 2)) "#<") (deftest print.vector.unreadable.2 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(0 1 2 3)) for result = (write-to-string v :array nil :readably nil) unless (string= (subseq result 0 2) "#<") collect (list i type v result))) nil) (deftest print.vector.unreadable.3 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(0 1 -2 -1)) for result = (write-to-string v :array nil :readably nil) unless (string= (subseq result 0 2) "#<") collect (list i type v result))) nil) ;;; Readability tests (deftest print.vector.random.1 (trim-list (loop for v in *universe* when (vectorp v) nconc (loop repeat 10 nconc (randomly-check-readability v :test #'equalp :can-fail (not (subtypep t (array-element-type v)))))) 10) nil) (deftest print.vector.random.2 (trim-list (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(1 3 2 0)) nconc (loop repeat 10 nconc (randomly-check-readability v :test #'equalp :can-fail t))) 10) nil) (deftest print.vector.random.3 (trim-list (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(-1 1 0 -2)) nconc (loop repeat 10 nconc (randomly-check-readability v :test #'equalp :can-fail t))) 10) nil) (deftest print.vector.random.4 (trim-list (loop for v = (make-random-vector (1+ (random 100))) repeat 1000 nconc (randomly-check-readability v :test #'equalp)) 10) nil) ;;; *print-length* checks (deftest print.vector.length.1 (with-standard-io-syntax (write-to-string #() :pretty nil :length 0 :readably nil)) "#()") (deftest print.vector.length.2 (with-standard-io-syntax (write-to-string #(1) :pretty nil :length 0 :readably nil)) "#(...)") (deftest print.vector.length.3 (with-standard-io-syntax (write-to-string #(1) :pretty nil :length 1 :readably nil)) "#(1)") (deftest print.vector.length.4 (with-standard-io-syntax (write-to-string #(a b c d e f g h) :pretty nil :array t :escape nil :length 5 :case :downcase :readably nil)) "#(a b c d e ...)") (deftest print.vector.length.5 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(0) :element-type type) for result = (write-to-string v :array t :readably nil :pretty nil :length 0) unless (string= result "#()") collect (list i type v result))) nil) (deftest print.vector.length.6 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(1) :element-type type :initial-contents '(2)) for result = (write-to-string v :pretty nil :array t :readably nil :length 0) unless (string= result "#(...)") collect (list i type v result))) nil) (deftest print.vector.length.7 (with-standard-io-syntax (loop for i from 1 to 100 for type = `(signed-byte ,i) for v = (make-array '(1) :element-type type :initial-contents '(-1)) for result = (write-to-string v :pretty nil :array t :readably nil :length 0) unless (string= result "#(...)") collect (list i type v result))) nil) (deftest print.vector.length.8 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(unsigned-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(1 3 0 2)) for result = (write-to-string v :pretty nil :array t :readably nil :length 2) unless (string= result "#(1 3 ...)") collect (list i type v result))) nil) (deftest print.vector.length.9 (with-standard-io-syntax (loop for i from 2 to 100 for type = `(signed-byte ,i) for v = (make-array '(4) :element-type type :initial-contents '(1 -2 0 -1)) for result = (write-to-string v :pretty nil :array t :readably nil :length 2) unless (string= result "#(1 -2 ...)") collect (list i type v result))) nil) ;;; Printing with *print-level* bound (deftest print.vector.level.1 (with-standard-io-syntax (write-to-string #() :level 0 :readably nil :pretty nil)) "#") (deftest print.vector.level.2 (with-standard-io-syntax (write-to-string #() :level 1 :readably nil :pretty nil)) "#()") (deftest print.vector.level.3 (with-standard-io-syntax (write-to-string #(17) :level 1 :readably nil :pretty nil)) "#(17)") (deftest print.vector.level.4 (with-standard-io-syntax (write-to-string #(4 (17) 9 (a) (b) 0) :level 1 :readably nil :pretty nil)) "#(4 # 9 # # 0)") (deftest print.vector.level.5 (with-standard-io-syntax (write-to-string '(#(a)) :level 1 :readably nil :pretty nil)) "(#)") (deftest print.vector.level.6 (with-standard-io-syntax (write-to-string '#(#(a)) :level 1 :readably nil :pretty nil)) "#(#)") gcl-2.7.1/ansi-tests/PaxHeaders/list.lsp0000644000000000000000000000013114542551762015143 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.601789663 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/list.lsp0000644000175000017500000000310014542551762014534 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:56:04 2003 ;;;; Contains: Tests of LIST, LIST* (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (def-fold-test list.fold.1 (list 'a)) (def-fold-test list.fold.2 (list 'a 'b)) (def-fold-test list.fold.3 (list 'a 'b 'c 'd 'e 'f)) ;;; LIST* tests (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)) (def-fold-test list*.fold.1 (list* 'a 'b)) (def-fold-test list*.fold.2 (list* 'a 'b 'c)) (def-fold-test list*.fold.3 (list* 'a 'b 'c 'd 'e 'f)) gcl-2.7.1/ansi-tests/PaxHeaders/mapcon.lsp0000644000000000000000000000013114542551763015446 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.609789698 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/mapcon.lsp0000644000175000017500000000357614542551763015060 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:24:28 2003 ;;;; Contains: Tests of MAPCON (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (check-type-error #'(lambda (x) (mapcon #'identity x)) #'listp) nil) (deftest mapcon.error.2 (signals-error (mapcon) program-error) t) (deftest mapcon.error.3 (signals-error (mapcon #'append) program-error) t) (deftest mapcon.error.4 (signals-error (locally (mapcon #'identity 1) t) type-error) t) (deftest mapcon.error.5 (signals-error (mapcon #'caar '(a b c)) type-error) t) (deftest mapcon.error.6 (signals-error (mapcon #'cons '(a b c)) program-error) t) (deftest mapcon.error.7 (signals-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapcon.error.8 (signals-error (mapcon #'copy-tree (cons 1 2)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/packages-08.lsp0000644000000000000000000000013114542551763016174 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.617789733 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-08.lsp0000644000175000017500000000726014542551763015600 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/search-bitvector.lsp0000644000000000000000000000013214542551763017436 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.617789733 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/search-bitvector.lsp0000644000175000017500000001225514542551763017041 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on bit vectors (in-package :cl-test) (compile-and-load "search-aux.lsp") (deftest search-bitvector.1 (let ((target *searched-bitvector*) (pat #*0)) (loop for i from 0 to (1- (length target)) for tail = (subseq target i) always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-bitvector.2 (let ((target *searched-bitvector*) (pat #*0)) (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) ;; Order of test, test-not (deftest search-bitvector.17 (let ((pat #*10) (target #*000011)) (search pat target :test #'<=)) 4) (deftest search-bitvector.18 (let ((pat #*10) (target #*000011)) (search pat target :test-not #'>)) 4) gcl-2.7.1/ansi-tests/PaxHeaders/loop2.lsp0000644000000000000000000000013114542551763015224 xustar0030 mtime=1703597043.000022426 29 atime=1744294960.62178975 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop2.lsp0000644000175000017500000000621414542551763014626 0ustar00cammcamm;-*- 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 (signals-error (loop for x in '(a . b) collect x) type-error) t) (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 (signals-error (loop for x in '(a b c) for x in '(d e f) collect x) program-error) t) (deftest loop.2.15 (signals-error (loop for (x . x) in '((a b) (c d)) collect x) program-error) t) (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.2.24 (macrolet ((%m (z) z)) (loop for x in (expand-in-current-env (%m '(1 2 3))) sum x)) 6) (deftest loop.2.25 (macrolet ((%m (z) z)) (loop for (x . y) in (expand-in-current-env (%m '((a . b) (c . d) (e . f)))) collect (list x y))) ((a b) (c d) (e f))) (deftest loop.2.26 (macrolet ((%m (z) z)) (loop as x in (expand-in-current-env (%m '(1 2 3))) sum x)) 6)gcl-2.7.1/ansi-tests/PaxHeaders/pattern-match.lsp0000644000000000000000000000013014542551763016737 xustar0030 mtime=1703597043.012022445 29 atime=1744294960.62178975 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pattern-match.lsp0000644000175000017500000000314014542551763016335 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 4 18:59:27 2004 ;;;; Contains: Macro for pattern matching on S-exprs (in-package :cl-test) (defmacro pmatch (pattern form) (cond ((consp pattern) (let ((pcar (car pattern)) (pcdr (cdr pattern)) (v (gensym))) (case pcar ((:or) `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) pcdr)))) ((:and) `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) pcdr)))) ((:not) (assert (eql (length pcdr) 1)) `(not (pmatch ,(car pcdr) ,form))) (t `(let ((,v ,form)) (and (pmatch ,pcar (car ,v)) (pmatch ,pcdr (cdr ,v)))))))) ((eql pattern '_) t) ((null pattern) `(null ,form)) ((symbolp pattern) `(eql (quote ,pattern) ,form)) (t `(eql ,pattern ,form)))) (defmacro matchcase (form &body cases) (let* ((v (gensym)) (cond-cases (mapcar #'(lambda (case) (assert (consp case)) (let ((pattern (car case)) (body (cdr case))) `((pmatch ,pattern ,v) ,@body))) cases))) `(let ((,v ,form)) (cond ,@cond-cases)))) (defmacro matchcase* (form &body cases) (let* ((block-name (gensym "DONE")) (v (gensym))) `(block ,block-name (let ((,v ,form)) (cond ,@(mapcar #'(lambda (case) (assert (consp case)) (let ((pat (car case)) (forms (cdr case)) (fail-name (gensym "FAIL"))) `((block ,fail-name (and (pmatch ,pat ,v) (macrolet ((fail () '(return-from ,fail-name nil))) (return-from ,block-name (progn ,@forms)))))))) cases)))))) gcl-2.7.1/ansi-tests/PaxHeaders/some.lsp0000644000000000000000000000013114542551763015134 xustar0030 mtime=1703597043.024022464 29 atime=1744294960.62178975 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/some.lsp0000644000175000017500000001700714542551763014540 0ustar00cammcamm;-*- 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) ;;; Other specialized sequences (deftest some.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'plusp v)))) (nil nil nil nil nil t t t t t)) (deftest some.18 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) collect (mod j (ash 1 i))) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'plusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest some.19 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) :element-type type :fill-pointer 4))) (equal (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'minusp v))) '(nil nil nil nil nil t t t t t))) collect i) nil) (deftest some.20 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'character :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest some.21 (let ((v (make-array '(10) :initial-contents "abcd012345" :element-type 'base-char :fill-pointer 4))) (loop for j from 0 to 9 do (setf (fill-pointer v) j) collect (notnot (some #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest some.22 (let ((v (make-array '(5) :initial-contents "abcde" :element-type 'base-char))) (values (some #'digit-char-p v) (setf (aref v 2) #\0) (notnot (some #'digit-char-p v)))) nil #\0 t) (deftest some.23 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) unless (some #'zerop v) collect (list type v)) nil) (deftest some.24 (loop for type in '(short-float single-float double-float long-float) for v = (make-array '(9) :element-type type :fill-pointer 6 :initial-contents (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) when (some #'zerop v) collect (list type v)) nil) (deftest some.25 (loop for type in '(short-float single-float double-float long-float) for ctype = `(complex ,type) for v = (make-array '(6) :element-type ctype :initial-contents (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) when (some (complement #'complexp) v) collect (list type v)) nil) ;;; Displaced vectors (deftest some.26 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2))) (values (notnot (some #'oddp v1)) (some #'oddp v2))) t nil) (deftest some.27 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (some 'oddp v1)) (not (some #'oddp v2))) collect i) nil) (deftest some.28 (loop for i from 1 to 40 for type = `(signed-byte ,i) unless (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) :element-type type)) (v2 (make-array '(4) :displaced-to v1 :displaced-index-offset 2 :element-type type))) (and (some 'oddp v1) (not (some #'oddp v2)))) collect i) nil) (deftest some.29 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'character :displaced-to s1 :displaced-index-offset i) collect (notnot (some 'digit-char-p s2)))) (t t nil nil t t t)) (deftest some.30 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 for s2 = (make-array '(2) :element-type 'base-char :displaced-to s1 :displaced-index-offset i) collect (notnot (some 'digit-char-p s2)))) (t t nil nil t t t)) (deftest some.31 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :adjustable t))) (values (some #'minusp v) (progn (adjust-array v '(11) :initial-element -1) (notnot (some #'minusp v))))) nil t) (deftest some.32 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 10 :adjustable t))) (values (some #'minusp v) (progn (adjust-array v '(11) :initial-element -1) (some #'minusp v)))) nil 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 (check-type-error #'(lambda (x) (some x '(a b c))) (typef '(or symbol function))) nil) (deftest some.error.4 (check-type-error #'(lambda (x) (some #'null x)) #'sequencep) nil) (deftest some.error.7 (check-type-error #'(lambda (x) (some #'eql () x)) #'sequencep) nil) (deftest some.error.8 (signals-error (some) program-error) t) (deftest some.error.9 (signals-error (some #'null) program-error) t) (deftest some.error.10 (signals-error (locally (some 1 '(a b c)) t) type-error) t) (deftest some.error.11 (signals-error (some #'cons '(a b c)) program-error) t) (deftest some.error.12 (signals-error (some #'car '(a b c)) type-error) t) (deftest some.error.13 (signals-error (some #'cons '(a b c) '(b c d) '(c d e)) program-error) t) (deftest some.error.14 (signals-error (some #'null '(a b . c)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/acos.lsp0000644000000000000000000000013114542551762015115 xustar0030 mtime=1703597042.916022294 29 atime=1744294960.62178975 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/acos.lsp0000644000175000017500000000451614542551762014522 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 10 05:39:24 2004 ;;;; Contains: Tess of ACOS (in-package :cl-test) (deftest acos.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (acos i)) for y = (car rlist) always (and (null (cdr rlist)) (numberp y))) t) (deftest acos.2 (loop for type in '(short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (acos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t)) (deftest acos.3 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (acos (complex 0 x))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest acos.4 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x1 = (- (random a) b) for x2 = (- (random a) b) for rlist = (multiple-value-list (acos (complex x1 x2))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest acos.5 (approx= (acos 0) (coerce (/ pi 2) 'single-float)) t) (deftest acos.6 (loop for type in '(single-float short-float double-float long-float) unless (approx= (acos (coerce 0 type)) (coerce (/ pi 2) type)) collect type) nil) (deftest acos.7 (loop for type in '(single-float short-float double-float long-float) unless (approx= (acos (coerce 1 type)) (coerce 0 type)) collect type) nil) (deftest acos.8 (loop for type in '(single-float short-float double-float long-float) unless (approx= (acos (coerce -1 type)) (coerce pi type)) collect type) nil) (deftest acos.9 (macrolet ((%m (z) z)) (not (not (> (acos (expand-in-current-env (%m 0))) 0)))) t) ;;; FIXME ;;; Add accuracy tests ;;; Error tests (deftest acos.error.1 (signals-error (acos) program-error) t) (deftest acos.error.2 (signals-error (acos 0.0 0.0) program-error) t) (deftest acos.error.3 (check-type-error #'acos #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/make-tar0000644000000000000000000000013114542551763015075 xustar0030 mtime=1703597043.000022426 29 atime=1744294960.62178975 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-tar0000755000175000017500000000017614542551763014503 0ustar00cammcammrm -f binary/* rt/binary/* tar cvf cltest.tar README *.system *.lsp make-tar binary/ rt/*.system rt/*.lsp rt/*.txt rt/binary/ gcl-2.7.1/ansi-tests/PaxHeaders/subsetp.lsp0000644000000000000000000000013114542551763015656 xustar0030 mtime=1703597043.024022464 29 atime=1744294960.62178975 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subsetp.lsp0000644000175000017500000001451214542551763015260 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 1 22:10:54 1998 ;;;; Contains: Tests of SUBSETP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (defharmless subsetp.test-and-test-not.1 (subsetp '(a b c) '(a g c e b) :test #'eql :test-not #'eql)) (defharmless subsetp.test-and-test-not.3 (subsetp '(a b c) '(a g c e b) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (subsetp) program-error) t) (deftest subsetp.error.2 (signals-error (subsetp nil) program-error) t) (deftest subsetp.error.3 (signals-error (subsetp nil nil :bad t) program-error) t) (deftest subsetp.error.4 (signals-error (subsetp nil nil :key) program-error) t) (deftest subsetp.error.5 (signals-error (subsetp nil nil 1 2) program-error) t) (deftest subsetp.error.6 (signals-error (subsetp nil nil :bad t :allow-other-keys nil) program-error) t) (deftest subsetp.error.7 (signals-error (subsetp (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest subsetp.error.8 (signals-error (subsetp (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest subsetp.error.9 (signals-error (subsetp (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest subsetp.error.10 (signals-error (subsetp (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest subsetp.error.11 (signals-error (subsetp (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest subsetp.error.12 (signals-error (subsetp (list* 1 2 3) (list 1 2 3 4 5 6)) type-error) t) ;;; The next two tests previously compared against NIL, but arguably ;;; a conforming implementation is not required to signal an error ;;; in these cases, since it doesn't have to traverse the other list. (deftest subsetp.error.13 (check-type-error #'(lambda (x) (subsetp x '(a b))) #'listp) nil) (deftest subsetp.error.14 (check-type-error #'(lambda (x) (subsetp '(a b) x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-13.lsp0000644000000000000000000000013114542551762016330 xustar0030 mtime=1703597042.924022307 29 atime=1744294960.62178975 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-13.lsp0000644000175000017500000001470714542551762015740 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/numberp.lsp0000644000000000000000000000013114542551763015641 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.625789768 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/numberp.lsp0000644000175000017500000000070314542551763015240 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 18:20:36 2003 ;;;; Contains: Tests of NUMBERP (in-package :cl-test) (deftest numberp.error.1 (signals-error (numberp) program-error) t) (deftest numberp.error.2 (signals-error (numberp 0 nil) program-error) t) (deftest numberp.error.3 (signals-error (numberp 'a nil nil) program-error) t) (deftest numberp.1 (check-type-predicate #'numberp 'number) nil) gcl-2.7.1/ansi-tests/PaxHeaders/stream-element-type.lsp0000644000000000000000000000013214542551763020073 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.625789768 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/stream-element-type.lsp0000644000175000017500000000525514542551763017500 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/round.lsp0000644000000000000000000000013214542551763015321 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.625789768 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/round.lsp0000644000175000017500000000707514542551763014730 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 13:39:56 2003 ;;;; Contains: Tests of ROUND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "round-aux.lsp") (deftest round.error.1 (signals-error (round) program-error) t) (deftest round.error.2 (signals-error (round 1.0 1 nil) program-error) t) ;;; (deftest round.1 (round.1-fn) nil) (deftest round.2 (round.2-fn) nil) (deftest round.3 (round.3-fn 2.0s4) nil) (deftest round.4 (round.3-fn 2.0f4) nil) (deftest round.5 (round.3-fn 2.0d4) nil) (deftest round.6 (round.3-fn 2.0l4) nil) (deftest round.7 (round.7-fn) nil) (deftest round.8 (round.8-fn) nil) (deftest round.9 (round.9-fn) nil) (deftest round.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (round x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest round.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (round (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest round.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest round.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (round x)) unless (and (eql q i) (eql r (- rrad))) collect (list i x q r))) nil) (deftest round.20 (round 1/2) 0 1/2) (deftest round.21 (round 3/2) 2 -1/2) gcl-2.7.1/ansi-tests/PaxHeaders/lcm.lsp0000644000000000000000000000013114542551762014743 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.625789768 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/lcm.lsp0000644000175000017500000000407314542551762014346 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 22:03:21 2003 ;;;; Contains: Tests of LCM (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "gcd-aux.lsp") (deftest lcm.error.1 (check-type-error #'lcm #'integerp) nil) (deftest lcm.1 (lcm) 1) (deftest lcm.2 (loop for i = (random-fixnum) for a = (abs i) repeat 1000 unless (and (eql a (lcm i)) (eql a (lcm 1 i))) collect i) nil) (deftest lcm.3 (loop for i = (random-from-interval 10000000000000000) for a = (abs i) repeat 1000 unless (and (eql a (lcm i)) (eql a (lcm i 1))) collect i) nil) (deftest lcm.4 (loop for i = (random-fixnum) for j = (random-fixnum) repeat 1000 unless (eql (my-lcm i j) (lcm i j)) collect (list i j)) nil) (deftest lcm.5 (let ((bound (ash 1 200))) (loop for i = (random-from-interval bound) for j = (random-from-interval bound) repeat 1000 unless (eql (my-lcm i j) (lcm i j)) collect (list i j))) nil) (deftest lcm.6 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) repeat 1000 unless (eql (my-lcm i (my-lcm j k)) (lcm i j k)) collect (list i j k)) nil) (deftest lcm.7 (loop for i = (random-fixnum) for j = (random-fixnum) for k = (random-fixnum) for n = (random-fixnum) repeat 1000 unless (eql (my-lcm (my-lcm i j) (my-lcm k n)) (lcm i j k n)) collect (list i j k n)) nil) (deftest lcm.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) always (eql (apply #'lcm (make-list i :initial-element 1)) 1)) t) (deftest lcm.9 (lcm 0 0) 0) (deftest lcm.10 (lcm 1 0 0) 0) (deftest lcm.11 (lcm 0 1 0) 0) (deftest lcm.12 (lcm 0 0 1) 0) (deftest lcm.order.1 (let ((i 0) x y) (values (lcm (progn (setf x (incf i)) 15) (progn (setf y (incf i)) 25)) i x y)) 75 2 1 2) (deftest lcm.order.2 (let ((i 0) x y) (values (lcm (progn (setf x (incf i)) 0) (progn (setf y (incf i)) 10)) i x y)) 0 2 1 2) (deftest lcm.order.3 (let ((i 0)) (values (lcm (progn (incf i) 0)) i)) 0 1) gcl-2.7.1/ansi-tests/PaxHeaders/lognand.lsp0000644000000000000000000000013214542551763015614 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.625789768 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/lognand.lsp0000644000175000017500000000323414542551763015214 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:11:12 2003 ;;;; Contains: Tests of LOGNAND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest lognand.error.1 (check-type-error #'(lambda (x) (lognand x 0)) #'integerp) nil) (deftest lognand.error.2 (check-type-error #'(lambda (x) (lognand 0 x)) #'integerp) nil) (deftest lognand.error.3 (signals-error (lognand) program-error) t) (deftest lognand.error.4 (signals-error (lognand 0) program-error) t) (deftest lognand.error.5 (signals-error (lognand 1 2 3) program-error) t) ;;; Non-error tests (deftest lognand.1 (lognand 0 0) -1) (deftest lognand.2 (lognand 0 -1) -1) (deftest lognand.3 (lognand -1 123) -124) (deftest lognand.4 (loop for x in *integers* always (and (eql -1 (lognand 0 x)) (eql (lognot x) (lognand x x)) (eql -1 (lognand (lognot x) x)) (eql -1 (lognand x (lognot x))))) t) (deftest lognand.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql -1 (lognand xc x)) collect x) nil) (deftest lognand.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (lognand x y) repeat 1000 unless (and (if (or (>= x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (not (and (logbitp i x) (logbitp i y))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest lognand.order.1 (let ((i 0) a b) (values (lognand (progn (setf a (incf i)) -2) (progn (setf b (incf i)) -3)) i a b)) 3 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/unexport.lsp0000644000000000000000000000013114542551763016055 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.625789768 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/unexport.lsp0000644000175000017500000001170214542551763015455 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:19 1998 ;;;; Contains: Tests of UNEXPORT (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 (signals-error (progn (when (find-package "X") (delete-package "X")) (unexport 'a (make-package "X" :use nil)) nil) package-error) t) ;; 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) ;;; Specialized sequence tests (defmacro def-unexport-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let* ((p (make-package name :use nil)) (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) name) (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)) (def-unexport-test unexport.7 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-unexport-test unexport.8 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'base-char)) (def-unexport-test unexport.9 (make-array 10 :initial-contents "TEST1ABCDE" :fill-pointer 5 :element-type 'character)) (def-unexport-test unexport.10 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-unexport-test unexport.11 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-unexport-test unexport.12 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) (def-unexport-test unexport.13 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 5))) ;;; Error tests (deftest unexport.error.1 (signals-error (unexport) program-error) t) (deftest unexport.error.2 (signals-error (unexport 'xyz "CL-TEST" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/array-in-bounds-p.lsp0000644000000000000000000000013214542551762017440 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.625789768 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-in-bounds-p.lsp0000644000175000017500000001051014542551762017033 0ustar00cammcamm;-*- 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) ;;; Macro expansion (deftest array-in-bounds-p.24 (macrolet ((%m (z) z)) (array-in-bounds-p (expand-in-current-env (%m #(a b))) 3)) nil) (deftest array-in-bounds-p.25 (macrolet ((%m (z) z)) (array-in-bounds-p #(a b) (expand-in-current-env (%m 2)))) 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 (signals-error (array-in-bounds-p) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/echo-stream-output-stream.lsp0000644000000000000000000000013214542551762021227 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.625789768 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/echo-stream-output-stream.lsp0000644000175000017500000000135514542551762020631 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/packages-13.lsp0000644000000000000000000000013114542551763016170 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.625789768 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-13.lsp0000644000175000017500000000234614542551763015574 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/compile-file-test-file.lsp0000644000000000000000000000013014542551762020426 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.629789786 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-file-test-file.lsp0000644000175000017500000000007714542551762020032 0ustar00cammcamm(in-package "CL-TEST") (defun compile-file-test-fun.1 () nil) gcl-2.7.1/ansi-tests/PaxHeaders/do-all-symbols.lsp0000644000000000000000000000013214542551762017027 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.629789786 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/do-all-symbols.lsp0000644000175000017500000000611414542551762016427 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 18:27:22 2004 ;;;; Contains: Tests of DO-ALL-SYMBOLS (in-package :cl-test) (def-macro-test do-all-symbols.error.1 (do-all-symbols (x))) ;;; FIXME Add tests for non-error cases (deftest do-all-symbols.1 (let ((symbols nil)) (do-all-symbols (sym) (push sym symbols)) (let ((hash (make-hash-table :test 'eq))) (with-package-iterator (f (list-all-packages) :internal :external :inherited) (loop (multiple-value-bind (found sym) (f) (unless found (return)) (setf (gethash sym hash) t)))) ;; hash now contains all symbols accessible in any package ;; Check that all symbols from DO-ALL-SYMBOLS are in this ;; package (loop for s in symbols unless (gethash s hash) collect s))) nil) ;; This is the converse of do-all-symbols.1 (deftest do-all-symbols.2 (let ((symbols nil)) (with-package-iterator (f (list-all-packages) :internal :external :inherited) (loop (multiple-value-bind (found sym) (f) (unless found (return))` (push sym symbols)))) (let ((hash (make-hash-table :test 'eq))) (do-all-symbols (s) (setf (gethash s hash) t)) (loop for s in symbols unless (gethash s hash) collect s))) nil) (deftest do-all-symbols.3 (let ((sym (gensym))) (do-all-symbols (s t) (assert (not (eq s sym))))) t) (deftest do-all-symbols.4 (let ((x :bad)) (do-all-symbols (x x))) nil) (deftest do-all-symbols.5 (block nil (do-all-symbols (x (return :bad))) :good) :good) (deftest do-all-symbols.6 (do-all-symbols (x :bad) (return :good)) :good) (deftest do-all-symbols.7 (block done (tagbody (do-all-symbols (x (return-from done :good)) (go 1) (return-from done :bad1) 1) 1 (return-from done :bad2))) :good) (deftest do-all-symbols.8 (block done (tagbody (do-all-symbols (x (return-from done :good)) (go tag) (return-from done :bad1) tag) tag (return-from done :bad2))) :good) ;;; Test that do-all-symbols accepts declarations (deftest do-all-symbols.9 (let ((x 0) (y 1)) (do-all-symbols (z nil) (declare (type (integer * 0) x)) (declare (type (integer 1 *) y)) (declare (ignore z)) (when (< x y) (return :good)))) :good) ;;; Default return is NIL (deftest do-all-symbols.10 (do-all-symbols (s) (declare (ignore s))) nil) ;;; Free declaration scope tests (deftest do-all-symbols.11 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do-all-symbols (s x) (declare (special x))))) :good) ;;; Executing a return actually terminates the loop (deftest do-all-symbols.12 (let ((should-have-returned nil)) (block done (do-all-symbols (s :bad1) (when should-have-returned (return-from done :bad2)) (setq should-have-returned t) (return :good)))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do-all-symbols.13 (macrolet ((%m (z) z)) (do-all-symbols (s (expand-in-current-env (%m :good))))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/rt.lsp0000644000000000000000000000013214542551763014617 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.629789786 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rt.lsp0000644000175000017500000003373414542551763014227 0ustar00cammcamm;-*-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.7.1/ansi-tests/PaxHeaders/format-newline.lsp0000644000000000000000000000013214542551762017120 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.629789786 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-newline.lsp0000644000175000017500000000102714542551762016516 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 27 08:07:16 2004 ;;;; Contains: Tests of ~ (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.newline.1 (concatenate 'string "~" (string #\Newline) " X") nil "X") (def-format-test format.newline.2 (concatenate 'string "A~:" (string #\Newline) " X") nil "A X") (def-format-test format.newline.3 (concatenate 'string "A~@" (string #\Newline) " X") nil #.(concatenate 'string "A" (string #\Newline) "X")) gcl-2.7.1/ansi-tests/PaxHeaders/defclass-01.lsp0000644000000000000000000000013214542551762016173 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.629789786 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defclass-01.lsp0000644000175000017500000004710414542551762015577 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 20:58:54 2003 ;;;; Contains: Tests for DEFCLASS, part 01 (in-package :cl-test) ;;; I've decided to write some 'manual' tests, then refactor these back ;;; to the automatic mechanisms I'll put into defclass-aux.lsp after ;;; I have a better understanding of the object system (defclass class-01 () (s1 s2 s3)) (deftest class-01.1 (notnot-mv (typep (make-instance 'class-01) 'class-01)) t) (deftest class-01.2 (notnot-mv (typep (make-instance (find-class 'class-01)) 'class-01)) t) (deftest class-01.3 (let ((c (make-instance 'class-01))) (values (setf (slot-value c 's1) 12) (setf (slot-value c 's2) 18) (setf (slot-value c 's3) 27) (loop for s in '(s1 s2 s3) collect (slot-value c s)))) 12 18 27 (12 18 27)) ;;;; (defclass class-02 () ((s1) (s2) (s3))) (deftest class-02.1 (notnot-mv (typep (make-instance 'class-02) 'class-02)) t) (deftest class-02.2 (notnot-mv (typep (make-instance (find-class 'class-02)) 'class-02)) t) (deftest class-02.3 (let ((c (make-instance 'class-02))) (values (setf (slot-value c 's1) 12) (setf (slot-value c 's2) 18) (setf (slot-value c 's3) 27) (loop for s in '(s1 s2 s3) collect (slot-value c s)))) 12 18 27 (12 18 27)) ;;;; (defclass class-03 () ((s1 :type integer) (s2 :type t) (s3 :type fixnum))) (deftest class-03.1 (notnot-mv (typep (make-instance 'class-03) 'class-03)) t) (deftest class-03.2 (notnot-mv (typep (make-instance (find-class 'class-03)) 'class-03)) t) (deftest class-03.3 (let ((c (make-instance 'class-03))) (values (setf (slot-value c 's1) 12) (setf (slot-value c 's2) 'a) (setf (slot-value c 's3) 27) (loop for s in '(s1 s2 s3) collect (slot-value c s)))) 12 a 27 (12 a 27)) ;;;; (defclass class-04 () ((s1 :reader s1-r) (s2 :writer s2-w) (s3 :accessor s3-a))) ;;; Readers, writers, and accessors (deftest class-04.1 (let ((c (make-instance 'class-04))) (values (setf (slot-value c 's1) 'a) (setf (slot-value c 's2) 'b) (setf (slot-value c 's3) 'c) (s1-r c) (slot-value c 's2) (s2-w 'd c) (slot-value c 's2) (s3-a c) (setf (s3-a c) 'e) (slot-value c 's3) (s3-a c))) a b c a b d d c e e e) (deftest class-04.2 (notnot-mv (typep #'s1-r 'generic-function)) t) (deftest class-04.3 (notnot-mv (typep #'s2-w 'generic-function)) t) (deftest class-04.4 (notnot-mv (typep #'s3-a 'generic-function)) t) (deftest class-04.5 (notnot-mv (typep #'(setf s3-a) 'generic-function)) t) ;;;; (defclass class-05 () (s1 (s2 :allocation :instance) (s3 :allocation :class))) (deftest class-05.1 (let ((c1 (make-instance 'class-05)) (c2 (make-instance 'class-05))) (values (not (eql c1 c2)) (list (setf (slot-value c1 's1) 12) (setf (slot-value c2 's1) 17) (slot-value c1 's1) (slot-value c2 's1)) (list (setf (slot-value c1 's2) 'a) (setf (slot-value c2 's2) 'b) (slot-value c1 's2) (slot-value c2 's2)) (list (setf (slot-value c1 's3) 'x) (slot-value c1 's3) (slot-value c2 's3) (setf (slot-value c2 's3) 'y) (slot-value c1 's3) (slot-value c2 's3) (setf (slot-value c1 's3) 'z) (slot-value c1 's3) (slot-value c2 's3)) (slot-value (make-instance 'class-05) 's3))) t (12 17 12 17) (a b a b) (x x x y y y z z z) z) ;;;; (defclass class-06 () ((s1 :reader s1-r1 :reader s1-r2 :writer s1-w1 :writer s1-w2))) (defclass class-06a () ((s1 :reader s1-r1) s3)) (deftest class-06.1 (let ((c (make-instance 'class-06))) (values (setf (slot-value c 's1) 'x) (slot-value c 's1) (s1-r1 c) (s1-r2 c) (s1-w1 'y c) (slot-value c 's1) (s1-r1 c) (s1-r2 c) (s1-w2 'z c) (slot-value c 's1) (s1-r1 c) (s1-r2 c))) x x x x y y y y z z z z) (deftest class-06.2 (let ((c1 (make-instance 'class-06)) (c2 (make-instance 'class-06a))) (values (setf (slot-value c1 's1) 'x) (setf (slot-value c2 's1) 'y) (mapcar #'s1-r1 (list c1 c2)))) x y (x y)) ;;;; (defclass class-07 () ((s1 :initarg :s1a :initarg :s1b :reader s1) (s2 :initarg :s2 :reader s2))) (deftest class-07.1 (let ((c (make-instance 'class-07))) (values (slot-boundp c 's1) (slot-boundp c 's2))) nil nil) (deftest class-07.2 (let ((c (make-instance 'class-07 :s1a 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t x nil) (deftest class-07.3 (let ((c (make-instance 'class-07 :s1b 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t x nil) (deftest class-07.4 (let ((c (make-instance 'class-07 :s1a 'y :s1b 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t y nil) (deftest class-07.5 (let ((c (make-instance 'class-07 :s1b 'y :s1a 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t y nil) (deftest class-07.6 (let ((c (make-instance 'class-07 :s1a 'y :s1a 'x))) (values (notnot (slot-boundp c 's1)) (s1 c) (slot-boundp c 's2))) t y nil) (deftest class-07.7 (let ((c (make-instance 'class-07 :s2 'a :s1a 'b))) (values (notnot (slot-boundp c 's1)) (notnot (slot-boundp c 's2)) (s1 c) (s2 c))) t t b a) (deftest class-07.8 (let ((c (make-instance 'class-07 :s2 'a :s1a 'b :s2 'x :s1a 'y :s1b 'z))) (values (notnot (slot-boundp c 's1)) (notnot (slot-boundp c 's2)) (s1 c) (s2 c))) t t b a) (deftest class-07.9 (let ((c (make-instance 'class-07 :s1b 'x :s1a 'y))) (values (notnot (slot-boundp c 's1)) (slot-boundp c 's2) (s1 c))) t nil x) (deftest class-07.10 (let ((c (make-instance 'class-07 :s1a 'x :s2 'y :allow-other-keys nil))) (values (s1 c) (s2 c))) x y) (deftest class-07.11 (let ((c (make-instance 'class-07 :s1a 'a :s2 'b :garbage 'z :allow-other-keys t))) (values (s1 c) (s2 c))) a b) (deftest class-07.12 (let ((c (make-instance 'class-07 :s1a 'd :s2 'c :garbage 'z :allow-other-keys t :allow-other-keys nil))) (values (s1 c) (s2 c))) d c) ;;;; (declaim (special *class-08-s2-initvar*)) (defclass class-08 () ((s1 :initform 0) (s2 :initform *class-08-s2-initvar*))) (deftest class-08.1 (let* ((*class-08-s2-initvar* 'x) (c (make-instance 'class-08))) (values (slot-value c 's1) (slot-value c 's2))) 0 x) ;;;; (declaim (special *class-09-s2-initvar*)) (defclass class-09 () ((s1 :initform 0 :initarg :s1) (s2 :initform *class-09-s2-initvar* :initarg :s2))) (deftest class-09.1 (let* ((*class-09-s2-initvar* 'x) (c (make-instance 'class-09))) (values (slot-value c 's1) (slot-value c 's2))) 0 x) (deftest class-09.2 (let* ((*class-09-s2-initvar* 'x) (c (make-instance 'class-09 :s1 1))) (values (slot-value c 's1) (slot-value c 's2))) 1 x) (deftest class-09.3 (let* ((c (make-instance 'class-09 :s2 'a))) (values (slot-value c 's1) (slot-value c 's2))) 0 a) (deftest class-09.4 (let* ((c (make-instance 'class-09 :s2 'a :s1 10 :s1 'bad :s2 'bad))) (values (slot-value c 's1) (slot-value c 's2))) 10 a) ;;;; (declaim (special *class-10-s1-initvar*)) (defclass class-10 () ((s1 :initform (incf *class-10-s1-initvar*) :initarg :s1))) (deftest class-10.1 (let* ((*class-10-s1-initvar* 0) (c (make-instance 'class-10))) (values *class-10-s1-initvar* (slot-value c 's1))) 1 1) (deftest class-10.2 (let* ((*class-10-s1-initvar* 0) (c (make-instance 'class-10 :s1 10))) (values *class-10-s1-initvar* (slot-value c 's1))) 0 10) ;;;; (let ((x 7)) (defclass class-11 () ((s1 :initform x :initarg :s1)))) (deftest class-11.1 (slot-value (make-instance 'class-11) 's1) 7) (deftest class-11.2 (slot-value (make-instance 'class-11 :s1 100) 's1) 100) ;;; (flet ((%f () 'x)) (defclass class-12 () ((s1 :initform (%f) :initarg :s1)))) (deftest class-12.1 (slot-value (make-instance 'class-12) 's1) x) (deftest class-12.2 (slot-value (make-instance 'class-12 :s1 'y) 's1) y) ;;; (defclass class-13 () ((s1 :allocation :class :initarg :s1))) (deftest class-13.1 (let ((c1 (make-instance 'class-13)) (c2 (make-instance 'class-13 :s1 'foo))) (values (slot-value c1 's1) (slot-value c2 's1))) foo foo) ;;; (defclass class-14 () ((s1 :initarg nil :reader s1))) (deftest class-14.1 (let ((c (make-instance 'class-14 nil 'x))) (s1 c)) x) ;;; (defclass class-15 () ((s1 :initarg :allow-other-keys :reader s1))) ;;; Dicussion on comp.lang.lisp convinced me this test was bogus. ;;; The default value of :allow-other-keys specified in 7.1.2 is not ;;; the same as the default value forms, specified by :default-initargs, ;;; that are used to produce the defaulted initialization argument list. ;;; (deftest class-15.1 ;;; (let ((c (make-instance 'class-15))) ;;; (s1 c)) ;;; nil) (deftest class-15.2 (let ((c (make-instance 'class-15 :allow-other-keys nil))) (s1 c)) nil) (deftest class-15.3 (let ((c (make-instance 'class-15 :allow-other-keys t))) (s1 c)) t) (deftest class-15.4 (let ((c (make-instance 'class-15 :allow-other-keys t :allow-other-keys nil))) (s1 c)) t) (deftest class-15.5 (let ((c (make-instance 'class-15 :allow-other-keys nil :allow-other-keys t))) (s1 c)) nil) (deftest class-15.6 (let ((c (make-instance 'class-15 :allow-other-keys t :foo 'bar))) (s1 c)) t) (deftest class-15.7 (let ((c (make-instance 'class-15 :allow-other-keys t :allow-other-keys nil :foo 'bar))) (s1 c)) t) ;;; Tests of :default-initargs (defclass class-16 () ((s1 :initarg :s1)) (:default-initargs :s1 'x)) (deftest class-16.1 (let ((c (make-instance 'class-16))) (slot-value c 's1)) x) (deftest class-16.2 (let ((c (make-instance 'class-16 :s1 'y))) (slot-value c 's1)) y) (deftest class-16.3 (let ((c (make-instance 'class-16 :s1 nil))) (slot-value c 's1)) nil) ;;; (defclass class-17 () ((s1 :initarg :s1 :initform 'foo)) (:default-initargs :s1 'bar)) (deftest class-17.1 (let ((c (make-instance 'class-17))) (slot-value c 's1)) bar) (deftest class-17.2 (let ((c (make-instance 'class-17 :s1 'z))) (slot-value c 's1)) z) (deftest class-17.3 (let ((c (make-instance 'class-17 :s1 nil))) (slot-value c 's1)) nil) ;;; (defclass class-18 () ((s1 :initarg :s1 :initarg :s1b)) (:default-initargs :s1 'x :s1b 'y)) (deftest class-18.1 (let ((c (make-instance 'class-18))) (slot-value c 's1)) x) (deftest class-18.2 (let ((c (make-instance 'class-18 :s1 'z))) (slot-value c 's1)) z) (deftest class-18.3 (let ((c (make-instance 'class-18 :s1 nil))) (slot-value c 's1)) nil) (deftest class-18.4 (let ((c (make-instance 'class-18 :s1b 'z))) (slot-value c 's1)) z) (deftest class-18.5 (let ((c (make-instance 'class-18 :s1b nil))) (slot-value c 's1)) nil) ;;; (declaim (special *class-19-s1-initvar*)) (defclass class-19 () ((s1 :initarg :s1)) (:default-initargs :s1 (setf *class-19-s1-initvar* 'a))) (deftest class-19.1 (let* ((*class-19-s1-initvar* nil) (c (make-instance 'class-19))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) *class-19-s1-initvar*)) a a) (deftest class-19.2 (let* ((*class-19-s1-initvar* nil) (c (make-instance 'class-19 :s1 nil))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) *class-19-s1-initvar*)) nil nil) (deftest class-19.3 (let* ((*class-19-s1-initvar* nil) (c (make-instance 'class-19 :s1 'x))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) *class-19-s1-initvar*)) x nil) ;;; (declaim (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (defclass class-20 () ((s1 :initarg :s1 :initarg :s1b)) (:default-initargs :s1 (setf *class-20-s1-initvar-1* 'a) :s1b (setf *class-20-s1-initvar-2* 'b))) (deftest class-20.1 (let* (*class-20-s1-initvar-1* *class-20-s1-initvar-2* (c (make-instance 'class-20))) (declare (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) a a b) (deftest class-20.2 (let* (*class-20-s1-initvar-1* *class-20-s1-initvar-2* (c (make-instance 'class-20 :s1 'x))) (declare (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) x nil b) (deftest class-20.3 (let* (*class-20-s1-initvar-1* *class-20-s1-initvar-2* (c (make-instance 'class-20 :s1b 'y))) (declare (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) y a nil) ;;; (declaim (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (let ((*class-21-s1-initvar-1* 0) (*class-21-s1-initvar-2* 0)) (defclass class-21 () ((s1 :initarg :s1 :initarg :s1b) (s2 :initarg :s1b :initarg :s2)) (:default-initargs :s1 (incf *class-21-s1-initvar-1*) :s1b (incf *class-21-s1-initvar-2*)))) (deftest class-21.1 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) 11 21 11 21) (deftest class-21.2 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s1 'x))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) x 21 10 21) (deftest class-21.3 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s1 'x :s1b 'y))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) x y 10 20) (deftest class-21.4 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s1b 'y))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) y y 11 20) (deftest class-21.5 (let* ((*class-21-s1-initvar-1* 10) (*class-21-s1-initvar-2* 20) (c (make-instance 'class-21 :s2 'y))) (declare (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) 11 y 11 21) ;;; Documentation strings (defclass class-22 () ((s1 :documentation "This is slot s1 in class class-22"))) (deftest class-22.1 (notnot-mv (typep (make-instance 'class-22) 'class-22)) t) ;;; We can't portably get at the docstring of slots ;;; (defclass class-23 () (s1 s2 s3) (:documentation "This is class-23 in ansi-tests")) (deftest class-23.1 (notnot-mv (typep (make-instance 'class-23) 'class-23)) t) (deftest class-23.2 (let ((doc (documentation 'class-23 'type))) (or (null doc) (equalt doc "This is class-23 in ansi-tests"))) t) (deftest class-23.3 (let ((doc (documentation (find-class 'class-23) 'type))) (or (null doc) (equalt doc "This is class-23 in ansi-tests"))) t) (deftest class-23.4 (let ((doc (documentation (find-class 'class-23) t))) (or (null doc) (equalt doc "This is class-23 in ansi-tests"))) t) ;;; (defclass class-24 () ((s1 :initarg :allow-other-keys :reader s1)) (:default-initargs :allow-other-keys t)) (deftest class-24.1 (s1 (make-instance 'class-24)) t) (deftest class-24.2 (s1 (make-instance 'class-24 :nonsense t)) t) (deftest class-24.3 (s1 (make-instance 'class-24 :allow-other-keys nil)) nil) (deftest class-24.4 (s1 (make-instance 'class-24 :allow-other-keys 'a :foo t)) a) ;;; (defclass class-25 () ((s1 :initarg :allow-other-keys :reader s1)) (:default-initargs :allow-other-keys nil)) (deftest class-25.1 (s1 (make-instance 'class-25)) nil) (deftest class-25.2 (s1 (make-instance 'class-25 :allow-other-keys t)) t) (deftest class-25.3 (s1 (make-instance 'class-25 :allow-other-keys t :foo nil)) t) (deftest class-25.4 (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil)) t) (deftest class-25.5 (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil :foo t)) t) (deftest class-25.6 (s1 (make-instance 'class-25 :allow-other-keys 'foo :allow-other-keys 'bar)) foo) ;;; (defclass class-26 () ((s1-26 :writer (setf s1-26)))) (deftest class-26.1 (let ((c (make-instance 'class-26))) (values (slot-boundp c 's1-26) (setf (s1-26 c) 'x) (slot-value c 's1-26) (typep* #'(setf s1-26) 'generic-function))) nil x x t) ;;; (defclass class-27 () (a (b :initform 10) (c :initarg :c) (d :initarg :d)) (:metaclass standard-class) (:default-initargs :d 17)) (deftest class-27.1 (let ((class (find-class 'class-27))) (values (subtypep* 'class-27 'standard-object) (subtypep* 'class-27 t) (subtypep* 'class-27 (find-class 'standard-object)) (subtypep* 'class-27 (find-class t)) (subtypep* class 'standard-object) (subtypep* class t) (subtypep* class (find-class 'standard-object)) (subtypep* class (find-class t)))) t t t t t t t t) (deftest class-27.2 (let ((c (make-instance 'class-27))) (values (slot-boundp* c 'a) (slot-value c 'b) (slot-boundp* c 'c) (slot-value c 'd))) nil 10 nil 17) (deftest class-27.3 (let ((c (make-instance 'class-27 :c 26 :d 43))) (values (slot-boundp* c 'a) (slot-value c 'b) (slot-value c 'c) (slot-value c 'd))) nil 10 26 43) ;;; (declaim (special *class-28-reset-fn* *class-28-query-fn*)) (declaim (type function *class-28-reset-fn* *class-28-query-fn*)) (let ((x 0) (y 0)) (flet ((%reset (a b) (setf x a y b)) (%query () (list x y))) (setf *class-28-reset-fn* #'%reset *class-28-query-fn* #'%query) (defclass class-28 () ((s1 :initform (incf x) :initarg :s1) (s2 :initarg :s2)) (:default-initargs :s2 (incf y))))) (deftest class-28.1 (let ((class (find-class 'class-28))) (funcall *class-28-reset-fn* 5 10) (list (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28))) (list (typep* obj 'class-28) (typep* obj class) (eqt (class-of obj) class) (map-slot-value obj '(s1 s2)) (funcall *class-28-query-fn*))))) ((5 10) (t t t (6 11) (6 11)))) (deftest class-28.2 (let ((class (find-class 'class-28))) (funcall *class-28-reset-fn* 5 10) (list (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28 :s1 17))) (list (typep* obj 'class-28) (typep* obj class) (eqt (class-of obj) class) (map-slot-value obj '(s1 s2)) (funcall *class-28-query-fn*))))) ((5 10) (t t t (17 11) (5 11)))) (deftest class-28.3 (let ((class (find-class 'class-28))) (funcall *class-28-reset-fn* 5 10) (list (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28 :s2 17))) (list (typep* obj 'class-28) (typep* obj class) (eqt (class-of obj) class) (map-slot-value obj '(s1 s2)) (funcall *class-28-query-fn*))))) ((5 10) (t t t (6 17) (6 10)))) gcl-2.7.1/ansi-tests/PaxHeaders/add-method.lsp0000644000000000000000000000013214542551762016177 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.629789786 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/add-method.lsp0000644000175000017500000000767714542551762015616 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 19:12:25 2003 ;;;; Contains: Tests for ADD-METHOD (in-package :cl-test) (defgeneric add-method-gf-01 (x) (:method ((x t)) 'a)) (defgeneric add-method-gf-02 (x)) ;;; Cannot add a method that's already in another method (deftest add-method.error.1 (let ((method (find-method #'add-method-gf-01 nil (list (find-class t))))) (handler-case (add-method #'add-method-gf-02 method) (error () :error))) :error) ;;; The lambda lists must be congruent (deftest add-method.error.2 (let* ((gf (eval '(defgeneric add-method-gf-03 (x) (:method ((x t)) 'a)))) (method (find-method #'add-method-gf-03 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-04 (x y))))) (handler-case (add-method gf2 method) (error () :error))) :error) (deftest add-method.error.3 (let* ((gf (eval '(defgeneric add-method-gf-05 (x &optional y) (:method ((x t) &optional y) 'a)))) (method (find-method #'add-method-gf-05 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-06 (x y))))) (handler-case (add-method gf2 method) (error () :error))) :error) (deftest add-method.error.4 (signals-error (add-method) program-error) t) (deftest add-method.error.5 (signals-error (add-method #'add-method-gf-01) program-error) t) (deftest add-method.error.6 (signals-error (let* ((gf (eval '(defgeneric add-method-gf-07 (x) (:method ((x t)) 'a)))) (method (find-method #'add-method-gf-07 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-08 (x))))) (remove-method gf method) (add-method gf2 method nil)) program-error) t) (deftest add-method.error.7 (let* ((gf (eval '(defgeneric add-method-gf-09 (x y) (:method ((x t) (y t)) 'a)))) (method (find-method #'add-method-gf-09 nil (list (find-class t) (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-10 (x &optional y))))) (remove-method gf method) (handler-case (add-method gf2 method) (error () :error))) :error) (deftest add-method.error.8 (let* ((gf (eval '(defgeneric add-method-gf-11 (x &key y) (:method ((x t) &key y) 'a)))) (method (find-method #'add-method-gf-11 nil (list (find-class t)))) (gf2 (eval '(defgeneric add-method-gf-12 (x))))) (remove-method gf method) (handler-case (add-method gf2 method) (error () :error))) :error) ;;; Non-error tests (deftest add-method.1 (let* ((gf (eval '(defgeneric add-method-gf-13 (x) (:method ((x integer)) 'a) (:method ((x t)) 'b)))) (method (find-method #'add-method-gf-13 nil (list (find-class 'integer)))) (gf2 (eval '(defgeneric add-method-gf-14 (x))))) (declare (type generic-function gf gf2)) (values (funcall gf 0) (funcall gf 'x) (eqt gf (remove-method gf method)) (eqt gf2 (add-method gf2 method)) (funcall gf 0) (funcall gf 'x) (funcall gf2 0))) a b t t b b a) ;;; An existing method is replaced. (deftest add-method.2 (let* ((specializers (list (find-class 'integer))) (gf (eval '(defgeneric add-method-gf-15 (x) (:method ((x integer)) 'a) (:method ((x t)) 'b)))) (method (find-method gf nil specializers)) (gf2 (eval '(defgeneric add-method-gf-16 (x) (:method ((x integer)) 'c) (:method ((x t)) 'd)))) (method2 (find-method gf2 nil specializers))) (declare (type generic-function gf gf2)) (values (funcall gf 0) (funcall gf 'x) (funcall gf2 0) (funcall gf2 'x) (eqt gf (remove-method gf method)) (eqt gf2 (add-method gf2 method)) (eqt method (find-method gf2 nil specializers)) (eqt method2 (find-method gf2 nil specializers)) (funcall gf 0) (funcall gf 'x) (funcall gf2 0) (funcall gf2 'x))) a b c d t t t nil b b a d) ;;; Must add tests for: :around methods, :before methods, :after methods, ;;; nonstandard method combinations gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-22.lsp0000644000000000000000000000013214542551762016331 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.629789786 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-22.lsp0000644000175000017500000003261114542551762015732 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/misc.lsp0000644000000000000000000000013114542551763015124 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.629789786 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/misc.lsp0000644000175000017500000131534714542551763014541 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 20 09:45:15 2003 ;;;; Contains: Miscellaneous tests ;;; ;;; This file contains odds-and-ends, mostly tests that came up as ;;; bug-stimulators in various implementations. ;;; (in-package :cl-test) (declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)) (deftest misc.1 (funcall (compile nil '(lambda (b) (declare (type (integer 8 22337) b)) (+ b 2607688420))) 100) 2607688520) (deftest misc.2 (funcall (compile nil '(lambda (b) (integer-length (dpb b (byte 4 28) -1005)))) 12800263) 32) (deftest misc.3 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (debug 1))) (let ((v7 (let ((v2 (block b5 (return-from b5 (if t b -4))))) a))) -65667836))) 1 2) -65667836) (deftest misc.4 (funcall (compile nil '(lambda (a b c) (declare (type (integer -629491 -333) a) (type (integer -142 1) b) (type (integer 0 12604) c) (optimize (speed 3) (safety 1) (debug 1))) (let ((v6 (block b7 (return-from b7 (if (eql b 0) 1358159 a))))) b))) -1000 -17 6143) -17) (deftest misc.5 (funcall (compile nil '(lambda () (* 390 (- (signum (logeqv -8005440 -2310)) -10604863))))) 4135896180) (deftest misc.6 (funcall (compile nil '(lambda (a c) (declare (optimize (speed 3) (debug 1))) (flet ((%f14 () (if c a -486826646))) (let ((v7 (flet ((%f18 () (%f14))) a))) (let ((v5 (%f14))) 0))))) 10 20) 0) (deftest misc.7 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (debug 1))) (flet ((%f18 () -36)) (flet ((%f13 () (let () (block b8 (return-from b8 c))))) (%f18))))) 10) -36) (deftest misc.8 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (debug 1))) (let ((v3 (flet ((%f12 () (min b (block b2 (return-from b2 a))))) a))) (block b7 (flet ((%f5 () (return-from b7 b))) (%f5)))))) 10 20) 20) (deftest misc.9 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (debug 1))) (block b6 (flet ((%f3 () (ldb (byte 19 23) (block b1 (let () (- (if nil (return-from b6 89627) 1160) (return-from b1 22923))))))) 1))))) 1) (deftest misc.10 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (debug 1)) (type (integer -15417757 5816) c)) (flet ((%f3 () (if nil -3143 c))) (block b5 (let ((v7 (if (< 23613642 (%f3)) c -23097977))) (let ((v5 (return-from b5 (if (eql c v7) (let ((v6 (%f3))) 4650813) 782)))) -4362540)))))) -10000) 782) (deftest misc.11 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (debug 1))) (block b8 (logxor (let ((v3 (return-from b8 120789657))) 3690) (block b2 (flet ((%f9 () (flet ((%f10 () -1)) c))) (flet ((%f3 () (let () (return-from b2 b)))) a))))))) 1 2 3) 120789657) (deftest misc.12 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer -171067 -5) c)) (flet ((%f16 () (flet ((%f12 () 439)) 3358))) (flet ((%f14 () c)) (if (%f14) -1 (%f14)))))) -100) -1) (deftest misc.13 (funcall (compile nil '(lambda (b c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer -1554410 36086789) b) (type (integer -15033876209 126774299) c) ) (block b3 (flet ((%f9 () (abs (flet ((%f5 () (return-from b3 -2))) (if (if (<= 1 c) b (%f5)) -65 -47895812))))) (min (let ((v3 (let ((v8 (%f9))) b))) b) (if (= 1364001 (%f9)) (logeqv (block b5 -2713) -247) -19)))))) 0 0) -2) (deftest misc.14 (funcall (compile nil '(lambda (c) (declare (notinline logandc1)) (block b6 (flet ((%f17 () (return-from b6 c))) (logandc1 (%f17) (if 1 450967818 (let ((v1 (%f17))) -17))))))) 10) 10) (deftest misc.15 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (safety 1) (debug 1))) (flet ((%f6 () a)) (block b5 (flet ((%f14 () (min 17593 (block b1 (return-from b1 b))))) (block b7 (if (%f6) (return-from b7 28182012) (return-from b5 0)))))))) 3 5) 28182012) (deftest misc.16 (funcall (compile nil '(lambda (a c) (flet ((%f14 () (block b6 (flet ((%f7 () (return-from b6 4))) (if 587793 (if (%f7) c -23086423) (%f7)))))) (block b1 (flet ((%f18 () a)) (logandc1 (return-from b1 -2781) (if (%f14) 58647578 -396746))))))) 1 2) -2781) (deftest misc.17 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer 4 23363) b) (type (integer -32681 41648) c) ) (flet ((%f18 () (if nil c b))) (if (if (> -71810514 a) 102077 465393) (block b3 (if (%f18) (return-from b3 c) c)) (%f18))))) 0 10 1000) 1000) (deftest misc.18 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1) (debug 1)) (type (integer 7 58010860) a) (type (integer -3573280 -1) b) (type (integer -920848 -819) c) ) (flet ((%f15 () (if (logbitp 5 a) a c))) (min (if (%f15) b -39) (if (> 0 -14756) b (%f15)))))) 8 -1000 -10000) -1000) (deftest misc.19 (funcall (compile nil '(lambda (a b c) (declare (type (integer 54 3862515) a) (type (integer -961325 1539) b) (type (integer 6 31455) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (lognor (flet ((%f13 () b)) (%f13)) (flet ((%f1 () (return-from %f1 a))) (labels ((%f3 () (%f1))) -428))))) 100 0 200) 427) (deftest misc.20 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1 31880308) a) (type (integer -11374222037 5331202966) b) (type (integer -483 -1) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f6 () a)) (if (eql (let ((v9 (%f6))) -50072824) c) 28146341 (if (< 119937 21304962) 21304962 (%f6)))))) 0 0 -1) 21304962) (deftest misc.21 (funcall (compile nil '(lambda (a b c) (declare (type (integer 398 3955) a) (type (integer 233 464963) b) (type (integer -124477 16) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (logior (flet ((%f18 () -3584768)) (%f18)) (flet ((%f1 () (return-from %f1 c))) (flet ((%f9 () (if (%f1) 24181 7))) 56048))))) 400 300 0) -3547152) (deftest misc.22 (funcall (compile nil '(lambda (a b c) (declare (type (integer -126378 -103) a) (type (integer -1158604975 1) b) (type (integer 502 28036) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f13 () c)) (labels ((%f3 () (logandc1 c (block b6 (max -73100 (if b (return-from b6 4935) (%f13))))))) (%f13))))) -200 0 1000) 1000) (deftest misc.23 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1 18911480) a) (type (integer -1 48333) b) (type (integer -3881001767 -1937357) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f10 () c)) (block b7 (logorc2 (* (%f10) (if (ldb-test (byte 27 1) -11337) (return-from b7 -2) 246137101)) (min (%f10) (return-from b7 -76114))))))) 1 0 -2000000) -2) (deftest misc.24 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1477249397 -10697252) a) (type (integer -7 54591) b) (type (integer -102559556 15) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (block b8 (let ((v1 (return-from b8 a))) (1+ (block b3 (flet ((%f10 () (min a (return-from b3 -1)))) 16776220))))))) -11000000 0 0) -11000000) (deftest misc.25 (funcall (compile nil '(lambda (a b c) (declare (type (integer -944 111244) a) (type (integer 100512 3286178) b) (type (integer -2170236 -107) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f17 () c)) (labels ((%f16 () a)) (if (if (logbitp 10 1029643) t 355) (if (equal (%f17) b) c a) (if (= 1325844 (%f16)) -50285 (1- (%f17)))))))) 0 200000 -200) 0) (deftest misc.26 (funcall (compile nil '(lambda (c) (declare (optimize speed)) (block b5 (if (logbitp 6 -97) (let ((v2 (block b8 -42484))) c) (flet ((%f10 () (return-from b5 -785143))) (let ((v3 (%f10))) (%f10))))))) 0) -785143) (deftest misc.27 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (debug 1))) (labels ((%f14 () c)) (logand (%f14) (labels ((%f15 () (logeqv (let ((v1 b)) c) (return-from %f15 -1740)))) (labels ((%f8 () (%f15))) a)))))) 5 2 3) 1) (deftest misc.28 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1948 12024) b) (type (integer -104357939 -252) c) (optimize (speed 3) (debug 1))) (flet ((%f18 () c)) (logandc1 (if (eql b (%f18)) 0 a) (if (ldb-test (byte 30 30) 1) (%f18) 1) )))) 0 2000 -300) 1) (deftest misc.29 (funcall (compile nil '(lambda (a b c) (declare (type (integer 661607 10451683348) a) (type (integer -2 -2) b) (type (integer 5996117 18803237) c) (optimize (speed 3) (safety 1) (debug 1))) (labels ((%f16 () -29)) (flet ((%f7 () (labels ((%f1 () a)) (let () (block b3 (if 37101207 (return-from b3 -5322045) (let ((v5 b)) 146099574))))))) (if (%f16) c c))))) 1000000 -2 6000000) 6000000) (deftest misc.30 (funcall (compile nil '(lambda (c) (declare (type (integer -253 -1) c) (optimize (speed 3) (safety 1) (debug 1))) (flet ((%f8 () c)) (if (= (%f8) 481) (%f8) 1779465)))) -100) 1779465) (deftest misc.31 (funcall (compile nil '(lambda () (let ((v9 (labels ((%f13 () nil)) nil))) (let ((v3 (logandc2 97 3))) (* v3 (- 37391897 (logand v3 -66)))))))) 3589619040) (deftest misc.32 (funcall (compile nil '(lambda (a d) (declare (type (integer -8507 26755) a) (type (integer -393314538 2084485) d) (optimize (speed 3) (safety 1) (debug 1))) (gcd (if (= 0 a) 10 (abs -1)) (logxor -1 (min -7580 (max (logand a 31365125) d)))))) 1 1) 1) (deftest misc.33 (funcall (compile nil '(lambda (a b c d) (declare (type (integer 240 100434465) a) (optimize (speed 3) (safety 1) (debug 1))) (logxor (if (ldb-test (byte 27 4) d) -1 (max 55546856 -431)) (logorc2 (if (>= 0 b) (if (> b c) (logandc2 c d) (if (> d 224002) 0 d)) (signum (logior c b))) (logior a -1))))) 256 0 0 0) 55546856) (deftest misc.34 (funcall (compile nil `(lambda (b c) (declare (type (integer -23228343 2) b) (type (integer -115581022 512244512) c) (optimize (speed 3) (safety 1) (debug 1))) (* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b)) (deposit-field b (byte 25 27) -30424886)) (dpb b (byte 23 29) c) ))) 0 0) 0) (deftest misc.35 (funcall (compile nil '(lambda (c) (declare (type (integer -5945502333 12668542) c) (optimize (speed 3))) (let ((v2 (* c 12))) (- (max (if (/= 109335113 v2) -26479 v2) (deposit-field 311 (byte 14 28) (min (max 521326 c) -51))))))) 12668542) 26479) (deftest misc.36 (funcall (compile nil '(lambda () (declare (notinline + logand) (optimize (speed 0))) (logand (block b5 (flet ((%f1 () (return-from b5 -220))) (let ((v7 (%f1))) (+ 359749 35728422)))) -24076)))) -24284) (deftest misc.37 (funcall (compile nil '(lambda (b) (declare (notinline -) (optimize (speed 0))) (- (block b4 (flet ((%f4 () (return-from b4 b))) (%f4)))))) 10) -10) (deftest misc.38 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logandc1 x x))) 79) 0) (deftest misc.39 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logandc2 x x))) 79) 0) (deftest misc.40 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logorc1 x x))) 79) -1) (deftest misc.41 (funcall (compile nil '(lambda (x) (declare (type (integer 0 100) x) (optimize (speed 3) (safety 1))) (logorc2 x x))) 79) -1) (deftest misc.42 (funcall (compile nil '(lambda (x) (declare (type (integer -100 100) x)) (ldb (byte 1 32) x))) -1) 1) (deftest misc.43 (funcall (compile nil '(lambda () (flet ((%f2 () 288213285)) (+ (%f2) (* 13 (%f2))))))) 4034985990) (deftest misc.44 (funcall (compile nil '(lambda (a) (declare (type (integer -917858 964754309) a) (optimize (speed 3))) (* 25 (min (max a 171625820) 171626138)))) 861929141) 4290653450) (deftest misc.45 (funcall (compile nil '(lambda (b) (declare (type (integer 21 9673) b) (optimize (speed 3))) (* (integer-length -198435631) (+ b 137206182)))) 6027) 3841941852) (deftest misc.46 (funcall (compile nil '(lambda (b c) (declare (type (integer 0 1) b) (optimize (speed 3))) (flet ((%f2 () (lognor (block b5 138) c))) (if (not (or (= -67399 b) b)) (deposit-field (%f2) (byte 11 8) -3) c)))) 0 0) 0) (deftest misc.47 (funcall (compile nil '(lambda (a) (declare (type (integer -4005718822 -50081775) a) (optimize (speed 3) (safety 1) (debug 1))) (lognor (ash a (min 0 a)) a))) -2878148992) 0) (deftest misc.48 (funcall (compile nil '(lambda (a) (declare (notinline ash min)) (lognor (ash a (min 0 a)) a))) -2878148992) 0) (deftest misc.49 (let ((body '(truncate (logorc1 -996082 C) -2)) (arg 25337234)) (values (funcall (compile nil `(lambda (c) ,body)) arg) (funcall (compile nil `(lambda (c) (declare (notinline truncate)) ,body)) arg))) -13099001 -13099001) (deftest misc.50 (funcall (compile nil `(lambda (c) (declare (optimize (speed 3)) (type (integer 23062188 149459656) c)) (mod c (min -2 0)))) 95019853) -1) (deftest misc.51 (funcall (compile nil `(lambda (b) (declare (optimize (speed 3)) (type (integer 2 152044363) b)) (rem b (min -16 0)))) 108251912) 8) (deftest misc.53 (funcall (compile nil '(lambda () (let (x) (block nil (flet ((%f (y z) (if (> y z) (setq x y) (setq x z)))) (%f 1 2) (%f (return 14) 2))) x)))) 2) (deftest misc.54 (funcall (compile nil '(lambda (a c) (declare (type (integer 8 117873977) a) (type (integer -131828754 234037511) c) (optimize (speed 3) (safety 1) (debug 1))) (* (mod (signum a) (max 50 -358301)) (* -2320445737132 (* (* a (deposit-field a (byte 32 19) a)) c))))) 11386 165297671) -49725654774521915007942373712) (deftest misc.55 (funcall (compile nil '(lambda (a b c) (declare (type (integer -5498929 389890) a) (type (integer -5029571274946 48793670) b) (type (integer 9221496 260169518304) c) (ignorable a b c) (optimize (speed 3) (safety 1) (debug 1))) (- (mod 1020122 (min -49 -420)) (logandc1 (block b2 (mod c (min -49 (if t (return-from b2 1582) b)))) (labels ((%f14 () (mod a (max 76 8)))) b))))) -1893077 -2965238893954 30902744890) 2965238894454) (deftest misc.56 (funcall (compile nil '(lambda (a c) (declare (type (integer -8691408487404 -9) a) (type (integer 266003133 2112105962) c) (optimize (speed 3) (safety 1) (debug 1))) (truncate (max (round a) c) (* (* a a) a)))) -10 266003133) -266003 133) (deftest misc.57 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1907 58388940297) a) (type (integer -646968358 294016) b) (type (integer -708435313 89383896) c) (optimize (speed 3) (safety 1) (debug 1))) (let ((v6 (abs (min a (signum c))))) (if (ceiling v6 (max 77 v6)) b 2)))) 50005747335 -363030456 17382819) -363030456) (deftest misc.58 (funcall (compile nil '(lambda (a) (declare (type (integer -23 66141285) a) (optimize (speed 3))) (logorc2 (setq a 35191330) (* a 107)))) 4099241) -3764388885) (deftest misc.59 (funcall (compile nil '(lambda (a b c) (declare (type (integer -3966039360 -879349) a) (type (integer -62642199164 -8993827395) b) (type (integer -8065934654337 223) c) (optimize (speed 3) (safety 1) (debug 1))) (floor (* (ceiling c) c) (max 78 (* b (* a (* a b))))))) -1000000 -10000000000 0) 0 0) (deftest misc.60 (funcall (compile nil '(lambda () (let ((v5 46660)) (setq v5 (signum (rem v5 (max 53 v5)))))))) 0) (deftest misc.61 (progn (compile nil '(lambda (a b) (declare (type (integer -1785799651 -2) a) (type (integer -27 614132331) b) (optimize (speed 3) (safety 1) (debug 1))) (ceiling (max (floor -733432 (max 84 -20)) 346) (min -10 (* 17592186028032 (* (* a b) a)))))) :good) :good) (deftest misc.62 (funcall (compile nil '(lambda (a) (if (and (if a t nil) nil) a (min (block b5 -1) a)))) 100) -1) ;;; sbcl bug (probably #233) (deftest misc.63 (let* ((form '(flet ((%f12 () (setq c -9868204937))) (if (<= c (%f12)) -2 (if (= c c) b c)))) (form1 `(lambda (b c) (declare (type (integer -80421740610 1395590616) c)) ,form)) (form2 `(lambda (b c) ,form)) (vals '(-696742851945 686256271))) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) ;;; sbcl bug (probably #233) (deftest misc.64 (let* ((form '(logcount (if (not (> c (let ((v7 (setq c -246180))) -1))) (ldb (byte 24 11) c) c))) (form1 `(lambda (c) (declare (type (integer -256128 207636) c)) ,form)) (form2 `(lambda (c) ,form)) (vals '(11292)) ) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) ;;; sbcl bug (probably #233) (deftest misc.65 (let ((form1 '(lambda (b c) (declare (type (integer -350684427436 -255912007) b)) (logandc2 c (if (< b (setq b -25647585550)) b 0)))) (form2 '(lambda (b c) (logandc2 c (if (< b (setq b -25647585550)) b 0)))) (vals '(-297090677547 -20121092))) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) (deftest misc.66 (let* ((form '(if (> a (setq a -2198578292)) (min b (if (<= a -14866) a -128363)) a)) (form1 `(lambda (a b) (declare (type (integer -3709231882 0) a)) (declare (type (integer -562051054 -1) b)) ,form)) (form2 `(lambda (a b) ,form)) (vals '(-2095414787 -256985442))) (eqlt (apply (compile nil form1) vals) (apply (compile nil form2) vals))) t) ;;; sbcl/cmucl bug (on sparc) (deftest misc.67 (funcall (compile nil '(lambda (x) (declare (type (integer 10604862 10604862) x) (optimize speed)) (* x 390))) 10604862) 4135896180) ;;; cmucl bug (cvs, 10/10/2003) (deftest misc.68 (funcall (compile nil '(lambda (b) (flet ((%f8 () (rem b (identity (return-from %f8 0))))) (lognor (%f8) 0)))) 0) -1) (deftest misc.69 (funcall (compile nil '(lambda (b) (flet ((%f11 () (logorc2 (block b1 (let () (return-from b1 b))) -1984))) b))) 0) 0) (deftest misc.70 (funcall (compile nil '(lambda (c) (declare (type (integer 46156191457 126998564334) c)) (truncate c (min -16 186196583)))) 87723029763) -5482689360 3) (deftest misc.71 (funcall (compile nil '(lambda () (block b8 (if (identity (return-from b8 30)) 1 (identity (block b5 (labels ((%f10 () (min -52 (return-from b5 10)))) 20)))))))) 30) (deftest misc.72 (funcall (compile nil '(lambda () (flet ((%f13 () (rem 1 (min 0 (return-from %f13 17))))) (%f13))))) 17) (deftest misc.73 (funcall (compile nil '(lambda (c) (declare (type (integer 46156191457 126998564334) c)) (rem c (min -1 0)))) 87723029763) 0) (deftest misc.74 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (speed 0) (debug 0))) (ash 6916244 (min 42 -185236061640))))) 0) ;;; Unwind-protect bug, from sbcl: ;;; "The value NIL is not of type SB-C::NODE." (deftest misc.75 (funcall (compile nil '(lambda () (flet ((%f12 () (unwind-protect 1))) 0)))) 0) ;;; cmucl (2003-10-12), "NIL is not of type C::REF" (deftest misc.76 (funcall (compile nil '(lambda (a c) (if nil (unwind-protect (max 521739 (unwind-protect c))) (logandc2 3942 a)))) 0 0) 3942) ;;; gcl (2003-10-11) Miscomputation of (mod 0 -53) in compiled code (deftest misc.77 (funcall (compile nil '(lambda () (mod 0 -53)))) 0) ;;; cmucl (2003-10-12) "NIL is not of type C::BYTE-LAMBDA-INFO" (deftest misc.78 (funcall (compile nil '(lambda () (declare (optimize (speed 0) (debug 0))) (let ((v4 (case 227 ((-11113 -106126) (unwind-protect 8473)) (t 43916)))) -12)))) -12) ;;; Same as misc.78, but with no declarations ;;; In cmucl (2003-10-12) "NIL is not of type C::ENVIRONMENT" (deftest misc.79 (funcall (compile nil '(lambda () (let ((v4 (case 227 ((-11113 -106126) (unwind-protect 8473)) (t 43916)))) -12)))) -12) (deftest misc.79a (funcall (compile nil '(lambda (a b) (declare (type (integer 72504 351460) a)) (declare (type (integer 2383 108330) b)) (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (if (or (or (/= b 0) (logbitp 0 0)) (logbitp 0 a)) 0 (funcall (constantly 0) b 0 (catch 'ct4 b))))) 132318 12238) 0) ;;; cmucl (2003-10-12) "Invalid number of arguments: 2" (deftest misc.80 (funcall (compile nil '(lambda (b c) (declare (notinline > logior imagpart)) (declare (optimize (speed 0) (debug 0))) (labels ((%f16 () (imagpart (block b3 (logeqv (logior -122516 (if (> -1 0) (return-from b3 c) b)) (return-from %f16 32186310)))))) (lognor (%f16) b)))) -123886 -1656) 57385) ;;; cmucl (2003-10-12) "NIL is not of type C::REF" (deftest misc.81 (funcall (compile nil '(lambda (b) (block b7 (let ((v3 (return-from b7 b))) (unwind-protect b))))) 17) 17) ;;; cmucl (2003-10-12) "The assertion C::SUCC failed" (deftest misc.82 (funcall (compile nil '(lambda (c) (labels ((%f15 () (* (unwind-protect c) (max -5726369 (return-from %f15 3099206))))) c))) 0) 0) ;;; cmucl (2003-10-13) "The assertion (NOT (C::BLOCK-DELETE-P BLOCK)) failed." (deftest misc.83 (funcall (compile nil '(lambda (a c) (flet ((%f8 () (min c (min a (return-from %f8 c))))) c))) 0 -10) -10) (deftest misc.84 (funcall (compile nil '(lambda (a b) (flet ((%f18 () (let () (let () (if (ldb-test (byte 20 23) b) a (return-from %f18 431)))))) -674))) 0 0) -674) (deftest misc.85 (funcall (compile nil '(lambda (c) (labels ((%f14 () (let () (logandc1 (min -32 (return-from %f14 -69793)) c)))) 156))) 0) 156) ;;; Two tests showing bug(s) in clisp (2.31) (deftest misc.86 (funcall (compile nil '(lambda (b) (flet ((%f10 nil :bad)) (let ((v7 (let ((v2 (%f10))) b))) (unwind-protect b))))) :good) :good) (deftest misc.87 (apply (compile nil '(lambda (a b c) (let ((v9 a)) (let ((v2 (setq v9 c))) (unwind-protect c))))) '(x y z)) z) ;;; cmucl bug (18e+ 10/15/03) (deftest misc.88 (eval '(block b3 (max (return-from b3 1) (if (unwind-protect (unwind-protect 2)) 3 4)))) 1) ;;; ;;; cmucl bug (18e+ 10/15/03) ;;; Also occurs in sbcl (0.8.16.20) ;;; "Too large to be represented as a SINGLE-FLOAT" ;;; (a large bignum is coerced to a single-float in type propagation, ;;; with unfortunate results.) ;;; ;;; Here, the function were the problem occurs is - (deftest misc.89 (funcall (compile nil '(lambda (c) (declare (type (integer 0 130304) c)) (- (rem -26 (max 25 (load-time-value 505849129))) (* -15718867961526428520296254978781964 c)))) 0) -26) ;;; Here, it is MAX (deftest misc.89a (funcall (compile nil '(lambda (a b c d) (declare (type (integer -265115792172 -206231862770) a)) (declare (type (integer 11069 58322510034) b)) (declare (type (integer -7351 28730) c)) (declare (type (integer -913299295156 3670905260104) d)) (declare (ignorable a b c d)) (declare (optimize (safety 1) (space 1) (compilation-speed 2) (debug 0) (speed 2))) (- (signum (catch 'ct6 0)) (numerator (* -1303 d -20527703 d c))))) -261283766805 41605749408 5110 1269102278886) -220139978315039892599545286437019126040) ;;; Here, it is MOD (deftest misc.89b (funcall (compile nil '(lambda (a b c d) (declare (type (integer -481454219025 239286093202) a)) (declare (type (integer -1121405368785 213522) b)) (declare (type (integer -103720347879 -241) c)) (declare (type (integer -12830115357 3027711346) d)) (declare (ignorable a b c d)) (declare (optimize (speed 2) (compilation-speed 1) (space 1) (safety 3) (debug 2))) (floor (load-time-value 0) (min -18 (* a c b -12626))))) -78545446876 -460518205737 -38885914099 1598305189) 0 0) ;;; acl bugs (version 6.2, linux x86 trial) (deftest misc.90 (let* ((form '(- 0 (ignore-errors 20763) (logxor b 1 c -7672794) b)) (fn1 `(lambda (b c) (declare (type (integer -148895 -46982) b)) (declare (type (integer 0 1) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form))) (let ((v1 (funcall (compile nil fn1) -76071 0)) (v2 (funcall (compile nil fn2) -76071 0)) (v3 (funcall (eval `(function ,fn2)) -76071 0))) (if (= v1 v2 v3) :good (list v1 v2 v3)))) :good) (deftest misc.91 (let ((fn1 '(lambda () (declare (optimize (speed 3) (safety 1))) (ash -10 (min 8 -481)))) (fn2 '(lambda () (ash -10 (min 8 -481))))) (let ((v1 (funcall (compile nil fn1))) (v2 (funcall (compile nil fn2))) (v3 (funcall (eval `(function ,fn2))))) (if (= v1 v2 v3) :good (list v1 v2 v3)))) :good) (deftest misc.92 (let* ((form '(- -16179207 b (lognor (let () 3) (logxor -17567197 c)))) (fn1 `(lambda (b c) (declare (type (integer -621 30) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form)) (vals '(26291532469 -21))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals)) (v3 (apply (eval `(function ,fn2)) vals))) (if (= v1 v2 v3) :good (list v1 v2 v3)))) :good) (deftest misc.93 (let* ((form '(ash (1+ (flet ((%f5 (f5-1) c)) c)) (min 69 (logxor a b)))) (fn1 `(lambda (a b c) (declare (type (integer -128 -109) a) (type (integer -2 -1) b) (optimize (speed 3) (safety 1))) ,form)) (fn2 `(lambda (a b c) ,form)) (vals '(-123 -1 2590941967601))) (eqlt (apply (compile nil fn1) vals) (apply (compile nil fn2) vals))) t) (deftest misc.94 (not (funcall (compile nil '(lambda () (declare (optimize (speed 3) (safety 1) (debug 1))) (<= 268435280 (load-time-value 39763134374436777607194165739302560271120000)))))) nil) (deftest misc.95 (let* ((form '(+ 272 c (if (< b a) -49618 -29042) b)) (fn1 `(lambda (a b c) (declare (type (integer -1585918 601848636) a)) (declare (type (integer -4 16544323) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (a b c) ,form)) (vals '(601739317 10891850 17452477960))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2)))) :good) (deftest misc.96 (let* ((form '(max 26 (ceiling b (min -8 (max -1 c))))) (fn1 `(lambda (b c) (declare (type (integer 482134 96074347505) b)) (declare (type (integer -4036 -50) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form)) (vals '(90244278480 -338))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2)))) :good) (deftest misc.97 (let* ((form '(- 349708 (gcd c 0) (logand b b (if (> -8543459 c) 83328 1073)))) (fn1 `(lambda (b c) (declare (type (integer 301653 329907) b)) (declare (type (integer 171971491 1073721279) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) ,form)) (fn2 `(lambda (b c) ,form)) (vals '(321769 1073671227))) (let ((v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2)))) :good) ;;; sbcl bugs (0.8.4.40, x86 linux) (deftest misc.98 (funcall (compile nil '(lambda (x) (declare (type (integer -1000000 1000000) x)) (logand x x 0))) 12345) 0) (deftest misc.99 (funcall (compile nil '(lambda (a) (declare (type (integer 4303063 101130078) a)) (mask-field (byte 18 2) (ash a 77)))) 57132532) 0) (deftest misc.100 (funcall (compile nil '(lambda (c) (declare (type (integer -3924 1001809828) c)) (declare (optimize (speed 3))) (min 47 (if (ldb-test (byte 2 14) c) -570344431 (ignore-errors -732893970))))) 705347625) -570344431) (deftest misc.101 (funcall (compile nil '(lambda (a c) (declare (type (integer 185501219873 303014665162) a)) (declare (type (integer -160758 255724) c)) (declare (optimize (speed 3))) (let ((v8 (- -554046873252388011622614991634432 (ignore-errors c) (unwind-protect 2791485)))) (max (ignore-errors a) (let ((v6 (- v8 (restart-case 980)))) (min v8 v6)))))) 259448422916 173715) 259448422916) (deftest misc.102 (funcall (compile nil '(lambda (b) (declare (type (integer -1598566306 2941) b)) (declare (optimize (speed 3))) (max -148949 (ignore-errors b)))) 0) 0) (deftest misc.103 (funcall (compile nil '(lambda (a b) (min -80 (abs (ignore-errors (+ (logeqv b (block b6 (return-from b6 (load-time-value -6876935)))) (if (logbitp 1 a) b (setq a -1522022182249)))))))) -1802767029877 -12374959963) -80) (deftest misc.104 (funcall (compile nil '(lambda (a) (declare (type (integer 55400028 60748067) a)) (lognand 1505 (ash a (let () 40))))) 58194485) -1) (deftest misc.105 (funcall (compile nil '(lambda (b c) (declare (type (integer -4 -3) c)) (block b7 (flet ((%f1 (f1-1 f1-2 f1-3) (if (logbitp 0 (return-from b7 (- -815145138 f1-2))) (return-from b7 -2611670) 99345))) (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2))) b))))) 2950453607 -4) -815145134) ;;; Gives the error The value NIL is not of type INTEGER. (in sbcl 0.8.4.40) (deftest misc.106 (progn (eval '(defun misc.106-fn (a b c) (declare (optimize speed)) (block b6 (flet ((%f8 (f8-1 f8-2) b)) (%f8 (%f8 c 338) (if t (return-from b6 a) c)))))) (misc.106-fn -30271 -1 -3043)) -30271) ;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.4.40) (deftest misc.107 (funcall (compile nil '(lambda (b c) (declare (type (integer -29742055786 23602182204) b)) (declare (type (integer -7409 -2075) c)) (declare (optimize (speed 3))) (floor (labels ((%f2 () (block b6 (ignore-errors (return-from b6 (if (= c 8) b 82674)))))) (%f2))))) 22992834060 -5833) 82674 0) ;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.10.15) (deftest misc.107a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 1) (debug 3) (compilation-speed 0))) (flet ((%f14 (f14-1 &optional (f14-2 (rationalize (catch 'ct4 0))) (f14-3 0) (f14-4 0)) (dotimes (iv2 0 0) (progn f14-2)))) (apply #'%f14 0 0 0 nil))))) 0) ;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.14.18) (deftest misc.107b (funcall (compile nil '(lambda (a b c) (declare (type (integer 7215 1030625885) a)) (declare (type (integer -4361 -6) b)) (declare (type (integer -3798210806 -898) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 3) (compilation-speed 1))) (block b4 (let ((*s7* (cons c 0))) (declare (special *s7*)) (return-from b4 (prog1 0 (the integer (integer-length (1+ (let () (gcd (cdr *s7*) (case b ((31 38 20 0 5 45) 2) ((34 35 64 61 47) 39) ((58) a) (t 131788))))))))))))) 734649164 -3343 -2306504518) 0) (deftest misc.107c (funcall (compile nil '(lambda (c) (declare (optimize (speed 2) (space 1) (safety 1) (debug 3) (compilation-speed 0))) (let* ((*s6* (unwind-protect 0 (the integer (ash 2914825 (min 8 c)))))) (declare (special *s6*)) 0))) -105) 0) (deftest misc.107d (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 1) (safety 1) (debug 3) (compilation-speed 1))) (catch 'ct4 (logorc1 (the integer (case (dotimes (iv2 2 2) (progn 203)) ((-51) -59598) ((-31 -150) a) (t b))) (throw 'ct4 0))))) 10 20) 0) (deftest misc.107e (funcall (compile nil '(lambda (a) (declare (optimize (speed 1) (space 0) (safety 1) (debug 3) (compilation-speed 1))) (flet ((%f11 (&key (key1 (the integer (- a 245241933)))) 0)) (%f11)))) 1) 0) ;;; cmucl bug (Argument X is not a NUMBER: NIL) (deftest misc.108 (funcall (compile nil '(lambda (b) (block b7 (- b (ignore-errors (return-from b7 57876)))))) 10) 57876) ;;; "The assertion (C::CONSTANT-CONTINUATION-P C::CONT) failed." (cmucl) (deftest misc.109 (funcall (compile nil '(lambda () (load-time-value (block b4 (* (return-from b4 -27) (block b5 (return-from b4 (return-from b5 (ignore-errors (unwind-protect (return-from b5 0)))))))))))) -27) ;;; This bug was occuring a lot in sbcl, and now occurs in cmucl too ;;; NIL fell through ETYPECASE expression. Wanted one of (C:FIXUP X86::EA C:TN). (deftest misc.110 (funcall (compile nil '(lambda (c) (declare (type (integer -1441970837 -427) c)) (declare (optimize (speed 3))) (block b7 (abs (min c (ignore-errors (return-from b7 c))))))) -500) -500) ;;; In sbcl 0.8.10.14 ;;; NIL fell through ETYPECASE expression. ;;; Wanted one of (SB-C:FIXUP SB-VM::EA SB-C:TN). (deftest misc.110a (funcall (compile nil '(lambda (a b c d e f) (declare (type (integer -1294746569 1640996137) a)) (declare (type (integer 33628514900 90005963619) b)) (declare (type (integer -807801310 3) c)) (declare (type (integer 36607 121946) d)) (declare (type (integer -6669690514043 -1776180885905) e)) (declare (type (integer -1472 1979) f)) (declare (ignorable a b c d e f)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3))) (catch 'ct7 (if (logbitp 0 (if (/= 0 a) c (ignore-errors (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0)))) 0 0)))) 391833530 36648101240 -32785211 91893 -4124561581760 1358) 0) ;;; CLISP (2.31+) compiler bug (deftest misc.111 (funcall (compile nil '(lambda (a c) (if (or (ldb-test (byte 12 18) a) (not (and t (not (if (not (and c t)) nil nil))))) 170 -110730))) 3035465333 1919088834) 170) ;;; sbcl (0.8.5.8) "The value NIL is not of type SB-C::IR2-LVAR." (deftest misc.112 (funcall (compile nil '(lambda (a) (declare (type (integer -944 -472) a)) (declare (optimize (speed 3))) (round (block b3 (return-from b3 (if (= 55957 a) -117 (ignore-errors (return-from b3 a)))))))) -589) -589 0) ;;; sbcl (0.8.5.8) "The value NIL is not of type SB-C::CTRAN" (deftest misc.113 (funcall (compile nil '(lambda (b c) (if (or (ldb-test (byte 8 10) b) t) c (min (if (<= -6467 c) c 6) (flet ((%f3 (f3-1 f3-2) f3-1)) (multiple-value-call #'%f3 (values b 107))))))) -238 -23658556) -23658556) ;;; clisp (1 Oct 2003 cvs HEAD) "*** - CAR: #:G7744659 is not a LIST" (deftest misc.114 (funcall (compile nil '(lambda (a b) (unwind-protect (block b2 (flet ((%f1 nil b)) (logior (if a (if (ldb-test (byte 23 1) 253966182) (return-from b2 a) -103275090) 62410) (if (not (not (if (not nil) t (ldb-test (byte 2 27) 253671809)))) (return-from b2 -22) (%f1)))))))) 777595384624 -1510893868) 777595384624) ;;; clisp (1 Oct 2003 cvs HEAD) "Compiler bug!! Occurred in OPTIMIZE-LABEL." (deftest misc.115 (funcall (compile nil '(lambda (a b c) (declare (type (integer 0 1000) a b c)) (if (and (if b (not (and (not (or a t)) nil)) nil) (logbitp 6 c)) c b))) 0 100 600) 600) (deftest misc.116 (funcall (compile nil '(lambda (a c) (declare (type (integer 0 1000) a c)) (if (if (and (not (and (not (or a t)) nil)) t) c nil) 91 -1725615))) 0 0) 91) (deftest misc.117 (funcall (compile nil '(lambda (a c) (declare (type (integer 0 1000) a c)) (if (or c (not (or nil (not (and (not (or a t)) nil))))) 373146181 115))) 0 0) 373146181) (deftest misc.118 (funcall (compile nil '(lambda (a) (declare (type (integer 0 10000) a)) (if (or (or nil (not (or (not (or a nil)) t))) a) a 9376))) 0) 0) (deftest misc.119 (funcall (compile nil '(lambda () (if (and (if (1+ 0) nil (not (and (not (and (<= 3) nil)) nil))) (if (= -31) -20 -2371)) 1493 39720)))) 39720) (deftest misc.120 (funcall (compile nil '(lambda (c) (declare (type (integer 377036 4184626) c)) (if (or (and t (not (and (not (and c nil)) nil))) nil) 3470653 c))) 1000000) 3470653) (deftest misc.121 (funcall (compile nil '(lambda (a b c) (if (and (and -92220 (not (and (not (or c nil)) nil))) a) b b))) 2000000 150000 -1) 150000) ;;; CAR: #:G243 is not a LIST (deftest misc.122 (funcall (compile nil '(lambda (a b c) (declare (type (integer 2872749 5754655) a)) (declare (type (integer 24114340 89504792) b)) (declare (type (integer 506491 1412971) c)) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (- (let ((v7 (ignore-errors a))) -6) (logand (if c -13936 c) (block b3 (if (if (or t b) (not nil) c) (return-from b3 -3114) (ignore-errors 7) )))))) 3000000 30000000 600000) 15978) ;;; gcl bug (30 Oct 2003) (deftest misc.123 (let* ((fn1 '(lambda (b) (declare (optimize (safety 1))) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (multiple-value-call #'%f7 (values b 2)))))) (fn2 '(lambda (b) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (multiple-value-call #'%f7 (values b 2)))))) (vals '(1439719153)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) (deftest misc.124 (let* ((fn1 '(lambda (b) (declare (optimize (safety 1))) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (funcall #'%f7 b 2))))) (fn2 '(lambda (b) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (funcall #'%f7 b 2))))) (vals '(1439719153)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; This passed in gcl, but I added it for completeness. (deftest misc.125 (let* ((fn1 '(lambda (b) (declare (optimize (safety 1))) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (%f7 b 2))))) (fn2 '(lambda (b) (labels ((%f7 (f7-1 f7-2) (let ((v2 (setq b 723149855))) 25620))) (max b (%f7 b 2))))) (vals '(1439719153)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; clisp optional argument bug: "SYMBOL-VALUE: 1 is not a SYMBOL" (deftest misc.126 (funcall (compile nil '(lambda () (declare (special *should-always-be-true*)) (labels ((%f10 (f10-1 &optional (f10-2 (cl:handler-bind nil (if *should-always-be-true* (progn 878) (should-never-be-called) ))) (f10-3 (cl:handler-case 10))) -15)) (%f10 -144))))) -15) (deftest misc.127 (funcall (compile nil '(lambda (a c) (flet ((%f10 (f10-1 f10-2) 10)) (flet ((%f4 (&optional (f4-1 (ldb (byte 10 6) (* 828 (+ 30 (dpb c (byte 9 30) (%f10 1918433 34107))) ))) (f4-2 (setq a 0))) 2)) (%f4 -5))))) 0 0) 2) ;;; cmucl (22 Oct 2003 build) bug ;;; The assertion (EQ (C::COMPONENT-KIND C:COMPONENT) :INITIAL) failed. (deftest misc.128 (flet ((%f14 (f14-1 f14-2 &optional (f14-3 (unwind-protect 13059412)) (f14-4 452384) (f14-5 -6714)) -1)) (%f14 -2 1 1279896 589726354 -11)) -1) (deftest misc.129 (labels ((%f17 (f17-1 f17-2 &optional (f17-3 (unwind-protect 178))) 483633925)) -661328075) -661328075) (deftest misc.130 (let* ((fn1 '(lambda (a c) (flet ((%f10 (&optional (f10-1 -6489) (f10-2 (+ c))) a)) (multiple-value-call #'%f10 (values -178858 a))))) (fn2 '(lambda (a c) (declare (notinline values +) (optimize (speed 0) (debug 0))) (flet ((%f10 (&optional (f10-1 -6489) (f10-2 (+ c))) a)) (multiple-value-call #'%f10 (values -178858 a))))) (vals '(-13649921 -1813684177409)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) (deftest misc.131 (let* ((fn1 '(lambda (a b) (max (block b7 (abs (ignore-errors (if (ldb-test (byte 33 15) (return-from b7 a)) b b))))))) (fn2 '(lambda (a b) (declare (notinline abs max)) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (max (block b7 (abs (ignore-errors (if (ldb-test (byte 33 15) (return-from b7 a)) b b))))))) (vals '(-823894140303 -3)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; cmucl (22 Oct 2003) ;;; The assertion (EQ C::ENV ;;; (C::LAMBDA-ENVIRONMENT ;;; (C::LAMBDA-VAR-HOME C::THING))) failed. (deftest misc.132 (funcall (compile nil '(lambda (b c) (declare (type (integer -3358662 7782429) b)) (declare (type (integer -513018 12740) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (labels ((%f9 (&optional (f9-1 (labels ((%f5 (f5-1 f5-2) (floor (ignore-errors f5-1) (min -67 (if (equal -56 c) -11197265 f5-2))))) c)) (f9-2 -439518) (f9-3 -2840573)) f9-1)) (%f9 -193644 b 1368)))) 10 20) -193644) (deftest misc.132a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 0))) (labels ((%f1 () 0)) (if t 0 (dotimes (iv1 5 (if (%f1) 0 0)) (catch 'ct1 0))))))) 0) ;;; cmucl (22 Oct 2003) Default for optional parameter is improperly chosen (deftest misc.133 (funcall (compile nil '(lambda (a b c) (declare (notinline values)) (declare (optimize (speed 0) (debug 0))) (flet ((%f15 (&optional (f15-5 c)) f15-5)) (multiple-value-call #'%f15 (values -2688612))))) 1 2 3) -2688612) ;;; ACL 6.2 (x86 linux trial) bugs ;;; With optional flet/labels parameters, there's a very high frequency bug ;;; causing the compiler error "Error: `:INFERRED' is not of the expected ;;; type `NUMBER'". The following tests show this bug. (deftest misc.134 (funcall (compile nil '(lambda (b) (labels ((%f5 (f5-1 f5-2 f5-3 &optional (f5-4 0) (f5-5 (flet ((%f13 (f13-1) (return-from %f13 b))) b))) 900654472)) 183301))) 13775799184) 183301) (deftest misc.135 (funcall (compile nil '(lambda (a b) (labels ((%f4 (&optional (f4-1 (labels ((%f17 nil a)) b))) -14806404)) 190134))) 1783745644 268410629) 190134) (deftest misc.136 (funcall (compile nil '(lambda (c) (flet ((%f17 (&optional (f17-1 (flet ((%f9 nil c)) 73574919))) 643)) 1039017546))) 0) 1039017546) ;;; And these caused segfaults (deftest misc.137 (funcall (compile nil '(lambda () (declare (optimize (speed 3))) (declare (optimize (safety 1))) (flet ((%f16 (&optional (f16-2 (lognor -3897747 (if nil -1 -127228378)))) 10)) 20)))) 20) (deftest misc.138 (funcall (compile nil '(lambda (c) (declare (type (integer 2996 39280) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (if (zerop (labels ((%f8 (&optional (f8-2 (logorc2 c -161957))) 2176)) 3)) c c))) 3000) 3000) ;;; Lispworks 4.2 (x86 linux personal edition) failures (deftest misc.139 (let* ((fn1 '(lambda (c) (declare (optimize (speed 3))) (logior (labels ((%f1 (f1-1 &optional (f1-2 (setq c 7))) f1-1)) (%f1 774 3616592)) c))) (fn2 '(lambda (c) (logior (labels ((%f1 (f1-1 &optional (f1-2 (setq c 7))) f1-1)) (%f1 774 3616592)) c))) (vals '(-3)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) (deftest misc.140 (funcall (compile nil '(lambda (a) (ldb (byte 24 20) (labels ((%f12 (&optional (f12-1 149) (f12-2 -3894159)) 34068)) (let* ((v4 (%f12))) a))))) -1) 16777215) ;;; In Lispworks 4.2 (x86 linux personal edition) ;;; 'Error: *** Ran out of patterns in (MOVE) for (edi NIL)' (deftest misc.141 (funcall (compile nil '(lambda () (labels ((%f11 (&optional (f11-3 (restart-case 0))) f11-3)) (%f11 1))))) 1) (deftest misc.142 (funcall (compile nil '(lambda () (labels ((%f15 (&optional (f15-3 (block b1 (+ 1 (return-from b1 -10))))) f15-3)) (%f15))))) -10) ;;; cmucl (22 Oct 2003): NIL is not of type C::REF (deftest misc.143 (block b2 (max (return-from b2 1) (let ((v3 (unwind-protect (let* ((v1 (ignore-errors -254))) 1)))) -2))) 1) ;;; (was) The assertion (NOT (C::BLOCK-DELETE-P BLOCK)) failed. ;;; (now) The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL :TOP-LEVEL))) failed. (deftest misc.144 (funcall (compile nil '(lambda (a b c) (declare (type (integer 9739325 14941321) c)) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 b)) (return-from %f7 f7-4))) (if (= -76482 c) (if (>= c 10986082) (%f7 a b (%f7 -8088 c -147106 2)) -10502) (%f7 509252 b b))))) -200 17 10000000) 17) (deftest misc.145 (funcall (compile nil '(lambda (a b c) (declare (optimize (safety 3))) (block b5 (return-from b5 (logior (if (or c t) b (load-time-value -61)) (return-from b5 -3)))))) 1 2 3) -3) ;;; cmucl: order of evaluation error (deftest misc.146 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3))) (flet ((%f14 (&optional (f14-1 301917227) (f14-2 (setq b 995196571))) f14-1)) (%f14 b (block b3 (%f14 -64)))))) 10) 10) ;;; cmucl (22 Oct 2003): NIL is not of type C::CLEANUP (deftest misc.147 (flet ((%f11 () (if nil (ignore-errors -19884254) (unwind-protect -2)))) :good) :good) ;;; The assertion (C::CONSTANT-CONTINUATION-P C::CONT) failed. (deftest misc.148 (block b2 (logior (return-from b2 484) (restart-case (ignore-errors 1737021)))) 484) ;;; Argument X is not a NUMBER: NIL. (deftest misc.149 (funcall (compile nil '(lambda (b) (block b1 (- (logand 0 -34 1026491) (ignore-errors (return-from b1 b)))))) 0) 0) (deftest misc.149a (funcall (compile nil '(lambda (a) (block b1 (- a (ignore-errors (return-from b1 1)))))) 0) 1) ;;; cmucl (11 2003 image) "NIL is not of type C::CONTINUATION" (deftest misc.150 (funcall (compile nil '(lambda (a b c) (flet ((%f17 (&optional (f17-4 (labels ((%f13 (f13-1 &optional (f13-2 (multiple-value-prog1 b))) -4)) (%f13 b (%f13 190))))) -157596)) (labels ((%f6 () (%f17))) c)))) 10 20 30000) 30000) (deftest misc.150a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 2))) (catch 'ct6 (apply (constantly 0) (list)))))) 0) (deftest misc.150b (funcall (compile nil '(lambda (a) (declare (type integer a)) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 3))) (if (= a 0) 0 (truncate a)))) 0) 0) (deftest misc.150c (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 3) (safety 2) (debug 3) (compilation-speed 3))) (labels ((%f4 (f4-1) 0)) (labels ((%f15 (f15-1 f15-2 &optional (f15-3 (apply #'%f4 0 nil)) (f15-4 0) (f15-5 (%f4 (%f4 (if (/= 0 0) a 0))))) 0)) (labels ((%f13 (f13-1) (%f15 b 0 0 0))) 0))))) 1 2) 0) (deftest misc.150d (funcall (compile nil '(lambda (a b) (declare (type (integer 4146834609223 16403344221223) a)) (declare (type (integer -35470308180 3523580009) b)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 0))) (catch 'ct1 (logand b a 0)))) 4146834609223 10) 0) ;;; cmucl (11 2003 x86 linux) "NIL is not of type C::ENVIRONMENT" (deftest misc.151 (funcall (compile nil '(lambda (b c) (declare (type (integer -249 97) b)) (declare (type (integer 3565969 6559088) c)) (let* ((v7 (if (not (= 1030 4)) c (logand (if (/= b c) b 34945725) (unwind-protect -12443701))))) 5520737))) -24 5657943) 5520737) (deftest misc.151a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 0))) (case 0 ((-12 -9 -12 -2 -5 -2 15) (catch 'ct7 (throw 'ct7 0))) (t 0))))) 0) ;;; sbcl bug (0.8.5.19) ;;; "The value NIL is not of type SB-C::REF." (deftest misc.152 (funcall (compile nil '(lambda (a) (block b5 (let ((v1 (let ((v8 (unwind-protect 9365))) 8862008))) (* (return-from b5 (labels ((%f11 (f11-1) f11-1)) (%f11 87246015))) (return-from b5 (setq v1 (labels ((%f6 (f6-1 f6-2 f6-3) v1)) (dpb (unwind-protect a) (byte 18 13) (labels ((%f4 () 27322826)) (%f6 -2 -108626545 (%f4)))))))))))) -6) 87246015) (deftest misc.153 (funcall (compile nil '(lambda (a) (if (logbitp 3 (case -2 ((-96879 -1035 -57680 -106404 -94516 -125088) (unwind-protect 90309179)) ((-20811 -86901 -9368 -98520 -71594) (let ((v9 (unwind-protect 136707))) (block b3 (setq v9 (let ((v4 (return-from b3 v9))) (- (ignore-errors (return-from b3 v4)))))))) (t -50))) -20343 a))) 0) -20343) ;;; Bug in ecl (cvs head, 4 Nov 2003) ;;; "/tmp/ecl04Coiwc0V.c:48: `lex0' undeclared (first use in this function)" (deftest misc.154 (funcall (compile nil '(lambda (b) (labels ((%f8 nil -39011)) (flet ((%f4 (f4-1 f4-2 &optional (f4-3 (%f8)) (f4-4 b)) (%f8))) (%f4 -260093 -75538 -501684 (let ((v9 (%f8))) -3)))))) 0) -39011) ;;; "/tmp/ecl1572CbKzu.c:16: too many arguments to function `APPLY'" (deftest misc.155 (funcall (compile nil '(lambda (a b c) (labels ((%f6 (f6-1 f6-2) c)) (multiple-value-call #'%f6 (values a c))))) 0 10 20) 20) ;;; "The function C::LDB1 is undefined." (deftest misc.156 (funcall (compile nil '(lambda () (let ((v6 (ldb (byte 30 1) 1473))) (let ((v8 v6)) 2395))))) 2395) ;;; "/tmp/ecl9CEiD1RL5.c:36: `lex0' undeclared (first use in this function)" (deftest misc.157 (funcall (compile nil ' (lambda (c) (labels ((%f11 nil 1)) (flet ((%f9 (f9-1 f9-2) (case 17466182 ((-12) (%f11)) (t c)))) (%f9 -9913 c))))) 17) 17) ;;; SBCL (0.8.5.24) bug: "bogus operands to XOR" (deftest misc.158 (funcall (compile nil '(lambda (a b c) (declare (type (integer 79828 2625480458) a)) (declare (type (integer -4363283 8171697) b)) (declare (type (integer -301 0) c)) (if (equal 6392154 (logxor a b)) 1706 (let ((v5 (abs c))) (logand v5 (logior (logandc2 c v5) (common-lisp:handler-case (ash a (min 36 22477))))))))) 100000 0 0) 0) ;;; sbcl (0.8.5.24) The value NIL is not of type SB-C::CTRAN. (deftest misc.159 (funcall (compile nil '(lambda () (let ((v8 70696)) (if (equal v8 -536145083) (let ((v2 (setq v8 v8))) (flet ((%f9 (f9-1 f9-2) 309257)) (multiple-value-call #'%f9 (values v2 v2)))) 100))))) 100) ;;; sbcl (0.8.5.37) The value NIL is not of type SB-C::CTRAN. (deftest misc.159a (funcall (compile nil '(lambda (a b) (declare (type (integer -105680 2104974) a)) (declare (type (integer -1881 -1134) b)) (declare (ignorable a b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b5 (let ((v2 (if (or (>= 34 a) 108361696) (return-from b5 -1) (lognand b -16023672)))) (flet ((%f10 (f10-1 &optional (f10-2 (if (eql -30 v2) v2 -5)) (f10-3 v2) (f10-4 14)) (if (equal a f10-2) f10-4 380663047))) (flet ((%f6 (f6-1 f6-2 f6-3) f6-1)) (multiple-value-call #'%f6 (values a (%f10 -37243) -47691)))))))) 100 -1200) -1) ;;; gcl (9 Nov 2003) bug ;;; Error in FUNCALL [or a callee]: Caught fatal error [memory may be damaged] (deftest misc.160 (funcall (compile nil '(lambda (c) (declare (notinline + funcall)) (+ (labels ((%f1 () -14)) (funcall #'%f1)) (flet ((%f2 () (floor c))) (funcall #'%f2))))) 0) -14) ;;; cmucl (9 Nov 2003) ;;; The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL :TOP-LEVEL))) failed. (deftest misc.161 (funcall (compile nil '(lambda (a b c) (flet ((%f17 (f17-1 f17-2 f17-3) (flet ((%f2 (f2-1 f2-2 &optional (f2-3 (return-from %f17 f17-1)) (f2-4 (return-from %f17 -57))) b)) (multiple-value-call #'%f2 (values c -588 55101157))))) (if nil (let* ((v6 (%f17 102136 3096194 a))) b) c)))) -511 -2269809964 250738) 250738) (deftest misc.161a (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 0))) (progn (abs 0) (- a) 0))) 1) 0) ;;; cmucl (9 Nov 2003) Incorrect result at SPEED 0. (deftest misc.162 (let* ((fn `(lambda (a c) (declare (notinline funcall) (optimize (speed 0) (debug 0))) (labels ((%f17 (f17-1 &optional (f17-4 c)) (return-from %f17 (if f17-4 f17-1 49572640)))) (funcall #'%f17 15128425 a))))) (funcall (compile nil fn) 1 3)) 15128425) ;;; gcl (12 Nov 2003) ;;; C compiler failure during compilation (duplicate case value) (deftest misc.163 (funcall (compile nil '(lambda (b) (declare (type (integer -15716 3947) b)) (case b ((-7 -6 -6) :good) ((-5 -6) :bad) ))) -6) :good) ;;; gcl (13 Nov 2003) ;;; Error in FUNCALL [or a callee]: Caught fatal error [memory may be damaged] (deftest misc.164 (funcall (compile nil '(lambda (a) (labels ((%f6 (f6-1 f6-2) (cl:handler-case (labels ((%f2 nil (logior a))) (if (eql (%f2) (%f2)) 2829254 -10723)) (error (c) (error c)) ))) (funcall #'%f6 10 20) ))) 0) 2829254) ;;; sbcl failures ;;; The value NIL is not of type SB-C::NODE. (deftest misc.165 (funcall (compile nil '(lambda (a b c) (block b3 (flet ((%f15 (f15-1 f15-2 f15-3 &optional (f15-4 (flet ((%f17 (f17-1 f17-2 f17-3 &optional (f17-4 185155520) (f17-5 c) (f17-6 37)) c)) (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817))) (f15-5 a) (f15-6 -40)) (return-from b3 -16))) (multiple-value-call #'%f15 (values -519354 a 121 c -1905)))))) 0 0 -5) -16) ;;; failed AVER: ;;; "(NOT ;;; (AND (NULL (BLOCK-SUCC B)) ;;; (NOT (BLOCK-DELETE-P B)) ;;; (NOT (EQ B (COMPONENT-HEAD #)))))" (deftest misc.166 (funcall (compile nil '(lambda (a b c) (labels ((%f4 (f4-1 f4-2 &optional (f4-3 b) (f4-4 c) (f4-5 -170)) (let ((v2 (flet ((%f3 (f3-1 &optional (f3-2 28476586) (f3-3 c) (f3-4 -9240)) (return-from %f4 1))) (multiple-value-call #'%f3 (values -479909 19843799 f4-5 -463858))))) b))) c))) 0 0 -223721124) -223721124) (deftest misc.167 (funcall (compile nil '(lambda (a b c) (flet ((%f5 (f5-1 f5-2) (return-from %f5 604245664))) (flet ((%f12 (f12-1 f12-2 &optional (f12-3 c) (f12-4 -579456) (f12-5 (labels ((%f9 (f9-1 &optional (f9-2 (%f5 1 (let ((v4 (%f5 30732606 a))) b))) (f9-3 -29) (f9-4 (block b4 (labels ((%f14 () (labels ((%f18 (&optional (f18-1 (locally 592928)) (f18-2 -3) (f18-3 (return-from b4 a))) f18-1)) (%f18 74214190 a)))) (%f14))))) -1)) (flet ((%f17 (f17-1 f17-2 &optional (f17-3 -136045032)) -38655)) (%f17 43873 -138030706 -1372492))))) (return-from %f12 -15216677))) (%f12 (%f5 b 2329383) a))))) 1 2 3) -15216677) (deftest misc.168 (funcall (compile nil '(lambda (a b c) (block b3 (flet ((%f11 (f11-1 f11-2 &optional (f11-3 (block b6 (labels ((%f11 (f11-1 &optional (f11-2 c) (f11-3 (return-from b6 -1806))) (return-from b3 -28432))) (apply #'%f11 (list -114)))))) (return-from %f11 f11-2))) (%f11 b c (labels ((%f10 (f10-1 f10-2 &optional (f10-3 a) (f10-4 (%f11 -3931 170))) -1704759)) c)))))) 1 2 3) 3) (deftest misc.169 (funcall (compile nil '(lambda (a b c) (if t -21705 (flet ((%f15 (f15-1 f15-2) b)) (block b4 (%f15 -11112264 (labels ((%f2 (f2-1 &optional (f2-2 (if b -5485340 -1534)) (f2-3 -6)) (return-from b4 f2-1))) (return-from b4 (if b (%f2 c -320813) (%f2 b a a)))))))))) 1 2 3) -21705) ;;; sbcl (0.8.5.26) ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.170 (funcall (compile nil '(lambda (b) (flet ((%f14 (f14-1 f14-2) (if (if (eql b -7) nil nil) (labels ((%f10 (f10-1 f10-2 f10-3) 7466)) (return-from %f14 (min (multiple-value-call #'%f10 (values 0 492 f14-1)) (max 11 f14-1) (multiple-value-call #'%f10 (values 439171 f14-2 0))))) 1))) (let ((v6 (%f14 (logcount b) -386283))) 56211)))) 17) 56211) (deftest misc.170a (funcall (compile nil '(lambda (a b) (declare (type (integer -281 30570) a)) (declare (type (integer -4247786 -199821) b)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (flet ((%f14 (f14-1 f14-2) (coerce 0 'integer))) (labels ((%f3 (f3-1 f3-2 f3-3) (if (if (typep (%f14 -864 -10620) '(integer -11672107617 -2)) t (typep (imagpart (lcm 2120258 0 (logandc2 -6222 -1057382553))) '(integer * -113))) (dotimes (iv3 5 (flet ((%f11 (f11-1 f11-2 f11-3) b)) (multiple-value-call #'%f11 (values a a f3-3)))) 0) 0))) (case (%f3 a a 0) (t 0)))))) 22087 -1787181) 0) ;;; The value NIL is not of type SB-C::NODE. (deftest misc.171 (funcall (compile nil '(lambda (b) (block b6 (flet ((%f11 (f11-1 f11-2 &optional (f11-3 -2369157) (f11-4 409468)) (return-from b6 1))) (block b2 (flet ((%f10 (f10-1 f10-2 &optional (f10-3 (return-from b6 (return-from b6 -3)))) -8)) (%f10 (multiple-value-call #'%f11 (values -5945959 1654846427 -22)) (return-from b2 b) (return-from b2 31258361)))))))) 10) 1) ;;; segmentation violation at #XA4A0B59 (deftest misc.172 (funcall (compile nil '(lambda (a b c) (declare (notinline list apply)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (labels ((%f12 (f12-1 f12-2) (labels ((%f2 (f2-1 f2-2) (flet ((%f6 () (flet ((%f18 (f18-1 &optional (f18-2 a) (f18-3 -207465075) (f18-4 a)) (return-from %f12 b))) (%f18 -3489553 -7 (%f18 (%f18 150 -64 f12-1) (%f18 (%f18 -8531) 11410) b) 56362666)))) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 (%f6))) 7767415)) f12-1)))) (%f2 b -36582571)))) (apply #'%f12 (list 774 -4413))))) 0 1 2) 774) ;;; In sbcl 0.8.5.37 ;;; "Unreachable code is found or flow graph is not properly depth-first ordered." (deftest misc.173 (funcall (compile nil '(lambda (a b c) (declare (notinline values)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (flet ((%f11 (f11-1 f11-2 &optional (f11-3 c) (f11-4 7947114) (f11-5 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529)) 8134)) (multiple-value-call #'%f3 (values (%f3 -30637724 b) c))))) (setq c 555910))) (if (and nil (%f11 a a)) (if (%f11 a 421778 4030 1) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 (%f11 -79192293 (%f11 c a c -4 214720) b b (%f11 b 985))) (f7-4 a)) b)) (%f11 c b -25644)) 54) -32326608)))) 1 2 3) -32326608) ;;; In sbcl 0.8.5.37 ;;; The value NIL is not of type SB-C:COMPONENT. (deftest misc.174 (funcall (compile nil '(lambda (a b c) (declare (type (integer 10292971433 14459537906) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (and (and (/= -51885 b) nil) (case (1+ b) ((4 4 3 -4) (let* ((v1 (flet ((%f16 (f16-1) -1858366)) (apply #'%f16 b (list))))) -1602321)) (t 3))) 19 c))) 0 11000000000 0) 0) (deftest misc.174a (funcall (compile nil '(lambda (a b) (declare (type (integer 23 365478242977) a)) (declare (type (integer -38847 268231) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (not (if (/= b 7) t (not (not a)))) (case (setq b -5880) ((8382 3401 2058 39167 62228) (flet ((%f7 (f7-1 f7-2 f7-3) f7-1)) (multiple-value-call #'%f7 (values -135629 a -410168200)))) (t a)) 15173))) 30 0) 15173) (deftest misc.174b (funcall (compile nil '(lambda (a b) (declare (type (integer -8688 2170) a)) (declare (type (integer -9938931470 1964967743) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (and (if (if (equal b 9) nil t) nil (not (logbitp 5 (labels ((%f5 (f5-1 f5-2 f5-3) 4057223)) (let ((v9 (%f5 -42 -27504 45026809))) 15011))))) (if (or a (labels ((%f16 (f16-1) 61)) (apply #'%f16 275 (list)))) a t)) (setq a -4803) (rem a (max 47 b))))) 0 0) 0) ;;; In sbcl 0.8.5.37 ;;; "Unreachable code is found or flow graph is not properly depth-first ordered." (deftest misc.175 (funcall (compile nil '(lambda (a b c) (declare (notinline list apply values signum funcall)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (labels ((%f4 (f4-1 f4-2 f4-3) (labels ((%f1 (f1-1 f1-2 f1-3) 2)) (labels ((%f11 (f11-1 &optional (f11-2 (return-from %f4 (labels ((%f8 (f8-1 f8-2 f8-3 &optional (f8-4 -35) (f8-5 f4-2)) f4-1)) (funcall #'%f8 53 b f4-1))))) (return-from %f4 a))) (signum (let ((v4 (flet ((%f8 (f8-1 f8-2 f8-3 &optional (f8-4 b) (f8-5 -560367)) f8-4)) (%f8 -27 35395 c -69)))) (%f11 (multiple-value-call #'%f11 (values (%f1 (%f11 b (%f11 v4 f4-3)) f4-3 77936) 1628490976)) (return-from %f4 (%f1 -9432 f4-1 f4-1))))))))) (flet ((%f7 (f7-1 f7-2 f7-3) (%f4 b f7-3 f7-3))) (flet ((%f14 (f14-1) (apply #'%f7 -252 -56169265 -7322946 (list)))) (%f14 a)))))) -70313091 577425217 28052774417) -70313091) (deftest misc.175a (funcall (compile nil '(lambda (a b) (declare (notinline values list apply logior)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (if nil (logior (flet ((%f5 (f5-1) b)) (%f5 56288)) (flet ((%f17 (f17-1 f17-2 &optional (f17-3 (let () 6857)) (f17-4 (labels ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 a) (f3-5 877)) 139)) (apply #'%f3 (list -33052082 b a 1572))))) b)) (multiple-value-call #'%f17 (values 31 b a b)))) 392))) 0 0) 392) (deftest misc.175b (funcall (compile nil '(lambda (a b) (declare (type (integer -1185422977 2286472818) a)) (declare (type (integer -211381289038 74868) b)) (declare (ignorable a b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (lognor (unwind-protect -1248) (flet ((%f7 (&optional (f7-1 (flet ((%f1 (f1-1 f1-2 f1-3) 121426)) (%f1 b 2337452 (%f1 61767 b a)))) (f7-2 (block b8 (logandc1 (labels ((%f10 (f10-1 f10-2 f10-3) 323734600)) (%f10 (%f10 323734600 323734600 -10165) -607741 (ignore-errors 971588))) (if (>= b -27) (return-from b8 -2) (ignore-errors 237138926)))))) f7-2)) (apply #'%f7 (list 761316125 b)))))) 1792769319 -60202244870) 5) ;;; sbcl 0.8.5.37 ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.176 (funcall (compile nil '(lambda (a b c) (declare (type (integer 162180298 184143783) a)) (declare (type (integer 702599480988 725878356286) b)) (declare (type (integer 168 80719238530) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b6 (flet ((%f10 (f10-1 f10-2) (labels ((%f6 (f6-1 f6-2) f6-1)) (let ((v2 (flet ((%f1 (f1-1 f1-2 f1-3) f1-3)) (let ((v8 (%f1 -11350578 (%f6 10414199 13) -58931837))) -239755)))) 323)))) (labels ((%f4 (f4-1 &optional (f4-2 204) (f4-3 -1) (f4-4 (flet ((%f2 (f2-1) (if t (return-from b6 c) a))) (logorc2 (multiple-value-call #'%f2 (values 1)) (let* ((v5 (floor (%f2 -1260)))) (case (abs (logxor 185664 a)) ((-2 5975) (if (or (< b v5) nil) (return-from b6 (let ((v10 (%f2 c))) 0)) (multiple-value-call #'%f10 (values -3 a)))) (t b))))))) 1503938)) (multiple-value-call #'%f4 (values -1 a 1853966))))))) 173549795 725346738048 993243799) 993243799) ;;; different results (sbcl 0.8.5.37) ;;; May be that setq side effects bug again? (deftest misc.177 (let* ((form '(flet ((%f11 (f11-1 f11-2) (labels ((%f4 () (round 200048 (max 99 c)))) (logand f11-1 (labels ((%f3 (f3-1) -162967612)) (%f3 (let* ((v8 (%f4))) (setq f11-1 (%f4))))))))) (%f11 -120429363 (%f11 62362 b)))) (vars '(a b c)) (vals '(6714367 9645616 -637681868)) (fn1 `(lambda ,vars (declare (type (integer 804561 7640697) a)) (declare (type (integer -1 10441401) b)) (declare (type (integer -864634669 55189745) c)) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) ,form)) (fn2 `(lambda ,vars (declare (notinline list apply logand max round)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (compiled-fn1 (compile nil fn1)) (compiled-fn2 (compile nil fn2)) (results1 (multiple-value-list (apply compiled-fn1 vals))) (results2 (multiple-value-list (apply compiled-fn2 vals)))) (if (equal results1 results2) :good (values results1 results2))) :good) ;;; sbcl 0.8.5.37 ;;; The value NIL is not of type INTEGER. (deftest misc.178 (funcall (compile nil '(lambda (a b c) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (let ((v9 (flet ((%f9 (f9-1 f9-2 f9-3 &optional (f9-4 -40538) (f9-5 (flet ((%f10 (f10-1 f10-2) (labels ((%f11 (f11-1 f11-2) (labels ((%f10 (f10-1 f10-2) -1422)) (if (< b (%f10 (%f10 28262437 95387) f10-2)) -1562 f10-2)))) (let* ((v6 (%f11 59 b))) (return-from %f10 (apply #'%f11 f10-1 (list (return-from %f10 2029647)))))))) (apply #'%f10 -3067 3854883 (list))))) 64066)) (%f9 a 2774 0 c)))) (flet ((%f18 (f18-1 f18-2 &optional (f18-3 66) (f18-4 b)) -6939342)) (%f18 1274880 (%f18 b a 46746370 -1)))))) 0 0 0) -6939342) ;;; sbcl 0.8.5.37 ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.179 (funcall (compile nil '(lambda (a b) (declare (type (integer 1135 16722) a)) (declare (type (integer -640723637053 -9049) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b3 (return-from b3 (flet ((%f17 (f17-1 &optional (f17-2 b) (f17-3 b)) (+ (if t (return-from b3 -64796) a)))) (case (%f17 -3908648 -7026139 a) ((41771 -113272 -48004 -39699 50691 -13222) (multiple-value-call #'%f17 (values -1963404294 -105))) (t -7026139))))))) 2000 -10000) -64796) (deftest misc.180 (funcall (compile nil '(lambda (a b) (declare (type (integer 41 484) a)) (declare (type (integer -2546947 1008697961708) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if (and (ldb-test (byte 30 10) b) nil) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 -508405733)) 390004056)) (let* ((v4 (multiple-value-call #'%f7 (values b (%f7 b b))))) (multiple-value-call #'%f7 (values (%f7 80199 a) (%f7 (%f7 a (let* ((v6 (%f7 -226 250))) a)) (abs (ceiling v4))))))) -6001))) 50 0) -6001) ;;; sbcl 0.8.5.37 ;;; The value NIL is not of type SB-C::TAIL-SET. (deftest misc.181 (funcall (compile nil '(lambda (a b) (declare (type (integer -74233251043 -16478648860) a)) (declare (type (integer 0 960962) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f14 () (if 1 (return-from %f14 a) (labels ((%f10 (f10-1 f10-2 f10-3 &optional (f10-4 (let* ((v7 a)) 915))) -1268205049)) (labels ((%f18 (f18-1) (multiple-value-call #'%f10 (values f18-1 (%f10 (%f10 -1495 (%f10 -384 -84 (%f10 -1 48052 58909027 -35812) -114) (%f10 -391646964 -28131299 f18-1 (%f10 b 368193 a))) (%f10 f18-1 -1415811 f18-1 267932407) 174) -58 320)))) (let* ((v3 (let ((v7 (return-from %f14 (%f18 -418731)))) (%f10 104871 -1196 -21 a)))) (labels ((%f1 () (%f18 (%f18 -794761)))) (return-from %f14 b)))))))) (if (%f14) b 887481)))) -51967629256 809047) 809047) (deftest misc.181a (funcall (compile nil '(lambda (a b) (declare (type (integer -982285129 -90) a)) (declare (type (integer 1 82987) b)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (labels ((%f1 (f1-1 &optional (f1-2 -34) (f1-3 3318057) (f1-4 117)) (let ((v9 (let ((v9 (if t (return-from %f1 f1-2) 606042))) f1-1))) (flet ((%f16 (f16-1 f16-2) 292)) (labels ((%f2 (f2-1 f2-2 f2-3 &optional (f2-4 f1-3) (f2-5 f1-4) (f2-6 -418207187)) (%f16 2099 (%f16 f1-2 1157)))) (return-from %f1 (%f2 f1-4 -12066040 v9 122107))))))) (flet ((%f5 (f5-1 &optional (f5-2 (labels ((%f13 (f13-1 f13-2 f13-3 &optional (f13-4 a) (f13-5 b)) 1054213657)) (%f13 b 166441 -3))) (f5-3 20102220) (f5-4 (labels ((%f11 (f11-1 f11-2 f11-3) (%f1 -110148 (%f1 -12336576 f11-1 -61)))) (let ((v1 (apply #'%f11 -29706 a b (list)))) a)))) b)) (labels ((%f17 (f17-1 f17-2 f17-3 &optional (f17-4 -107566292) (f17-5 63) (f17-6 -2)) 105656)) (%f5 (%f17 185703492 a a -511 (%f1 b b -218142 (%f17 -240978 2923208 22 (%f5 1542 68917407 a) b))) -2018 -1)))))) -100 1) 1) ;;; sbcl 0.8.5.40 ;;; Different results from exprs containing ROUND (deftest misc.182 (let* ((form '(labels ((%f14 (f14-1 f14-2) (labels ((%f16 (f16-1 f16-2 &optional (f16-3 (setq f14-1 (ash f14-1 (min 77 b))))) (logandc2 c -100))) (return-from %f14 (* 2 (gcd f14-1 (%f16 c f14-1))))))) (round (%f14 c c) (max 83 (%f14 (multiple-value-call #'%f14 (values 0 2)) 0))))) (fn1 `(lambda (a b c) (declare (type (integer 5628 8762) a)) (declare (type (integer 778 33310188747) b)) (declare (type (integer -6699 4554) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) ,form)) (fn2 `(lambda (a b c) (declare (notinline values max round gcd * logandc2 min ash)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (vals '(7395 1602862793 -2384)) (cfn1 (compile nil fn1)) (cfn2 (compile nil fn2)) (result1 (multiple-value-list (apply cfn1 vals))) (result2 (multiple-value-list (apply cfn2 vals)))) (if (equal result1 result2) :good (values result1 result2))) :good) ;;; sbcl 0.8.5.42 ;;; failed AVER: "(NOT POPPING)" ;;; Also occurs in cmucl (11/2003 snapshot) (deftest misc.183 (funcall (compile nil '(lambda (a b c) (declare (type (integer -368154 377964) a)) (declare (type (integer 5044 14959) b)) (declare (type (integer -184859815 -8066427) c)) (declare (ignorable a b c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (block b7 (flet ((%f3 (f3-1 f3-2 f3-3) 0)) (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil))))) 0 6000 -9000000) 0) (deftest misc.183a (let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))) (1 2)) ;;; sbcl 0.8.5.42 ;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" (deftest misc.184 (funcall (compile nil '(lambda (a b c) (declare (type (integer 867934833 3293695878) a)) (declare (type (integer -82111 1776797) b)) (declare (type (integer -1432413516 54121964) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (if nil (flet ((%f15 (f15-1 &optional (f15-2 c)) (labels ((%f1 (f1-1 f1-2) 0)) (%f1 a 0)))) (flet ((%f4 () (multiple-value-call #'%f15 (values (%f15 c 0) (%f15 0))))) (if nil (%f4) (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0)) f8-3)) 0)))) 0))) 3040851270 1664281 -1340106197) 0) ;;; sbcl 0.8.5.42 ;;; invalid number of arguments: 1 ;;; ("XEP for LABELS CL-TEST::%F10" ... (deftest misc.185 (funcall (compile nil '(lambda (a b c) (declare (type (integer 5 155656586618) a)) (declare (type (integer -15492 196529) b)) (declare (type (integer 7 10) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 a) (f3-5 0) (f3-6 (labels ((%f10 (f10-1 f10-2 f10-3) 0)) (apply #'%f10 0 a (- (if (equal a b) b (%f10 c a 0)) (catch 'ct2 (throw 'ct2 c))) nil)))) 0)) (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7) 0) (deftest misc.185a (funcall (compile nil '(lambda (a b c) (declare (type (integer -1304066 1995764) a)) (declare (type (integer -52262604195 5419515202) b)) (declare (type (integer -13 94521) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f13 (f13-1 f13-2 f13-3) 0)) (apply #'%f13 (%f13 b 0 0) (catch 'ct1 0) (catch 'ct2 (throw 'ct2 c)) nil)))) 0 0 0) 0) ;;; sbcl 0.8.5.42 ;;; Different results (deftest misc.186 (let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1)) (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil))) (vars '(b c)) (fn1 `(lambda ,vars (declare (type (integer -2 19) b) (type (integer -1520 218978) c) (optimize (speed 3) (safety 1) (debug 1))) ,form)) (fn2 `(lambda ,vars (declare (notinline logeqv apply) (optimize (safety 3) (speed 0) (debug 0))) ,form)) (cf1 (compile nil fn1)) (cf2 (compile nil fn2)) (result1 (multiple-value-list (funcall cf1 2 18886))) (result2 (multiple-value-list (funcall cf2 2 18886)))) (if (equal result1 result2) :good (values result1 result2))) :good) ;;; cmucl (11/2003 snapshot) ;;; The assertion (NOT (EQ (C::FUNCTIONAL-KIND C::LEAF) :ESCAPE)) failed. (deftest misc.187 (apply (eval '(function (lambda (a b c) (declare (notinline)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) (flet ((%f7 (&optional (f7-1 (catch (quote ct7) 0)) (f7-2 0)) c)) (let ((v8 (flet ((%f14 (f14-1 &optional (f14-2 (%f7 b))) 0)) 0))) (%f7 b)))))) '(2374299 70496 -6321798384)) -6321798384) ;;; ecl bug ;;; Segmentation violation (deftest misc.188 (funcall (compile nil '(lambda (a b c) (declare (notinline floor min funcall)) (declare (optimize (safety 3) (speed 0) (debug 0))) (floor (flet ((%f10 (f10-1 f10-2) b)) (%f10 (%f10 0 0) a)) (min -37 (labels ((%f6 (f6-1 f6-2 f6-3) b)) (funcall #'%f6 b b b)))))) 7187592 -3970792748407 -14760) 1 0) ;;; Wrong number of arguments passed to an anonymous function (deftest misc.189 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1) (debug 1))) (let* ((v7 (labels ((%f13 (f13-1 f13-2 f13-3) 0)) (multiple-value-call #'%f13 (values a a a))))) (flet ((%f10 nil v7)) (%f10))))) 1733 3000 1314076) 0) ;;; gcl bug ;;; Error in FUNCALL [or a callee]: # is not of type NUMBER. (deftest misc.190 (let* ((form '(flet ((%f15 () (labels ((%f4 (f4-1) 0)) (flet ((%f6 (&optional (f6-2 (logand (apply #'%f4 (list (%f4 0))) (round (* a))))) -284)) (%f6))))) (funcall #'%f15))) (fn `(lambda (a b c) (declare (notinline values equal abs isqrt < >= byte mask-field funcall + * logcount logand logior round list apply min)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (vals '(538754530150 -199250645748 105109641))) (apply (compile nil fn) vals)) -284) ;;; gcl ;;; Error in COMPILER::CMP-ANON [or a callee]: 0 is not of type FUNCTION. (deftest misc.191 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (safety 1))) (labels ((%f1 nil c)) (flet ((%f12 (f12-1) (labels ((%f9 (f9-1 f9-2 f9-3) (%f1))) (apply #'%f9 (%f9 a b 0) a 0 nil)))) (apply #'%f12 0 nil))))) 0 0 0) 0) ;;; acl 6.2 (trial, x86) ;;; Returns incorrect value (deftest misc.192 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) (flet ((%f8 (f8-1 f8-2 f8-3) f8-2)) (catch 'ct6 (%f8 0 b (catch 'ct6 (throw 'ct6 a))))))) 1 2) 2) (deftest misc.193 (let* ((form '(if (if (<= a (truncate c (min -43 b))) (logbitp 0 0) (logbitp 0 -1)) 0 -36223)) (fn1 `(lambda (a b c) (declare (type (integer -3 15350342) a)) (declare (type (integer -4357 -1555) b)) (declare (type (integer 5389300879793 6422214587951) c)) (declare (optimize (speed 3))) (declare (optimize (safety 1))) (declare (optimize (debug 1))) ,form)) (fn2 `(lambda (a b c) (declare (notinline logbitp min truncate <=)) (declare (optimize (safety 3))) (declare (optimize (speed 0))) (declare (optimize (debug 0))) ,form)) (vals '(7792101 -1615 6070931814551)) (result1 (multiple-value-list (apply (compile nil fn1) vals))) (result2 (multiple-value-list (apply (compile nil fn2) vals)))) (if (equal result1 result2) :good (values result1 result2))) :good) ;;; cmucl (4 Nov 2003 snapshot) ;;; The assertion (EQ (C::TN-ENVIRONMENT C:TN) C::TN-ENV) failed. (deftest misc.194 (funcall (compile nil '(lambda (a b c) (declare (notinline funcall)) (declare (optimize (safety 3) (speed 0) (debug 3))) (flet ((%f14 (f14-1 f14-2 &optional (f14-3 0) (f14-4 (catch 'ct8 0)) (f14-5 (unwind-protect c))) 0)) (funcall #'%f14 0 0)))) 1 2 3) 0) ;;; incorrect value (in cmucl) (deftest misc.195 (funcall (compile nil '(lambda (a b) (declare (type (integer -5906488825 254936878485) a)) (declare (type (integer -350857549 -11423) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (safety 1) (debug 1))) (block b8 (labels ((%f6 (f6-1 &optional (f6-2 0) (f6-3 0) (f6-4 0)) 0)) (multiple-value-call #'%f6 (values 0)))))) 100 -100000) 0) ;;; NIL is not of type C::ENVIRONMENT (deftest misc.196 (funcall (compile nil '(lambda (a b) (declare (type (integer 1 46794484349) a)) (declare (type (integer -627 -2) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (safety 1) (debug 1))) (if (not (logbitp 0 0)) 0 (labels ((%f9 (f9-1 f9-2 f9-3) 0)) (%f9 (catch 'ct6 a) (catch 'ct4 0) 0))))) 1 -200) 0) ;;; The assertion (EQ (C::TN-ENVIRONMENT C:TN) C::TN-ENV) failed. (deftest misc.197 (funcall (compile nil '(lambda (a b) (declare (notinline logcount)) (declare (optimize (safety 3) (speed 0) (debug 3))) (labels ((%f5 (&optional (f5-1 b) (f5-2 0) (f5-3 (catch (quote ct2) 0))) (prog1 (logcount (block b1 f5-1))))) (if (%f5 0 0 0) (%f5 a) 0)))) 1 2) 1) ;;; gcl bug (30-11-2003) ;;; Different results ;;; These tests appear to be for the same bug. (deftest misc.198 (let* ((form '(min (catch 'ct4 (throw 'ct4 (setq c 29119897960))) c)) (fn1 `(lambda (c) (declare (type (integer -70450 39128850560) c)) (declare (optimize (speed 3) (safety 1))) ,form))) (funcall (compile nil fn1) 3512352656)) 29119897960) (deftest misc.199 (let* ((fn '(lambda (b) (declare (type (integer 3352138624 13120037248) b)) (declare (optimize (speed 3) (safety 1) (space 1))) (progn (catch 'ct1 (progn (setq b 11159349376) (throw 'ct1 0))) b)))) (funcall (compile nil fn) 4108962100)) 11159349376) ;;; sbcl ;;; "The value 0 is not of type REAL." (???) (deftest misc.200 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1))) (ceiling (ceiling (flet ((%f16 () 0)) (%f16))))))) 0 0) ;;; ecl 5 Dec 2003 ;;; Wrong number of arguments passed to an anonymous function (deftest misc.201 ;; form to be evaluated (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (flet ((%f10 (f10-1) (return-from %f10 a))) (multiple-value-call #'%f10 (values b))))) 10 -100) ;; expected return value 10) ;;; Does not terminate? (deftest misc.202 (funcall (compile nil '(lambda (a b c) (declare (type (integer -363953100 5324773015552) a)) (declare (type (integer -5744998440960 59520311) b)) (declare (type (integer -1864645998 -14608) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 0) (safety 2) (debug 0) (compilation-speed 2))) (flet ((%f1 (f1-1 f1-2) (labels ((%f1 (f1-1 f1-2) 0)) (%f1 a f1-2)))) (%f1 0 c)))) 10 20 -20000) 0) ;;; # (deftest misc.203 (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 1) (safety 2) (debug 0) (compilation-speed 0))) (labels ((%f18 (f18-1 f18-2 &optional (f18-3 a) (f18-4 a)) f18-2)) (multiple-value-call #'%f18 (values a 0))))) 100) 0) ;;; `env0' undeclared (first use in this function) (deftest misc.204 (funcall (compile nil '(lambda (a b) (declare (type (integer -4801373 -50300) a)) (declare (type (integer -62 -28) b)) (declare (ignorable a b)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 2) (compilation-speed 2))) (flet ((%f12 (f12-1) 0)) (labels ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 b) (f3-5 b) (f3-6 (labels ((%f9 nil b)) (apply #'%f12 (%f9) nil)))) (%f12 0))) (%f3 b 0 a))))) -2224841 -54) 0) ;;; # is not of type INTEGER. (deftest misc.205 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 3))) (labels ((%f1 nil b)) (flet ((%f11 (f11-1 f11-2 f11-3) 0)) (apply #'%f11 a (logand (%f1)) (flet ((%f13 (f13-1 f13-2) b)) (apply #'%f13 0 0 nil)) nil))))) 100 200) 0) ;;; # is not of type INTEGER. (deftest misc.206 (funcall #'(lambda (a b) (declare (notinline mask-field byte)) (declare (optimize (speed 1) (space 1) (safety 2) (debug 1) (compilation-speed 2))) (mask-field (byte 0 0) (block b3 (labels ((%f14 nil (return-from b3 a))) (%f14))))) 1 2) 0) ;;; # is not of type INTEGER (deftest misc.207 (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 2) (safety 0) (debug 1) (compilation-speed 0))) (labels ((%f3 (f3-1) a)) (labels ((%f10 (f10-1 f10-2) a)) (apply #'%f10 0 (logior (%f3 0)) nil))))) -10000) -10000) ;;; `env0' undeclared (first use in this function) (deftest misc.208 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 0))) (flet ((%f6 (f6-1 f6-2 f6-3) f6-3)) (labels ((%f8 (f8-1) (let* ((v1 (%f6 0 0 0))) 0))) (apply #'%f6 b b (%f8 b) nil))))) 10) 0) ;;; Wrong value computed (deftest misc.209 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 3))) (max (catch 'ct4 (throw 'ct4 (setq b 0))) b))) 6353) 0) ;;; Wrong value computed (deftest misc.210 (funcall (compile nil '(lambda (c) (declare (type (integer 3 65500689) c)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 3) (compilation-speed 2))) (catch 'ct6 (let ((v10 (truncate (integer-length (throw 'ct6 0))))) c)))) 100) 0) (deftest misc.210a (funcall (compile nil '(lambda (a) (declare (type (integer -55982525 -1) a)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 2) (compilation-speed 1))) (flet ((%f11 (f11-1 f11-2 f11-3) a)) (let ((v6 0)) (flet ((%f12 (f12-1) v6)) (if (<= 0) (%f11 v6 0 0) (multiple-value-call #'%f11 (values 0 0 (%f11 0 0 (apply #'%f12 0 nil)))))))))) -100) -100) ;;; Segmentation violation (deftest misc.211 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1439706333184 1191686946816) a)) (declare (type (integer -28 282229324) b)) (declare (type (integer -108149896 38889958912) c)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 1) (compilation-speed 3))) (let ((v4 (labels ((%f8 (f8-1 &optional (f8-2 0) (f8-3 b)) 0)) (logior (%f8 0) (%f8 0 0))))) (truncate (labels ((%f4 (&optional (f4-1 (ceiling c))) a)) (%f4 v4)) (max 38 (labels ((%f8 (f8-1 &optional (f8-2 (+ c a))) 0)) (apply #'%f8 a nil))))))) -979021452526 138874383 21099308459) -25763722434 -34) ;;; Wrong value returned (deftest misc.212 (funcall #'(lambda () (declare (optimize (speed 2) (space 0) (safety 3) (debug 2) (compilation-speed 0))) (let* ((v9 (unwind-protect 0))) v9))) 0) ;;; segmentation violation (deftest misc.213 (funcall (compile nil '(lambda (a b) (declare (type (integer -2 -1) b)) (declare (optimize (speed 1) (space 0) (safety 1) (debug 1) (compilation-speed 3))) (max (labels ((%f15 (f15-1) b)) (if (< 0 (%f15 a)) 0 0)) (labels ((%f11 (f11-1 f11-2 f11-3) b)) (apply #'%f11 0 0 0 nil))))) 0 -2) 0) (deftest misc.213a (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 3) (safety 0) (debug 1) (compilation-speed 3))) (max (labels ((%f7 (f7-1) a)) (%f7 0)) (flet ((%f12 (f12-1 f12-2) (if a f12-2 0))) (apply #'%f12 0 a nil))))) 123) 123) ;;; Wrong value (deftest misc.214 (funcall (compile nil '(lambda (a) (declare (optimize (speed 3) (space 1) (safety 2) (debug 0) (compilation-speed 2))) (flet ((%f8 nil (setq a 0))) (max a (%f8))))) 100) 100) ;;; Wrong value (deftest misc.215 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 3) (debug 0) (compilation-speed 2))) (ldb (byte 26 6) -1252)))) 67108844) (deftest misc.215a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 2) (safety 2) (debug 1) (compilation-speed 2))) (ldb (byte 30 0) -407020740)))) 666721084) ;;; Floating point exception (deftest misc.216 (truncate 0 -2549795210) 0 0) (deftest misc.217 (ceiling 0 -2549795210) 0 0) (deftest misc.218 (floor 0 -2549795210) 0 0) ;;; Infinite loop (deftest misc.219 (funcall (compile nil '(lambda () (labels ((%f (a b) (labels ((%f (c d) 0)) (%f 1 2)))) (%f 3 4))))) 0) ;;; #\^E is not of type NUMBER. (deftest misc.220 (funcall (compile nil '(lambda (a b) (declare (type (integer -3218770816 9386121) a)) (declare (type (integer -1 13) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (space 1) (safety 1) (debug 0) (compilation-speed 1))) (labels ((%f18 (f18-1 f18-2 f18-3) a)) (apply #'%f18 0 a (%f18 b (- (labels ((%f11 (f11-1 f11-2 f11-3) a)) (%f11 0 0 0))) a) nil)))) -468614602 3) -468614602) ;;; Floating point exception (deftest misc.221 (truncate 0 3006819284014656913408) 0 0) (deftest misc.222 (ceiling 0 3006819284014656913408) 0 0) (deftest misc.223 (floor 0 3006819284014656913408) 0 0) ;;; clisp (10 Dec 2003 cvs head) ;;; *** - SYMBOL-VALUE: 2 is not a SYMBOL (deftest misc.224 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 2) (space 3) (safety 0) (debug 1) (compilation-speed 0))) (flet ((%f14 (f14-1 f14-2 &optional (f14-3 c) (f14-4 (if (not nil) (labels ((%f9 nil 0)) (%f9)) a))) (flet ((%f17 (f17-1 f17-2) f14-1)) (%f17 0 f14-3)))) (%f14 (%f14 0 a) 0 b a)))) 248000 5409415 227923) 0) ;;; Wrong values (deftest misc.225 (funcall (compile nil '(lambda () (values (values 'a 'b))))) a) ;;; clisp (12 Dec 2003, 2:30AM CST cvs head) ;;; SYMBOL-VALUE: 1 is not a SYMBOL (deftest misc.226 (funcall (compile nil '(lambda (a) (flet ((%f (&optional (x (setq a 1)) (y (setq a 2))) 0)) (%f 0 0)))) 0) 0) (deftest misc.227 (funcall (compile nil '(lambda (b) (flet ((%f (&optional x (y (setq b 1))) x)) (%f 0)))) 0) 0) ;;; acl (x86 linux 6.2, patched 12 Dec 2003) ;;; No from-creg to move to... (deftest misc.228 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 1) (space 2) (safety 0) (debug 2) (compilation-speed 2))) (catch 'ct2 (case 0 ((-56087 86404 -94716) (signum (labels ((%f7 (f7-1 f7-2 f7-3) f7-2)) 0))) ((12986) (let ((v3 (catch 'ct2 (throw 'ct2 0)))) (labels ((%f14 (f14-1 f14-2) 0)) (%f14 b c)))) (t 0))))) -3847091255 -13482 -7577750) 0) (deftest misc.228a (funcall (compile nil '(lambda (a b c) (declare (type (integer -249606 2) a)) (declare (type (integer 125 511) b)) (declare (type (integer -2 1) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (catch 'ct4 (rational (case b ((350 244 1059) (prog2 (numerator c) 0)) ((1705 493) (unwind-protect (throw 'ct4 c) (loop for lv2 below 2 count (logbitp 0 c)))) (t a)))))) 0 200 -1) 0) (deftest misc.228b (funcall (compile nil '(lambda (c) (declare (type (integer -1 412413109) c)) (declare (optimize (speed 1) (space 2) (safety 2) (debug 1) (compilation-speed 3))) (catch 'ct2 (logior (* (progn (if c 0 (throw 'ct2 0)) 0) (catch 'ct2 (throw 'ct2 0))) (complex c 0) )))) 62151) 62151) ;;; Error: `T' is not of the expected type `INTEGER' (deftest misc.229 (funcall (compile nil '(lambda nil (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) (compilation-speed 3))) (labels ((%f15 (f15-1) 0)) (let ((v4 0)) (catch 'ct5 (%f15 (gcd (catch 'ct5 (let* ((v5 (throw 'ct5 0))) 0)) v4)))))))) 0) ;;; ecl ;;; Wrong result (order of evaluation problem) (deftest misc.230 (funcall (compile nil '(lambda (a) (declare (type (integer -6527559920 -247050) a)) (declare (optimize (speed 1) (space 3) (safety 0) (debug 0) (compilation-speed 3))) (labels ((%f10 (&optional (f10-1 0) (f10-2 (setq a -4456327156))) 0)) (logxor a (%f10 a))))) -3444248334) -3444248334) ;;; cmucl ;;; Wrong value (deftest misc.231 (funcall (compile nil '(lambda (b) (declare (type (integer -5209401 3339878) b)) (declare (optimize (speed 1) (space 2) (safety 0) (debug 2) (compilation-speed 3))) (flet ((%f3 (f3-1 f3-2) f3-1)) (apply #'%f3 0 (logxor (catch 'ct2 b) (catch 'ct5 (throw 'ct5 0))) nil)))) -2179757) 0) ;;; Invalid number of arguments: 1 (deftest misc.232 (funcall (compile nil '(lambda (a b) (declare (type (integer 197447754 495807327) a)) (declare (type (integer -125379462 1863191461) b)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 1) (compilation-speed 2))) (flet ((%f8 (&optional (f8-1 (max (catch (quote ct4) 0) (catch (quote ct6) (throw (quote ct6) 0))))) b)) (flet ((%f16 (f16-1 f16-2 f16-3) 0)) (apply #'%f16 a 0 (%f8) nil))))) 348270365 28780966) 0) ;;; The assertion (EQ C::CHECK :SIMPLE) failed. (deftest misc.233 (funcall (compile nil '(lambda (a b) (declare (type (integer -2333758327203 -321096206070) a)) (declare (type (integer -2842843403569 258395684270) b)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 2) (compilation-speed 2))) (flet ((%f18 (f18-1) (the integer (labels ((%f9 (f9-1 f9-2) (* (- -1 -210032251) (1+ (floor (labels ((%f11 (f11-1 f11-2) -96773966)) (%f11 b -3440758))))))) (flet ((%f2 (f2-1 f2-2 f2-3 &optional (f2-4 (%f9 -429204 -63)) (f2-5 (- (%f9 b 17) a)) (f2-6 (multiple-value-call #'%f9 (values (let () 7127585) (flet ((%f1 (f1-1 f1-2 f1-3) (catch 'ct6 -569234))) (macrolet () 13)))))) 1027)) (if nil (%f2 b a f18-1 69968 4 -217193265) (catch 'ct1 129548688))))))) (max (apply #'%f18 (list 0)))))) -2067244683733 143879071206) 129548688) ;;; NIL is not of type C::TAIL-SET (deftest misc.234 (funcall (compile nil '(lambda (b) ;; (a b) (declare (type (integer -13583709 -3876310) b)) (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f14 (f14-1 f14-2 f14-3) (flet ((%f2 (f2-1 &optional (f2-2 0) (f2-3 0) (f2-4 (block b8 (if (ldb-test (byte 0 0) 0) (* 0 f14-2) 0)))) 0)) (%f2 b f14-2)))) (%f14 0 0 (%f14 0 0 0))))) ;; -155589 -5694124) 0) ;;; sbcl 0.8.6.34 ;;; Wrong value (deftest misc.235 (funcall (compile nil '(lambda (b) (declare (notinline not)) (declare (optimize (speed 1) (space 0) (safety 0) (debug 2) (compilation-speed 3))) (multiple-value-prog1 0 (catch 'ct2 (if (not nil) (throw 'ct2 b) 0))))) :wrong) 0) (deftest misc.236 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 1) (space 0) (safety 3) (debug 0) (compilation-speed 1))) (flet ((%f8 (f8-1) 0)) (labels ((%f18 (f18-1 f18-2 &optional (f18-3 0)) (%f8 (catch 'ct7 (throw 'ct7 f18-1))))) (multiple-value-prog1 (catch 'ct7 a) 0 (multiple-value-call #'%f18 (values 0 (%f8 b)))))))) :good :bad) :good) (deftest misc.237 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 1))) (multiple-value-prog1 0 (catch 'ct7 (logandc1 (block b7 0) (throw 'ct7 -908543))))))) 0) ;;; cmucl (11 2003 snapshot) ;;; NIL is not of type C::CONTINUATION (deftest misc.238 (funcall (compile nil '(lambda (a) (declare (type (integer -77145797 -1) a)) (declare (optimize (speed 1) (space 1) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f5 (f5-1) a)) (%f5 (unwind-protect 0 (logand (- (catch 'ct5 0)))))))) -100) -100) (deftest misc.238a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 0))) (min (load-time-value 0)) 0))) 0) ;;; (in C::MAYBE-LET-CONVERT) (deftest misc.239 (funcall (compile nil '(lambda (a) (declare (type (integer -2315418108387 111852261677) a)) (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) (compilation-speed 1))) (labels ((%f4 () (labels ((%f16 (f16-1 f16-2) 0)) (flet ((%f9 () 0)) (%f16 0 (%f16 (%f9) a)))))) (flet ((%f10 (f10-1 f10-2 f10-3) (flet ((%f15 (f15-1 &optional (f15-2 (%f4)) (f15-3 0)) f15-3)) 0))) 0)))) 100) 0) (deftest misc.239a (funcall (compile nil '(lambda () (declare (optimize speed safety)) (LET ((x (PROG1 0 (ROUND 18916)))) (catch 'ct4 0))))) 0) (deftest misc.240 (funcall (compile nil '(lambda (b) (declare (type (integer 4 7) b)) (declare (optimize (speed 2) (space 3) (safety 3) (debug 1) (compilation-speed 3))) (unwind-protect 0 (common-lisp:handler-case (max (let ((*s1* b)) (declare (special *s1*)) (+ 0 *s1*))))))) 5) 0) ;;; clisp (12 Dec 2003 cvs head) ;;; *** - Compiler bug!! Occurred in ASSEMBLE-LAP at ILLEGAL INSTRUCTION. (deftest misc.241 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 2))) (labels ((%f17 (f17-1 f17-2) (multiple-value-prog1 0 0 0 (return-from %f17 0)))) (%f17 0 0))))) 0) (deftest misc.242 (funcall (compile nil '(lambda (a) (block b6 (multiple-value-prog1 a (return-from b6 0))))) :wrong) 0) (deftest misc.243 (funcall (compile nil '(lambda () (block b3 (return-from b3 (multiple-value-prog1 0 (return-from b3 0))))))) 0) ;;; lispworks 4.3 (personal edition) (deftest misc.244 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) (compilation-speed 2))) (catch 'ct8 (labels ((%f4 (&optional (f4-1 0) (f4-2 (throw 'ct8 0))) f4-1)) (%f4 b))))) :wrong) 0) (deftest misc.245 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 1))) (catch 'ct2 (labels ((%f11 (&optional (f11-1 (throw 'ct2 0))) a)) (apply #'%f11 0 nil))))) 20) 20) ;;; ecl (cvs head, 18 Dec 2003) (deftest misc.246 (let ((x (unwind-protect 0))) x) 0) (deftest misc.247 (let ((x (dotimes (i 0 10)))) x) 10) ;;; acl 6.2 trial ;;; "Error: Attempt to access the plist field of 0 which is not a symbol." (deftest misc.248 (funcall (compile nil '(lambda () (dotimes (i 0 0) 0)))) 0) ;;; sbcl ;;; # ;;; not found in ;;; # (deftest misc.249 (funcall (compile nil '(lambda (a b) (declare (notinline <=)) (declare (optimize (speed 2) (space 3) (safety 0) (debug 1) (compilation-speed 3))) (if (if (<= 0) nil nil) (labels ((%f9 (f9-1 f9-2 f9-3) (ignore-errors 0))) (dotimes (iv4 5 a) (%f9 0 0 b))) 0))) 1 2) 0) ;;; cmucl 11/2003 (deftest misc.250 (funcall (compile nil '(lambda (a) (declare (type (integer -12 14) a)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) (compilation-speed 3))) (let ((v6 0)) (flet ((%f11 (f11-1 &optional (f11-2 (case (catch 'ct7 0) (t (let* ((v2 (ignore-errors a))) v6))))) 0)) (%f11 0 0))))) 5) 0) ;;; NIL is not of type C::CONTINUATION ;;; (C::MAYBE-CONVERT-TO-ASSIGNMENT ;;; # ;;; WHERE-FROM= :DEFINED ;;; VARS= (F3-1 F3-2 F3-3)>) (deftest misc.251 (funcall (compile nil '(lambda (a b) (declare (type (integer -186585769 -7483) a)) (declare (type (integer -550 524) b)) (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) (compilation-speed 3))) (flet ((%f3 (f3-1 f3-2 f3-3) 0)) (%f3 0 0 (flet ((%f13 (f13-1 f13-2) 0)) (if (/= b a) b (deposit-field (%f3 0 b 0) (byte 0 0) (%f3 0 0 (%f13 0 0))))))))) -10000 0) 0) ;;; 8061593093 is not of type (INTEGER -2147483648 4294967295) (deftest misc.252 (funcall (compile nil '(lambda (b) (declare (type (integer -43443 9126488423) b)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) (compilation-speed 0))) (logand (setq b 8061593093) (min b 0)))) 0) 0) (deftest misc.252a (funcall (compile nil '(lambda (a b) (declare (type (integer -30189 -6047) a)) (declare (type (integer -10 16391481067) b)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) (compilation-speed 0))) (if (<= 0 (let ((*s1* (setq b 12204309028))) (declare (special *s1*)) (truncate b))) a 0))) -12618 16130777867) -12618) ;;; # fell through ETYPECASE expression. ;;; Wanted one of (C::BASIC-COMBINATION C::EXIT C::CRETURN C::CSET C::CIF ;;; (OR C::REF C:BIND)). ;;; [Condition of type CONDITIONS::CASE-FAILURE] ;;;[...] ;;; (C::SUBSTITUTE-CONTINUATION # #) (deftest misc.253 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 2))) (flet ((%f17 (f17-1) 0)) (%f17 (logandc1 0 (catch 'ct2 0))))))) 0) (deftest misc.253a (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 1) (safety 3) (debug 2) (compilation-speed 1))) (labels ((%f1 (f1-1 f1-2) (isqrt (abs (complex f1-1 0))))) (progn (/ (multiple-value-call #'%f1 (values (1- (restart-bind nil 1416182210)) 123337746)) 1) (tagbody) c)))) -34661) -34661) ;;; Wrong return value (deftest misc.254 (funcall (compile nil '(lambda (a) (declare (type (integer -5241 -1159) a)) (declare (optimize (speed 3) (space 2) (safety 0) (debug 3) (compilation-speed 1))) (gcd a (let ((*misc.254* (setq a -4929))) ;; special variable (declare (special *misc.254*)) 0)))) -3000) 3000) (deftest misc.255 (funcall (compile nil '(lambda (b) (declare (type (integer -3474321 15089206) b)) (declare (optimize (speed 3) (space 3) (safety 3) (debug 3) (compilation-speed 0))) (- b (block b3 (setq b 9367613) 0)))) 10) 10) ;;; clisp (20 Dec 2003) ;;; Bug involving tagbody and go in lexical function (deftest misc.256 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 0) (safety 3) (debug 0) (compilation-speed 0))) (tagbody (flet ((%f6 () (go 18))) (%f6)) 18)))) nil) ;;; clisp (22 Dec 2003) ;;; *** - Compiler bug!! Occurred in ACCESS-IN-STACK at STACKZ-END. (deftest misc.257 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) (compilation-speed 1))) (declare (special b)) (tagbody (flet ((%f1 (f1-1) (flet ((%f9 (&optional (f9-1 b) (f9-2 (go tag2)) (f9-3 0)) 0)) (%f9 0 0 0)))) (%f1 0)) tag2)))) nil) ;;; clisp (26 Dec 2003) ;;; PROGV binding is not having the correct effect in compiled code (deftest misc.258 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) (compilation-speed 0))) (let ((*s4* :right)) (declare (special *s4*)) (progv '(*s4*) (list :wrong1) (setq *s4* :wrong2)) *s4*)))) :right) ;;; sbcl 0.8.7.5 ;;; The value 215067723 is not of type (INTEGER 177547470 226026978). (deftest misc.259 (funcall (compile nil '(lambda (a) (declare (type (integer 177547470 226026978) a)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 0) (compilation-speed 1))) (logand a (* a 438810)))) 215067723) 13739018) (deftest misc.260 (funcall (compile nil '(lambda (a) (declare (type (integer 43369342 45325981) a)) (declare (optimize (speed 2) (space 0) (safety 2) (debug 0) (compilation-speed 3))) (logand 0 (* 5459177 a)))) 44219966) 0) (deftest misc.261 (funcall (compile nil '(lambda (b) (declare (type (integer 379442022 806547932) b)) (declare (optimize (speed 2) (space 0) (safety 0) (debug 3) (compilation-speed 2))) (logand b (* 227 b)))) 551173513) 545263625) (deftest misc.262 (funcall (compile nil '(lambda (a) (declare (type (integer 515644 54674673) a)) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 1))) (mask-field (byte 0 0) (* 613783109 a)))) 28831407) 0) (deftest misc.263 (funcall (compile nil '(lambda (a) (declare (type (integer 862944 60462138) a)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 1) (compilation-speed 1))) (logandc2 0 (* a 18094747)))) 36157847) 0) (deftest misc.264 (funcall (compile nil '(lambda (a) (declare (type (integer 896520522 1249309734) a)) (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 2))) (lognand 0 (* a 1381212086)))) 1202966173) -1) ;;; sbcl 0.8.7.6 ;;; Lisp error during constant folding: ;;; The function SB-VM::%LEA-MOD32 is undefined. (deftest misc.265 (funcall (compile nil '(lambda (a) (declare (type (integer -19621 11895) a)) (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) (compilation-speed 3))) (* 0 a 103754))) 1) 0) ;;; ecl (10 jan 2004) ;;; A bug was found in the compiler. Contact worm@arrakis.es. ;;; Broken at C::C2GO. (deftest misc.266 (funcall (compile nil '(lambda () (tagbody (flet ((%f (x) :bad)) (multiple-value-call #'%f (go done))) done)))) nil) (deftest misc.266a (funcall (compile nil '(lambda (b) (declare (type (integer -14356828946432 -24266) b)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) (compilation-speed 2))) (progn (tagbody (unwind-protect 0 (go 3)) 3) b))) -30000) -30000) ;;; Broken at C::C2VAR. (deftest misc.266b (funcall (compile nil '(lambda (b) (declare (optimize (speed 2) (space 3) (safety 2) (debug 0) (compilation-speed 0))) (unwind-protect 0 (catch 'ct7 (prog1 b 0))))) 1) 0) ;;; Incorrect return value (deftest misc.267 (locally (declare (special *s5*)) (let ((v8 (progv '(*s5*) (list 0) (if t *s5* *s5*)))) v8)) 0) (deftest misc.267a (let ((x (progv nil nil 0))) x) 0) (deftest misc.268 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 3) (debug 2) (compilation-speed 2))) (catch 'ct7 (rationalize (let ((v9 (1+ (throw 'ct7 0)))) 48955)))))) 0) (deftest misc.269 (funcall (compile nil '(lambda (a) (declare (type (integer -1 20) a)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 2) (compilation-speed 3))) (if (if a (logbitp 34 a) nil) 0 -230678))) 14) -230678) (deftest misc.270 (let ((*s3* (dotimes (iv4 0 10) (if t iv4 8)))) (declare (special *s3*)) *s3*) 10) (deftest misc.271 (let ((v2 (unwind-protect 0))) v2) 0) ;;; wrong number of values passed to anonymous function (deftest misc.272 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 0) (debug 3) (compilation-speed 2))) (flet ((%f17 (f17-1) 1)) (multiple-value-call #'%f17 (values (floor 0))))))) 1) ;;; clisp (10 jan 2004) ;;; Improper handling of a jump to an exit point from unwind-protect ;;; (see CLHS section 5.2) (deftest misc.273 (funcall (compile nil '(lambda (d) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 0))) (gcd 39 (catch 'ct2 (block b7 (throw 'ct2 (unwind-protect (return-from b7 17) (return-from b7 (progv '(*s6*) (list 31) d)) ))))))) 65) 13) ;;; sbcl 0.8.7.13 ;;; Lexical unwinding of UVL stack is not implemented. (deftest misc.274 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 1) (debug 2) (compilation-speed 0))) (multiple-value-prog1 (ignore-errors 0) 0 (catch 'ct7 0) (catch 'ct1 (catch 'ct4 (complex (throw 'ct4 (dotimes (iv4 0 0) (throw 'ct1 0))) 0))))))) 0) (deftest misc.274a (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 3) (debug 1) (compilation-speed 3))) (dotimes (iv4 3 0) (apply (constantly 0) 0 (catch 'ct2 (throw 'ct2 (rem 0 (max 46 0)))) nil))))) 0) ;;; failed AVER: "SUCC" (deftest misc.275 (funcall (compile nil '(lambda (b) (declare (notinline funcall min coerce)) (declare (optimize (speed 1) (space 2) (safety 2) (debug 1) (compilation-speed 1))) (flet ((%f12 (f12-1) (coerce (min (if f12-1 (multiple-value-prog1 b (return-from %f12 0)) 0)) 'integer))) (funcall #'%f12 0)))) -33) 0) (deftest misc.275a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 2) (debug 1) (compilation-speed 1))) (block b4 (coerce (logcount (if t 0 (multiple-value-prog1 (identity 0) (return-from b4 0)))) 'integer))))) 0) ;;; clisp (28 Jan 2004) ;;; Different return values (deftest misc.276 (funcall (compile nil `(lambda (b) (declare (optimize (speed 2) (space 0) (safety 0) (debug 3) (compilation-speed 3))) (labels ((%f2 () (let ((v10 (progn (dotimes (iv2 0 0) iv2) b))) (unwind-protect b (labels ((%f6 ())) (%f6)) )))) (%f2)))) :good) :good) ;;; Lispworks 4.3 linux (personal edition) ;;; Error: In - of (1 NIL) arguments should be of type NUMBER (deftest misc.277 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 0) (debug 3) (compilation-speed 0))) (labels ((%f15 (&optional (f15-3 (tagbody (labels ((%f6 () (go tag1))) (%f6)) tag1))) 0)) (%f15))))) 0) ;;; incorrect return value (deftest misc.278 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 0))) (catch 'ct5 (flet ((%f2 (&optional (f2-4 (throw 'ct5 0))) 1)) (%f2 (%f2 0))))))) 1) ;;; incorrect return value (deftest misc.279 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 3) (debug 0) (compilation-speed 3))) (flet ((%f10 () (if (< 0 (dotimes (iv2 1 -501162))) 0 -14))) (%f10))))) -14) ;;; incorrect return value (may be same bug as misc.278) (deftest misc.280 (funcall (compile nil '(lambda (a) (declare (optimize (speed 1) (space 3) (safety 1) (debug 3) (compilation-speed 2))) (catch 'ct6 (labels ((%f12 () (labels ((%f14 (&optional (f14-3 (return-from %f12 5))) 4)) (funcall (constantly 3) (let ((v2 (%f14))) 2) (throw 'ct6 1) )))) (%f12) a)))) :good) :good) ;;; incorrect return value (deftest misc.281 (funcall (compile nil '(lambda (c) (declare (optimize (speed 3) (space 3) (safety 3) (debug 2) (compilation-speed 3))) (ldb (byte 24 0) c))) -227016367797) 12919115) ;;; gcl: Error in COMPILER::CMP-ANON [or a callee]: The function COMPILER::LDB1 is undefined. (deftest misc.282 (funcall (compile nil '(lambda () (declare (optimize safety)) (ldb (byte 13 13) 43710)))) 5) ;;; gcl (2/28/2004) ;;; Error in COMPILER::CMP-ANON [or a callee]: T is not of type INTEGER. (deftest misc.283 (funcall (compile nil '(lambda (b d) (declare (optimize (speed 2) (space 2) (safety 1) (compilation-speed 3))) (expt (logxor (progn (tagbody (multiple-value-prog1 0 (go 7)) 7) 0) 0 b (rational d)) 0))) 2 4) 1) ;;; Error in COMPILER::CMP-ANON [or a callee]: 3 is not of type FUNCTION. ;;; (possibly the same bug as misc.283) (deftest misc.284 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 1) (safety 2) (debug 3) (compilation-speed 2))) (progn (tagbody (multiple-value-prog1 0 (go tag2)) 0 tag2) (funcall (constantly 0) (apply (constantly 0) (signum c) nil))))) 3) 0) ;;; ecl 29 Feb 2004 ;;; Incorrect constant propagation (deftest misc.285 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 3))) (block b7 (let* ((v1 (* (return-from b7 0) a))) -4359852)))) 1) 0) (deftest misc.286 (let ((v4 (dotimes (iv4 0 18494910) (progn 0)))) v4) 18494910) ;;; gcl (found by Camm) ;;; Error in COMPILER::CMP-ANON [or a callee]: The function NIL is undefined. (deftest misc.287 (funcall (compile nil '(lambda (e) (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f11 (f11-2) 0)) (%f11 (unwind-protect e (tagbody (let* ((v4 (unwind-protect (go 0)))) 0) 0) (logand (handler-bind () 0))))))) 10) 0) #| ecl (6 Mar 2004) (LAMBDA (C::LOC1 C::LOC2) (IF (AND (CONSP C::LOC1) (EQ (CAR C::LOC1) 'FIXNUM) (CONSP (CADR C::LOC1)) (EQ (CAADR C::LOC1) 'C::FIXNUM-VALUE) (EQ (CADR (CADR C::LOC1)) 2)) (PROGN (C::WT1 "(1<<(") (C::WT1 C::LOC2) (C::WT1 "))")) (PROGN (C::WT1 "fixnum_expt(") (C::WT1 C::LOC1) (C::WT1 #\,) (C::WT1 C::LOC2) (C::WT1 #\))))) is not of type STRING. Broken at C::WT-C-INLINE-LOC. |# (deftest misc.288 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) (compilation-speed 2))) (let ((v2 (integer-length (expt 0 0)))) (dotimes (iv4 0 0) (logand v2)))))) 0) ;;; cmucl ;;; wrong return value (deftest misc.289 (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 1) (safety 1) (debug 2) (compilation-speed 2))) (multiple-value-prog1 (apply (constantly 0) b 0 0 nil) (catch 'ct8 (throw 'ct8 -2))))) 1) 0) ;;; sbcl (0.8.8.23.stack.1) ;;; failed AVER: "(TAILP BLOCK2-STACK BLOCK1-STACK)" (deftest misc.290 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 3) (safety 1) (debug 2) (compilation-speed 0))) (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil)))) 0) (deftest misc.290a (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (boole boole-nor (expt (let ((v2 (expt (catch 'ct7 0) 0))) 0) 0) (expt (apply (constantly 0) 0 0 (catch 'ct6 0) nil) 0))))) -2) ;; Allegro CL 6.2 (14 Mar 2004) interpreter bug ;; Error: Cannot go to TAG, its body has been exited. (deftest misc.291 (funcall #'(lambda (a) (declare (notinline numerator)) (declare (optimize (speed 2) (space 3) (safety 2) (debug 0) (compilation-speed 2))) (tagbody (tagbody (progn a) tag) (go tag) tag)) 17) nil) ;;; sbcl 0.8.8.23.stack.2 ;;; The value -1 is not of type (MOD 536870911). (deftest misc.292 (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 1))) (flet ((%f15 (f15-1 f15-2 f15-3) (apply (constantly 0) 0 0 (ignore-errors (let ((v10 (apply (constantly 0) b a (max 0 c) nil))) 0)) nil))) (flet ((%f14 (f14-1 &optional (f14-2 b) (f14-3 0) (f14-4 0)) (%f15 0 0 b))) (%f14 0 c))))) 1 2 3) 0) (deftest misc.292a (funcall (compile nil '(lambda (a b) (declare (optimize (speed 2) (space 0) (safety 3) (debug 1) (compilation-speed 2))) (apply (constantly 0) a 0 (catch 'ct6 (apply (constantly 0) 0 0 (let* ((v1 (let ((*s7* 0)) b))) 0) 0 nil)) 0 nil))) 1 2) 0) ;;; failed AVER: "(NOT (MEMQ PUSH END-STACK))" (deftest misc.293 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 1) (safety 3) (debug 3) (compilation-speed 3))) (let ((v6 (labels ((%f9 (f9-1) (multiple-value-prog1 0 (return-from %f9 0) a))) (let ((*s4* (%f9 0))) 0)))) 0))) 1) 0) (deftest misc.293a (funcall (compile nil '(lambda (a b c) (declare (optimize (speed 2) (space 3) (safety 1) (debug 2) (compilation-speed 2))) (block b6 (multiple-value-prog1 0 b 0 (catch 'ct7 (return-from b6 (catch 'ct2 (complex (cl::handler-bind nil -254932942) 0)))))))) 1 2 3) -254932942) (deftest misc.293b (funcall (compile nil '(lambda () (declare (notinline complex)) (declare (optimize (speed 1) (space 0) (safety 1) (debug 3) (compilation-speed 3))) (flet ((%f () (multiple-value-prog1 0 (return-from %f 0)))) (complex (%f) 0))))) 0) (deftest misc.293c (funcall (compile nil '(lambda (a b) (declare (type (integer -6556 -33) a)) (declare (type (integer -1973908574551 1125) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 0) (space 2) (safety 0) (debug 2) (speed 0) #+sbcl (sb-c:insert-step-conditions 0) )) (block b4 (multiple-value-prog1 0 (catch 'ct7 (return-from b4 (catch 'ct6 (if a 0 b)))) 0 0)))) -237 -1365751422718) 0) (deftest misc.293d (funcall (compile nil '(lambda () (declare (optimize (debug 3) (safety 0) (space 2) (compilation-speed 2) (speed 2))) (block b4 (multiple-value-prog1 0 (catch 'ct8 (return-from b4 (catch 'ct2 (progn (tagbody) 0))))))))) 0) ;;; failed AVER: "(SUBSETP START START-STACK)" (deftest misc.294 (funcall (compile nil '(lambda (a b c) (declare (notinline /=)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 0)(compilation-speed 1))) (catch 'ct1 (flet ((%f1 (f1-1 f1-2 f1-3) (throw 'ct1 (if (/= 0) 0 (multiple-value-prog1 0 (throw 'ct1 a) c))))) (let ((*s3* (%f1 a a 0))) 0))))) 1 2 3) 0) (deftest misc.294a (funcall (compile nil '(lambda (a b c) (declare (notinline expt)) (declare (optimize (speed 1) (space 2) (safety 3) (debug 0) (compilation-speed 0))) (catch 'ct2 (expt (catch 'ct2 (throw 'ct2 (if a 0 (multiple-value-prog1 0 (throw 'ct2 c) 0)))) 0)))) 1 2 3) 1) ;;; The value NIL is not of type SB-C::IR2-BLOCK. (deftest misc.295 (funcall (compile nil '(lambda (a b c) (declare (type (integer -2858 1050811) a)) (declare (type (integer -419372 1395833) b)) (declare (type (integer -4717708 795706) c)) (declare (ignorable a b c)) (declare (optimize (speed 1) (space 0) (safety 2) (debug 1) (compilation-speed 2))) (multiple-value-prog1 (the integer (catch 'ct8 (catch 'ct5 (catch 'ct7 (flet ((%f3 (f3-1 f3-2 &optional (f3-3 a) (f3-4 c)) b)) (labels ((%f13 (f13-1 f13-2 f13-3) (let* ((*s4* (return-from %f13 (flet ((%f18 (f18-1 f18-2) (apply #'%f3 (progv nil nil f13-2) (list (%f3 -460 f18-1 10095 352819651))))) (flet ((%f5 () (funcall #'%f3 f13-2 (flet ((%f14 (f14-1 f14-2 &optional (f14-3 f13-2) (f14-4 -15)) 160080387)) -196377) (isqrt (abs (if (/= 117 (%f18 -14 -46574)) (return-from %f13 (ignore-errors (flet ((%f12 (f12-1 f12-2 &optional (f12-3 740148786) (f12-4 -20) (f12-5 -35261)) f12-3)) (%f3 (%f3 b (%f12 c b f13-3 f13-1 -1124)) 0 -1003264058 f13-1)))) (block b3 (labels ((%f15 () f13-2)) -4858377))))) (%f3 793 f13-2 f13-3 a)))) f13-3))))) (* -420793 (%f3 (%f3 f13-1 f13-3 f13-3 f13-2) 0 8604 f13-1))))) (lognor (progv nil nil (if (< -16 c) 15867134 (- (throw 'ct5 (prog1 7 (floor (max (%f13 -4862 -888 -53824112) a -17974 1540006) (min -74 -473379))))))) (progv nil nil (prog1 b 22 c a))))))))) (catch 'ct1 (throw 'ct1 0)) 0))) 794801 211700 -1246335) 7) ;;; Tests added by Camm for gcl (deftest misc.296 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2016726144 234357120) a)) (declare (type (integer -10569521299456 -1307998945280) b)) (declare (type (integer -45429002240 -17228484608) c)) (declare (type (integer 228451840 1454976512) d)) (declare (type (integer -4797 -2609) e)) (declare (type (integer -21 36300536) f)) (declare (type (integer -15983530 31646604) g)) (declare (type (integer -208720272 -357) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 3))) (expt (labels ((%f14 (f14-1 f14-2) (progn (tagbody (+ (unwind-protect (labels ((%f1 (f1-1) (go tag1))) (let ((*s6* (%f1 d))) 0)))) tag1 (+ (cl::handler-bind () (if (<= -11215713 -819) (integer-length (floor (conjugate f14-1) (max 12 (ceiling (block b2 (catch 'ct2 (ignore-errors (flet ((%f13 (f13-1) (logior 87 f14-2))) f14-1)))))))) (progv '(*s8*) (list 472865632) *s8*))))) 0))) (%f14 0 0)) 0))) -28594854 -3859203606860 -40757449218 894599577 -4163 11621230 29558853 -92216802) 1) (deftest misc.297 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -4354712743936 666241234) a)) (declare (type (integer -23496787232 13342697120) b)) (declare (type (integer -6834570 6274788) c)) (declare (type (integer -1988742 -250650) d)) (declare (type (integer 10523345 10868247) e)) (declare (type (integer -489185 -46267) f)) (declare (type (integer -627627253760 226529) g)) (declare (type (integer -1039260485 -22498) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 2) (debug 2) (compilation-speed 0))) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 0) (f7-5 0) (f7-6 (labels ((%f6 (f6-1) (labels ((%f9 (f9-1) 0)) (progn (tagbody (unwind-protect (if (%f9 (go tag4)) 0 0)) tag4 (cl::handler-case 0)) h)))) (apply #'%f6 0 nil)))) 0)) (%f7 0 d 0 f d)))) -4319330882538 -3195059121 -2799927 -1466395 10630639 -224479 -502579707077 -985908422) 0) (deftest misc.298 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer 1296736620544 1680954654720) a)) (declare (type (integer -2 -2) b)) (declare (type (integer 1 42303) c)) (declare (type (integer -38881008000 1333202563072) d)) (declare (type (integer -435684 1289298) e)) (declare (type (integer -164302654464 -10150328832) f)) (declare (type (integer 30759259904 38429537792) g)) (declare (type (integer -1628949299200 -47724342) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 1) (safety 0) (debug 0) (compilation-speed 1))) (progn (tagbody (let ((v9 (unwind-protect (go 0)))) 0) 0 (numerator (funcall (constantly 0) (logorc2 0 0) 0))) 0))) 1451922002679 -2 285 1067997670626 1115209 -37445463114 36530345360 -80501559891) 0) (deftest misc.299 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -1814 3348) a)) (declare (type (integer -32239015 12) b)) (declare (type (integer 128412 101411593) c)) (declare (type (integer -329076792320 -22) d)) (declare (type (integer 77651198 86069496) e)) (declare (type (integer -4616 3453771) f)) (declare (type (integer -14889981824 53610580608) g)) (declare (type (integer -1049733788 46605484288) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 2) (compilation-speed 2))) (conjugate (progn (tagbody (flet ((%f3 nil 0)) (unwind-protect (flet ((%f10 (f10-1) (let ((*s6* (%f3))) (go 6)))) (funcall #'%f10 f)))) 6 (let ((*s1* (restart-bind () (labels ((%f1 (f1-1) 3136)) (let () (progv '(*s5* *s1*) (list (labels ((%f2 nil (catch 'ct8 -11))) -70941710) (if nil (%f1 -1) 87)) (progn (tagbody (%f1 *s1*) 3 (block b2 (progn a)) tag3) h))))))) 0)) 0)))) 1555 -22062210 85224215 -161218251003 78463284 730073 33930166854 37839245921) 0) (deftest misc.300 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -29429 -3320) a)) (declare (type (integer -407874593 279639852) b)) (declare (type (integer -542849760256 3344389718016) c)) (declare (type (integer -2 12012755) d)) (declare (type (integer -248 -228) e)) (declare (type (integer 5 15636824592) f)) (declare (type (integer 21039 21595) g)) (declare (type (integer -1867743555584 -1621183025152) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 1) (debug 2) (compilation-speed 3))) (labels ((%f12 (f12-1 f12-2 f12-3) 0)) (labels ((%f17 (f17-1) (progn (tagbody (max (apply (constantly 0) (list (%f12 (unwind-protect (go tag1)) 0 d) 0 f))) tag1 (dpb (realpart (expt (round (return-from %f17 (restart-bind () (complex e 0))) (max 40 0)) 0)) (byte 0 0) 0)) 0))) (%f12 0 (%f17 0) 0))))) -6416 -274982013 2946309248013 1724720 -228 5782683458 21484 -1681168611256) 0) (deftest misc.301 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -1814 3348) a)) (declare (type (integer -32239015 12) b)) (declare (type (integer 128412 101411593) c)) (declare (type (integer -329076792320 -22) d)) (declare (type (integer 77651198 86069496) e)) (declare (type (integer -4616 3453771) f)) (declare (type (integer -14889981824 53610580608) g)) (declare (type (integer -1049733788 46605484288) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 2) (compilation-speed 2))) (conjugate (progn (tagbody (flet ((%f3 nil 0)) (unwind-protect (flet ((%f10 (f10-1) (let ((*s6* (%f3))) (go 6)))) (funcall #'%f10 f)))) 6 (let ((*s1* (restart-bind () (labels ((%f1 (f1-1) 3136)) (let () (progv '(*s5* *s1*) (list (labels ((%f2 nil (catch 'ct8 -11))) -70941710) (if nil (%f1 -1) 87)) (progn (tagbody (%f1 *s1*) 3 (block b2 (progn a)) tag3) h))))))) 0)) 0)))) 1555 -22062210 85224215 -161218251003 78463284 730073 33930166854 37839245921) 0) (deftest misc.302 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -206837809920 -126404559104) a)) (declare (type (integer -277874608640 -63724432) b)) (declare (type (integer -2 0) c)) (declare (type (integer -5992710 9946878) d)) (declare (type (integer -4345390743552 -76504514048) e)) (declare (type (integer -330 3826137) f)) (declare (type (integer -517792898560 -1193868) g)) (declare (type (integer 2018 98092396) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 1) (compilation-speed 1))) (flet ((%f12 (f12-1 f12-2 &optional (f12-3 0) (f12-4 (progn (tagbody (unwind-protect (go tag6)) tag6) (flet ((%f1 (f1-1 f1-2) 0)) (apply #'%f1 0 0 (list)))))) 0)) (%f12 0 e)))) -195379170409 -30212852077 -1 -2082141 -1686846623470 360505 -324299330279 37218064) 0) (deftest misc.303 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -55724018 0) a)) (declare (type (integer -4929718 2777256) b)) (declare (type (integer 18939493568 24064422528) c)) (declare (type (integer -13157393 112210531) d)) (declare (type (integer -75775 -4883) e)) (declare (type (integer 5071 1584913674240) f)) (declare (type (integer -1 -1) g)) (declare (type (integer -100 7017454141440) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 1) (compilation-speed 1))) (labels ((%f7 (f7-1 &optional (f7-2 0) (f7-3 0) (f7-4 0)) 0)) (progn (denominator (progn (let ((*s6* (progn (tagbody (unwind-protect (%f7 0 0 (go tag6) d)) tag6 (restart-case 0)) 0))) 0) 0)) 0)))) -23410726 -4342503 20297113275 80145634 -17664 937086103773 -1 2923877584757) 0) (deftest misc.304 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -11679 1672) a)) (declare (type (integer -359757 -216048) b)) (declare (type (integer -46345706880 -1824) c)) (declare (type (integer -18 18) d)) (declare (type (integer -70852138 427028370944) e)) (declare (type (integer -428904547840 535369082368) f)) (declare (type (integer -4372225 83) g)) (declare (type (integer -2 0) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 0) (compilation-speed 1))) (labels ((%f1 (f1-1 f1-2 f1-3) 0)) (rationalize (%f1 (progn (tagbody (let ((v3 (%f1 (unwind-protect (go tag2)) b 0))) 0) tag2) 0) h (cl::handler-case 0)))))) -7209 -223767 -42093806027 -9 132172281069 138363461574 -3751010 0) 0) (deftest misc.305 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -438 247) a)) (declare (type (integer -93662232 112841) b)) (declare (type (integer 8769 2766606) c)) (declare (type (integer -33007133760 32531429568) d)) (declare (type (integer 419 3712) e)) (declare (type (integer 1628 20513914304) f)) (declare (type (integer -1347290 47) g)) (declare (type (integer -12 3030073088) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 3) (compilation-speed 0))) (flet ((%f5 (f5-1 f5-2 &optional (f5-3 0) (f5-4 0) (f5-5 0)) (progn (tagbody (unwind-protect (go tag1)) tag1) (coerce (let* ((*s4* (flet ((%f1 nil (let* ((v7 (dpb 0 (byte 0 0) c))) a))) (progv '(*s6* *s7*) (list (%f1) 0) g)))) c) 'integer)))) (if (%f5 d 0 e 0 0) h 0)))) -58 -22237190 2055343 -8144832891 1213 19038103159 -1009345 929619162) 929619162) (deftest misc.306 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer 261 234565) a)) (declare (type (integer -1454263719936 -3279802168) b)) (declare (type (integer -1251120498 -49518770) c)) (declare (type (integer 0 369) d)) (declare (type (integer -12465203856 -45) e)) (declare (type (integer -94321486 -91941853) f)) (declare (type (integer -16528338864 11322249648) g)) (declare (type (integer -1230549 -1143976) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (denominator (progn (tagbody (unwind-protect (go tag7)) tag7) (logxor f (multiple-value-bind (*s4*) (logxor 0 (expt -2 1)) (truncate 0))))))) 130724 -736795298357 -1221747467 326 -9775240900 -94105708 -2273680158 -1156846) 1) (deftest misc.307 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2903632 1282236) a)) (declare (type (integer 7 10741) b)) (declare (type (integer -249635 214804) c)) (declare (type (integer -50422 10469) d)) (declare (type (integer -52337314 10771161) e)) (declare (type (integer 0 5333060) f)) (declare (type (integer -1 0) g)) (declare (type (integer 1595835 4577573) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) (compilation-speed 1))) (flet ((%f11 (f11-1 f11-2) 0)) (%f11 0 (unwind-protect e (progn (tagbody (let* ((v4 (progn (unwind-protect (go 0)) 0))) 0) 0) (logand (cl::handler-bind () (logand -15 -2 32578787 10349 e -24781944 -8))))))))) 60336 1625 124302 -33193 -8095855 4995857 0 4572381) 0) (deftest misc.308 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2806612475904 8750665416704) a)) (declare (type (integer -3 10) b)) (declare (type (integer -94336824 116591592) c)) (declare (type (integer 456813135872 903636350976) d)) (declare (type (integer -2364199833600 -172353318912) e)) (declare (type (integer 717 1760915) f)) (declare (type (integer -21 105) g)) (declare (type (integer -3579048169472 -346272903168) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (labels ((%f7 (f7-1) (multiple-value-prog1 0 0 (return-from %f7 (mask-field (byte 0 0) 0))))) (unwind-protect (%f7 0))))) 1951007924893 10 -49879990 614214833752 -1808568999586 1282634 99 -2783010573143) 0) (deftest misc.309 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -521338 12) a)) (declare (type (integer -1787856009216 1182078822400) b)) (declare (type (integer -3313 28535137344) c)) (declare (type (integer -38914612 -25121536) d)) (declare (type (integer 403073126400 2632230309888) e)) (declare (type (integer -39663606528 -1238304) f)) (declare (type (integer -103560 -70383) g)) (declare (type (integer -894 -227) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) (compilation-speed 2))) (block b8 (multiple-value-prog1 (logand (logior 0 (if (logbitp 0 0) 0 (multiple-value-bind (v2) 0 0)))) (gcd (let* ((*s4* 0)) (logior 0 (return-from b8 (let ((*s8* 0)) (round 0)))))) 0 0)))) -275760 -565946697213 9650536069 -37585973 1536165173011 -12895970021 -102192 -534) 0 0) (deftest misc.310 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -2016726144 234357120) a)) (declare (type (integer -10569521299456 -1307998945280) b)) (declare (type (integer -45429002240 -17228484608) c)) (declare (type (integer 228451840 1454976512) d)) (declare (type (integer -4797 -2609) e)) (declare (type (integer -21 36300536) f)) (declare (type (integer -15983530 31646604) g)) (declare (type (integer -208720272 -357) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 3))) (expt (labels ((%f14 (f14-1 f14-2) (progn (tagbody (+ (unwind-protect (labels ((%f1 (f1-1) (go tag1))) (let ((*s6* (%f1 d))) 0)))) tag1 (+ (cl::handler-bind () (if (<= -11215713 -819) (integer-length (floor (conjugate f14-1) (max 12 (ceiling (block b2 (catch 'ct2 (ignore-errors (flet ((%f13 (f13-1) (logior 87 f14-2))) f14-1)))))))) (progv '(*s8*) (list 472865632) *s8*))))) 0))) (%f14 0 0)) 0))) -28594854 -3859203606860 -40757449218 894599577 -4163 11621230 29558853 -92216802) 1) (deftest misc.311 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -1203392327680 -3017953) a)) (declare (type (integer -34222 -1) b)) (declare (type (integer -871294987 19) c)) (declare (type (integer 717979131904 3341735845888) d)) (declare (type (integer -7521858 3) e)) (declare (type (integer -52 49) f)) (declare (type (integer 18 43) g)) (declare (type (integer -503567246 -46) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 1) (debug 2) (compilation-speed 2))) (labels ((%f2 (f2-1 f2-2 f2-3 &optional (f2-4 (let ((*s6* (progn (tagbody (flet ((%f17 (f17-1 f17-2 f17-3) (go 6))) (%f17 0 b 0)) 6) 0))) (complex (progn (tagbody (labels ((%f18 (f18-1 f18-2 &optional (f18-3 0) (f18-4 f)) 0)) (apply #'%f18 g 0 0 (list))) 0) 0) 0))) (f2-5 0) (f2-6 0)) 0)) (%f2 0 0 f)))) -738307241633 -25016 -846570136 2181696281793 -983259 24 36 -185316211) 0) (deftest misc.312 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -18334222 14354736) a)) (declare (type (integer 11163582 6421184978944) b)) (declare (type (integer -13690431913984 -64765792960) c)) (declare (type (integer -12750925 31112834) d)) (declare (type (integer -5188669232 2246825616) e)) (declare (type (integer -31235593088 -134) f)) (declare (type (integer -1 -1) g)) (declare (type (integer -647589424 12392126736) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 3) (space 2) (safety 1) (debug 1) (compilation-speed 1))) (let ((*s4* (if (progn (tagbody (unwind-protect (go 2)) 2) 0) (numerator (let* ((v1 (let ((*s6* 0)) (logand b (rationalize (coerce 0 'integer)))))) 0)) 0))) 0))) 7112398 3547401482305 -12827294644277 23312291 -444957551 -5443955020 -1 4998457143) 0) (deftest misc.313 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer 55474 401001) a)) (declare (type (integer -8359558987776 8684176949248) b)) (declare (type (integer -54332 116292) c)) (declare (type (integer 0 0) d)) (declare (type (integer -609311104000 959776553984) e)) (declare (type (integer -2031580 3834807) f)) (declare (type (integer -10955 2549) g)) (declare (type (integer -8362590032 -210369) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 3) (safety 1) (debug 0) (compilation-speed 1))) (dotimes (iv1 3 0) (labels ((%f6 (f6-1 f6-2 f6-3 &optional (f6-4 (flet ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 0)) (flet ((%f11 nil 0)) (ash (progn (tagbody (labels ((%f3 (f3-1 &optional (f3-2 (go tag4))) 0)) (%f3 0)) tag4) 0) (min 42 (conjugate (coerce (conjugate (let ((v9 (%f11))) f3-1)) 'integer))))))) (%f3 c 0 a))) (f6-5 0)) 0)) (apply #'%f6 0 0 h nil))))) 93287 3146418586486 -51786 0 -63479145888 1935918 -10058 -2033798238) 0) (deftest misc.314 (funcall (compile nil '(lambda (a b c d e f g h) (declare (type (integer -176150296 698) a)) (declare (type (integer -62799871488 -56234210816) b)) (declare (type (integer -1 1) c)) (declare (type (integer 31 215808) d)) (declare (type (integer -3 -1) e)) (declare (type (integer -3 3387651) f)) (declare (type (integer -14370846720 -56648624) g)) (declare (type (integer -8316238784 -6221617344) h)) (declare (ignorable a b c d e f g h)) (declare (optimize (speed 1) (space 1) (safety 1) (debug 2) (compilation-speed 2))) (progn (tagbody (unwind-protect (let ((v10 (let* ((v7 (if (go tag6) 0 0))) 0))) 0)) tag6 (let ((v7 (flet ((%f11 nil 0)) (flet ((%f13 (f13-1 f13-2 f13-3) f13-2)) (funcall #'%f13 0 a (%f11)))))) 0)) 0))) -90583503 -61289371485 -1 175888 -3 3257970 -3264725617 -6816839328) 0) ;;; (misc.315 deleted) ;;; ACL 6.2 interpreter bugs ;;; Error: `NIL' is not of the expected type `NUMBER' ;;; (in COMP::IA-RESOLVE-REFS) (deftest misc.316 (funcall (compile nil '(lambda (a c) (declare (optimize (speed 2) (space 3) (safety 2) (debug 2) (compilation-speed 0))) (unwind-protect 0 (progn (tagbody (bit #*000000111 (min 8 (max 0 a))) tag5 (flet ((%f17 (f17-1 f17-2 f17-3) (complex (numerator (go tag4)) 0))) c) tag4) c)))) 1 2) 0) ;;; ecl failures (12 April 2004) ;;; wrong value returned (deftest misc.317 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 3) (debug 0) (compilation-speed 3))) (catch 'ct4 (elt '(40760) (min 0 (max 0 (let* ((v3 (* (throw 'ct4 0) 0))) 0)))))))) 0) ;;; seg fault (deftest misc.318 (funcall (compile nil '(lambda (a b c) (declare (type (integer -2050548150 4917) a)) (declare (type (integer -4 1) b)) (declare (type (integer 99335934976 442465125376) c)) (declare (ignorable a b c)) (declare (optimize (speed 1) (space 1) (safety 1) (debug 0) (compilation-speed 0))) (if (rationalize (labels ((%f12 (f12-1) (if c 0 (bit #*101010011000011 (min 14 (max 0 0)))))) (if (> 0 c) 0 (%f12 0)))) (progn (expt (flet ((%f18 (f18-1 f18-2 &optional (f18-3 0) (f18-4 c) (f18-5 b)) 0)) (apply #'%f18 b b 0 0 nil)) 0) a) 0))) 10 1 99335934976) 10) ;;; seg fault (deftest misc.319 (funcall (compile nil '(lambda (a b c) (declare (type (integer -626615938 3649977016320) a)) (declare (type (integer -3615553 6013683) b)) (declare (type (integer -746719 1431737508) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) (compilation-speed 3))) (if (logbitp 0 (flet ((%f10 (f10-1 f10-2 f10-3) b)) (flet ((%f4 (f4-1 f4-2) (apply #'%f10 (%f10 0 a 0) 0 c nil))) (complex (%f4 0 0) 0)))) 0 0))) 2378435476701 1646880 246794654) 0) ;;; sbcl 0.8.9.35 ;;; failed AVER: "(EQL (LAMBDA-COMPONENT FUNCTIONAL) *CURRENT-COMPONENT*)" (deftest misc.320 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 0) (safety 2) (debug 2) (compilation-speed 0))) (catch 'ct2 (elt '(102) (flet ((%f12 () (rem 0 -43))) (multiple-value-call #'%f12 (values)))))))) 102) (deftest misc.320a (funcall (compile nil '(lambda (b) (declare (optimize (speed 3) (space 0) (safety 2) (debug 2) (compilation-speed 0))) (reduce '* (list (elt '(10 20 30 40 50) b) (expt (reduce #'(lambda (lmv1 lmv3) (mod lmv3 15)) (vector 0 0)) 0) (rem 0 -71)) ))) 2) 0) (deftest misc.320b (funcall (compile nil '(lambda (a b c) (declare (type (integer -690191 -454473) a)) (declare (type (integer -459197 -62) b)) (declare (type (integer 445621505781 8489194559765) c)) (declare (ignorable a b c)) (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 3))) (elt '(3327764 3386241) (min 1 (max 0 (reduce #'(lambda (lmv6 lmv5) (mod 0 (min -86 0))) (list 0 0))))))) -512398 -156405 1140919327630) 3327764) ;;; ecl ;;; Wrong value (deftest misc.321 (funcall (compile nil '(lambda (p) (declare (optimize (speed 1) (space 3) (safety 2) (debug 1) (compilation-speed 3))) (catch 'ct2 (let* ((v3 (- (if p (throw 'ct2 :good) 0)))) :bad)))) t) :good) ;;; segfault (deftest misc.322 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 2) (safety 0) (debug 3) (compilation-speed 2))) (logorc2 (labels ((%f14 (f14-1) a)) (%f14 0)) (reduce #'(lambda (lmv1 lmv2) a) (list 0 0))))) 3151096069) -1) ;; #1# is undefined (deftest misc.323 (let* ((tail '(:from-end t)) (form `(lambda () (declare (optimize (speed 3) (space 1) (safety 2) (debug 2) (compilation-speed 2))) (eval '(reduce #'logior (vector (reduce #'logand (vector 0 0) . ,tail) 0) . ,tail))))) (funcall (compile nil form))) 0) ;;; Bad value (deftest misc.324 (funcall (compile nil '(lambda (a) (declare (optimize (speed 2) (space 2) (safety 3) (debug 2) (compilation-speed 3))) (labels ((%f6 (f6-1) (multiple-value-setq (a) 0))) (reduce #'(lambda (lmv4 lmv3) a) (list (%f6 0) 2))))) 1) 0) ;;; "A bug was found in the compiler. Contact worm@arrakis.es." ;;; Broken at C::C2MULTIPLE-VALUE-SETQ. (deftest misc.325 (funcall (compile nil '(lambda (a b) (declare (type (integer -1659358 3099614928896) a)) (declare (type (integer -492625 197903) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) (compilation-speed 1))) (reduce #'(lambda (lmv5 lmv6) (multiple-value-setq (a) 2443855591508)) (vector b a 0 0) :from-end t))) 1 2) 2443855591508) ;;; wrong value (deftest misc.326 (funcall (compile nil '(lambda (b) (declare (type (integer 155 7955) b)) (declare (optimize (speed 3) (space 3) (safety 3) (debug 1) (compilation-speed 0))) (flet ((%f13 (f13-1) (shiftf b 3019))) (+ b (%f13 0))))) 200) 400) ;;; acl 6.2 (x86 linux trial edition, patched, 4/15/04) ;;; Error: `NIL' is not of the expected type `REAL' (deftest misc.327 (funcall (compile nil '(lambda (a b) (declare (type (integer -67668056 -55) a)) (declare (type (integer -586950907 -10945000) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) (compilation-speed 1))) (labels ((%f15 (f15-1) (elt #(1073730663 1073689230 596123606 1073713997 311527378 186184643 1073713230 1316881) (min 7 (max 0 (catch 'ct7 (reduce #'min (list 0 b (catch 'ct7 (throw 'ct7 f15-1)) 0) :start 1 :from-end t))))))) (%f15 0)))) -38276611 -11001852) 1073730663) ;;; wrong return value: T (deftest misc.327a (funcall (compile nil '(lambda (a b c d e) (declare (notinline max vector reduce)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) (compilation-speed 2))) (reduce #'(lambda (lmv6 lmv3) lmv3) (vector 0 (max 0) 0 0 (catch 'ct2 (catch 'ct2 (throw 'ct2 0))) 0 e 0) :end 2 :from-end t))) 68664683637 328245 881497115 -303855 311427) 0) ;;; Bugs from abcl ;;; Debugger invoked on condition of type TYPE-ERROR: ;;; The value org.armedbear.lisp.Symbol@54 is not of type integer. (deftest misc.328 (funcall (compile nil '(lambda (a b) (declare (type (integer -11368047588 14412128900) a)) (declare (type (integer -10 0) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) (compilation-speed 0))) (if (logbitp 0 (if (or t nil) (setf a -2616861879) 0)) 0 0))) -4836700955 -1) 0) ;;; Incorrect value (deftest misc.329 (funcall (compile nil '(lambda (a b) (declare (type (integer -725661427 405092) a)) (declare (type (integer 84176291516 98216856233) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 0))) (let ((*s2* (case b ((53651 62711 29537 25305 62250) 0) (t 0)))) (declare (special *s2*)) (setq a -688292831)))) -406606203 84436335326) -688292831) (deftest misc.330 (funcall (compile nil '(lambda (a b) (declare (type (integer -12816761394938 -8706928710678) a)) (declare (type (integer -3683497948554 427) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 3) (compilation-speed 2))) (lcm (block b8 (signum (return-from b8 a)))))) -12715609319989 -582329850697) 12715609319989) (deftest misc.331 (funcall (compile nil '(lambda (a b) (declare (type (integer -777352478 239900) a)) (declare (type (integer -63500163479 -8671) b)) (declare (ignorable a b)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 2) (compilation-speed 3))) (if (if (>= 0) t t) (setq b -25319949896) b))) 0 -10000) -25319949896) ;;; Debugger invoked on condition of type TYPE-ERROR: ;;; The value 0 is not of type org.armedbear.lisp.Symbol@80f563d8. (deftest misc.332 (funcall (compile nil '(lambda (a b) (declare (notinline max logorc1 numerator rem)) (declare (optimize (speed 3) (space 1) (safety 1) (debug 1) (compilation-speed 2))) (rem (progn (tagbody (numerator (logorc1 0 (go tag5))) tag5) 0) (max 93 0)))) -801 17641908) 0) ;;; Debugger invoked on condition of type TYPE-ERROR: ;;; The value # is not of type org.armedbear.lisp.Symbol@80f563d8. (deftest misc.333 (funcall (compile nil '(lambda () (declare (notinline logxor)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 3) (compilation-speed 3))) (logxor (progn (tagbody (let* ((*s4* (progn (go 1) 0))) 0) 1) 0))))) 0) ;;; Debugger invoked on condition of type PROGRAM-ERROR: ;;; Wrong number of arguments for EXPT. (deftest misc.334 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1892675246514 8763564964618) a)) (declare (type (integer -1353 -456) b)) (declare (type (integer 2010840649 2119165101) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 0) (debug 2) (compilation-speed 1))) (+ (block b6 (expt (return-from b6 b) 0))))) 3966745735633 -1123 2030094113) -1123) ;;; The value NIL is not of type number. (deftest misc.335 (let ((c 10)) (denominator (progn (tagbody (realpart (loop for lv4 below 2 sum (go 0))) 0) c))) 1) (deftest misc.336 (prog2 (progn (tagbody (- (common-lisp:handler-case (go tag2))) tag2) 0) 0) 0) ;;; Incorrect return value (deftest misc.337 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 2) (debug 0) (compilation-speed 0))) (imagpart (block b8 (logior (block b7 (return-from b8 225480400)))))))) 0) ;;; Inconsistent stack height 1 != 2 (deftest misc.338 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (conjugate (block b8 (max (if c (return-from b8 0) 0)))))) 10)) 0) ;;; Inconsistent stack height 4 != 0 (deftest misc.339 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 0))) (block b1 (reduce #'min (list (return-from b1 0)) :end 1 :start 0 :from-end t )))))) 0) ;;; The value INTEGER is not of type sequence. (deftest misc.340 (funcall (compile nil '(lambda (a b c) (declare (type (integer -4379340 -1962) a)) (declare (type (integer 1304043 3225940) b)) (declare (type (integer -3229571579853 -180689150012) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 0) (debug 2) (compilation-speed 2))) (coerce (rationalize (progn (tagbody (reduce #'logand (list b 0 (go tag3)) :from-end t) tag3) 0)) 'integer))) -1625211 3052955 -2091182035681) 0) ;;; Inconsistent stack height 1 != 2 (deftest misc.341 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) (compilation-speed 3))) (logeqv (block b6 (logeqv (case 0 ((45293 29462 60403) (return-from b6 0)) (t c))))))) 10)) 10) ;;; Inconsistent stack height 0 != 1 (deftest misc.342 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (optimize (speed 1) (space 0) (safety 2) (debug 1) (compilation-speed 2))) (progn (tagbody (imagpart (dotimes (iv3 0 a) (go 4))) 4) 0))) 1)) 0) ;;; Expecting to find object/array on stack (deftest misc.343 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 3) (safety 2) (debug 3) (compilation-speed 2))) (mask-field (byte 0 0) (block b8 (reduce 'logior (list (return-from b8 0) 0 0) :end 3 :start 0 :from-end t))))))) 0) ;;; Wrong value (deftest misc.344 (funcall (compile nil '(lambda (a) (declare (type (integer -3464434 12316202) a)) (declare (optimize (speed 1) (space 0) (safety 0) (debug 0) (compilation-speed 2))) (progn (tagbody (gcd (expt (setf a -2612809) 0) (go 5)) 5) a))) 1891348) -2612809) ;;; Stack size too large (deftest misc.345 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b c) (declare (type (integer -1968 -1759) a)) (declare (type (integer 91 2293818743282) b)) (declare (type (integer -843793650839 -2) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 3))) (max (block b1 (conjugate (dotimes (iv3 0 (bit #*010 (min 2 (max 0 (return-from b1 0))))) (progn 0)))) (sbit #*0001011010010 (min 12 (max 0 0)))))) -1957 523078358699 -634832888815)) 0) (deftest misc.345a (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (declare (type (integer -3011346550 1630587670) c)) (declare (optimize (speed 1) (space 1) (safety 0) (debug 3) (compilation-speed 1))) (progn (tagbody (dotimes (iv2 0 (- 0 (go 7))) (progn 0)) 7 (progn (mask-field (byte 0 0) 0) c)) 0))) 1)) 0) ;;; wrong return value (deftest misc.346 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 2) (debug 2) (compilation-speed 2))) (bit #*011100 (min 5 (max 0 (block b8 (aref #(122010971004 126555236004) (min 1 (max 0 (progn (return-from b8 191438621) 0))))))))))) 0) ;;; The value 8 is not of type FUNCTION. (deftest misc.347 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 3) (debug 2) (compilation-speed 1))) (complex (* (block b2 (boole boole-xor (logxor (return-from b2 0)) 0))) 0)))) 0) ;;; Wrong result (deftest misc.348 (funcall (compile nil '(lambda (a c) (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 1))) (max (conjugate (setq a -4178265097)) (if (> c 0) 0 a)))) -2408319173 -4307532101272) -4178265097) (deftest misc.349 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (space 1) (safety 1) (debug 1) (compilation-speed 2))) (mod (let ((*s7* (block b7 (logandc2 (+ (return-from b7 0)) 0)))) -10) (max 26 0))))) 16) ;;; Inconsistent stack height 0 != 1 (deftest misc.350 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 3) (safety 1) (debug 2) (compilation-speed 3))) (progn (tagbody (complex (- 0 (if (and t) 0 (go tag1))) 0) tag1) 0))))) 0) (deftest misc.351 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (c) (declare (type (integer -598962457711 -2902) c)) (declare (optimize (speed 1) (space 0) (safety 1) (debug 0) (compilation-speed 3))) (lognor c (block b1 (loop for lv3 below 1 sum (if (/= 0) (return-from b1 0) c)))))) -392248104420)) 392248104419) (deftest misc.352 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) (compilation-speed 1))) (progn (tagbody (+ 0 (if (< 0) (go 5) 0)) 5) 0))))) 0) (deftest misc.353 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -8 -2) a)) (declare (type (integer -67321 14697029362) b)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 1) (compilation-speed 2))) (expt (block b2 (loop for lv1 below 3 sum (prog2 b 0 (expt (case 0 ((-13960 -57685 -37843 -34222 -14273 -40931 -2688) (return-from b2 0)) (t a)) 0)))) 0))) -7 772373806)) 1) ;;; Incorrect return value (deftest misc.354 (funcall (compile nil '(lambda (a b c) (declare (type (integer -1309 67082465417) a)) (declare (type (integer -7824641338734 -832606641) b)) (declare (type (integer 7473698771 3542216118742) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 1) (debug 3) (compilation-speed 2))) (+ 0 (progn (tagbody (if (if (>= b (go 3)) nil t) a c) 3) 0)))) 29329060987 -4964942044116 512158612507) 0) (deftest misc.355 (funcall (compile nil '(lambda (c) (declare (type (integer -1390043946499 -115168466439) c)) (declare (optimize (speed 2) (space 0) (safety 0) (debug 1) (compilation-speed 2))) (+ 0 (coerce (progn (tagbody (if (<= -1 (go tag1)) 0 c) tag1) 0) 'integer)))) -115168466439) 0) (deftest misc.356 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 2) (safety 1) (debug 0) (compilation-speed 3))) (let ((*s7* 0)) (dotimes (iv2 0 0) (block b3 (block b3 (block b3 (setq *s7* (return-from b3 0))))))))))) 0) (deftest misc.357 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (b) (declare (type (integer -1750881587721 -327383867) b)) (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) (compilation-speed 3))) (denominator (block b2 (let* ((*s8* 0)) (setq *s8* (case 0 ((-26733 -244 -26253 -50028) 0) (t (return-from b2 b))))))))) -1153135130306)) 1) (deftest misc.358 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 0) (debug 3) (compilation-speed 1))) (rationalize (let* ((*s1* 0)) (block b3 (conjugate (let* ((v10 (if (ldb-test (byte 0 0) 0) (return-from b3 *s1*) 0))) (setq *s1* (return-from b3 0))))))))))) 0) (deftest misc.359 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -477801566869 432060432661) a)) (declare (type (integer 366578392 525704751) b)) (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 1))) (max (case b ((0 -3 -2 -2 -3) (progn (tagbody (loop for lv1 below 2 count (let* ((*s1* a)) (setq *s1* (go 4)))) 4) 0)) (t 0))))) 287358622300 400248608)) 0) ;;; Wrong return value (deftest misc.360 (let ((c :good)) (tagbody (dotimes (j 1 (setf c :bad)) (go done)) done) c) :good) ;;; sbcl bugs (0.8.10.4) ;;; failed AVER: "(SUBSETP END END-STACK)" (deftest misc.361 (funcall (compile nil '(lambda (a b c) (declare (notinline boole values denominator list)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 0) (compilation-speed 2))) (catch 'ct6 (progv '(*s8*) (list 0) (let ((v9 (ignore-errors (throw 'ct6 0)))) (denominator (progv nil nil (values (boole boole-and 0 v9))))))))) 1 2 3) 0) ;;; sbcl (0.8.10.15) ;;; Wrong return value: SB-KERNEL:*HANDLER-CLUSTERS* (deftest misc.362 (funcall (compile nil '(lambda (b g h) (declare (optimize (speed 3) (space 3) (safety 2) (debug 2) (compilation-speed 3))) (catch 'ct5 (unwind-protect (labels ((%f15 (f15-1 f15-2 f15-3) (rational (throw 'ct5 0)))) (%f15 0 (apply #'%f15 0 h (progn (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) 0) nil) 0)) (common-lisp:handler-case 0))))) 1 2 3) 0) ;;; Wrong value: NIL (deftest misc.363 (funcall (compile nil '(lambda (a) (declare (type (integer -17286401550789 15753784105886) a)) (declare (optimize (speed 2) (space 2) (safety 2) (debug 0) (compilation-speed 3))) (if (not (>= 0 (shiftf a 110236462073))) 0 (elt '(30 101 13 2 10 52 89 57) (min 7 (max 0 a)))))) -3647332298473) 57) ;;; "full call to SB-KERNEL:DATA-VECTOR-REF" (deftest misc.364 (dotimes (iv1 2 0) (if (> iv1 iv1) (svref #(2002 3778 1998 3466 530 3279 2033 521 4085) (min 8 (max 0 iv1))) 0)) 0) ;;; OpenMCL/darwin bug (12 May 2004) (deftest misc.365 (let* ((fn1 '(lambda (a b c) (declare (type (integer -2 21) a)) (declare (type (integer -5651364356 4324101092) b)) (declare (type (integer -30766087 28182568) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) (compilation-speed 1))) (coerce (logxor b -1) 'integer))) (fn2 '(lambda (a b c) (declare (notinline logxor coerce)) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 2))) (coerce (logxor b -1) 'integer))) (vals '(9 -328421075 -6406890)) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good) ;;; sbcl 0.8.10.24 ;;; Argument X is not a REAL: # (deftest misc.366 (funcall (compile nil '(lambda (a b c d e f g h i) (declare (type (integer 10 65866342) a)) (declare (type (integer 151 702748905609) b)) (declare (type (integer -60442925 167939283) c)) (declare (type (integer 7706 10562) d)) (declare (type (integer -97180326158 17496) e)) (declare (type (integer -73249 -51989) f)) (declare (type (integer -12 2718) g)) (declare (type (integer -37832 591244) h)) (declare (type (integer -2579781276 2108461452) i)) (declare (ignorable a b c d e f g h i)) (declare (optimize (speed 3) (space 0) (safety 0) (debug 2) (compilation-speed 2))) (elt '(11751 8554 7393 1924 3418) (min 4 (max 0 (block b4 (numerator (flet ((%f5 (f5-1 f5-2 f5-3 &optional (f5-4 (prog1 0 (return-from b4 0) 0)) (f5-5 d) (f5-6 0)) 0)) (numerator (apply (constantly 0) 0 0 (rationalize (unwind-protect (%f5 0 c (%f5 0 c (%f5 0 0 0 h (%f5 0 0 0) i) a)) (ignore-errors 0))) 0 nil)))))))))) 21956127 524275646496 101890987 8762 -88607922426 -55959 2177 147174 38469170) 11751) ;;; The value # ;;; is not of type RATIONAL. (deftest misc.367 (funcall (compile nil '(lambda (a b) (declare (type (integer 11557968 115977463) a)) (declare (type (integer -89510 -20616) b)) (declare (optimize (speed 2) (space 3) (safety 1) (debug 0) (compilation-speed 1))) (rational (flet ((%f17 (f17-1 f17-2) 0)) (%f17 (numerator (%f17 (denominator (catch 'ct5 (apply (constantly 0) 0 (unwind-protect (catch 'ct2 (throw 'ct5 (progn (%f17 a b) a)))) nil))) 0)) (%f17 0 a)))))) 112475717 -25829) 0) ;;; sbcl 0.8.10.25 ;;; "The value -3 is not of type (INTEGER -5 -2)." (deftest misc.368 (funcall (compile nil '(lambda (a) (declare (type (integer -5 -2) a)) (declare (ignorable a)) (declare (optimize (speed 2) (space 3) (safety 1) (debug 1) (compilation-speed 1))) (if (and (not (not (> a (numerator (setf a -4))))) (logbitp 0 (conjugate a))) 0 0))) -3) 0) ;;; acl 6.2 (x86 linux trial edition, patched, 4/15/04) ;;; Error: `T' is not of the expected type `NUMBER' (deftest misc.369 (funcall (compile nil '(lambda (a b c d e) (declare (type (integer -15256078323 33828721319) a)) (declare (type (integer -44368 22872) b)) (declare (type (integer -7623 -7522) c)) (declare (type (integer -53 289) d)) (declare (type (integer -1853649832248 2196352552304) e)) (declare (ignorable a b c d e)) (declare (optimize (speed 1) (space 2) (safety 0) (debug 0) (compilation-speed 3))) (flet ((%f2 (f2-1 &optional &key (key1 0) (key2 e)) (labels ((%f5 (f5-1 f5-2 f5-3 &optional &key (key1 (aref #(397) (min 0 (max 0 (let ((v7 (make-array nil :initial-element d))) (reduce #'(lambda (lmv5 lmv6) key1) (vector f2-1 0) :start 0)))))) &allow-other-keys) 0)) 0))) b))) -2821485338 -35420 -7622 135 9592294022) -35420) ;;; Lispworks personal edition 4.3 (x86 linux) ;;; Inconsistent return value (deftest misc.370 (funcall (compile nil '(lambda (a b c) (declare (type (integer -3070433 6) a)) (declare (type (integer -5 -3) b)) (declare (type (integer -4433759745778 -1) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 1) (safety 0) (debug 2) (compilation-speed 3))) (flet ((%f15 (f15-1 f15-2 &optional (f15-3 0) (f15-4 (denominator (setq c -4214677583716))) (f15-5 0) &key (key1 c) &allow-other-keys) (progv '(*s1* *s5* *s7*) (list f15-2 0 f15-1) key1))) (%f15 0 (%f15 c 0) 0)))) -1233959 -4 -2643533316361) -4214677583716) ;;; Armed Bear CL ;;; inconsistent stack height (deftest misc.371 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b c) (declare (type (integer -7288 10764) a)) (declare (type (integer -7 24) b)) (declare (type (integer 7951930344 11209871544) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 2) (safety 0) (debug 0) (compilation-speed 0))) (rationalize (block b1 (if b (return-from b1 (progn (tagbody (return-from b1 (let* ((*s1* (cons (go tag3) 0))) (declare (dynamic-extent *s1*)) 0)) tag3) 0)) 0))))) -5566 9 10557204445)) 0) ;;; 0 is not of type LIST (deftest misc.372 (funcall (compile nil '(lambda (a b c) (declare (type (integer -738508 627) a)) (declare (type (integer -100241328874 104421) b)) (declare (type (integer -71651668566 4932238952300) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 2) (safety 1) (debug 3) (compilation-speed 2))) (sbit #*0 (min 0 (max 0 (multiple-value-bind (v1) (cons c (truncate 0 (min -42 0))) (cdr v1))))))) -657195 -10801112339 -4291316763) 0) ;;; inconsistent stack height (deftest misc.373 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b c) (declare (type (integer 0 179061) a)) (declare (type (integer -15793 42532) b)) (declare (type (integer -2 0) c)) (declare (ignorable a b c)) (declare (optimize (speed 3) (space 0) (safety 2) (debug 1) (compilation-speed 0))) (reduce 'logxor (list 0 b 0 0 a 0 0 0 (block b6 (let* ((v6 (cons (if c (return-from b6 0) 0) b))) 0)) 0) :end 6 :from-end t))) 141814 1445 -2)) 142419) (deftest misc.374 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -99 4) a)) (declare (type (integer 35621436 36172433) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (space 1) (safety 3) (debug 1) (compilation-speed 0))) (lognand (let ((v6 0)) (declare (dynamic-extent v6)) v6) (block b6 (let* ((v10 (cons (expt (case 0 ((30207) (return-from b6 0)) (t b)) 0) 0))) (declare (dynamic-extent v10)) 0))))) -57 35725118)) -1) ;;; abcl (23 May 2004) ;;; 0 is not of type LIST (deftest misc.375 (funcall (compile nil '(lambda (a b c d e f) (declare (type (integer -3172868 25583841) a)) (declare (type (integer -8176159 1565888775976) b)) (declare (type (integer -2601325109 147819602) c)) (declare (type (integer -502316251909 515874281072) d)) (declare (type (integer 174 2604648) e)) (declare (type (integer 1627646459 3124243119) f)) (declare (ignorable a b c d e f)) (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 2))) (let* ((*s6* (make-array nil :initial-element 0 :adjustable t))) (if (logbitp 0 (denominator (prog2 (truncate (dotimes (iv3 0 0) (progn 0))) (multiple-value-bind (*s7*) (cons d 0) (cdr *s7*))))) 0 0)))) 12851164 182468232812 -2243976802 309299185674 2538150 1855615980) 0) ;;; abcl (25 May 2004) ;;; 0 is not of type LIST (deftest misc.376 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (space 1) (safety 2) (debug 1) (compilation-speed 0))) (dotimes (iv4 3 (multiple-value-bind (*s6*) (cons 0 0) (progn (cdr *s6*) 0))) (floor (rational (let ((*s2* (rational (common-lisp:handler-case 0)))) 0))))))) 0) (deftest misc.377 (funcall (compile nil '(lambda (e) ; (a b c d e) (declare (type (integer -46778182694 512) e)) (declare (optimize (speed 3) (space 3) (safety 2) (debug 2) (compilation-speed 3))) (if (block b3 (numerator (progn (tagbody (truncate (dotimes (iv3 0 0) (block b3 0))) (multiple-value-bind (*s5*) (cons 0 e) (rationalize (cdr *s5*)))) 0))) 0 0))) 10) 0) (deftest misc.378 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 0) (safety 1) (debug 3) (compilation-speed 2))) (dotimes (iv4 3 0) (restart-case (round (multiple-value-bind (*s6*) (cons c 0) (car *s6*))))))) 1) 0) (deftest misc.379 (funcall (compile nil '(lambda () (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) (compilation-speed 1))) (values (floor 0) (multiple-value-bind (v3) (cons 0 0) (car v3)))))) 0 0) ;;; gcl (31 May 2004, cvs head) ;;; Error in APPLY [or a callee]: Expected a FIXNUM ;;; Also fails in cmucl 1/2003 (deftest misc.380 (funcall (compile nil '(lambda (a) (declare (type (integer -1397457 1846252) a)) (declare (optimize (speed 2) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (let ((v9 (make-array nil :initial-element 0))) (declare (dynamic-extent v9)) (block b8 (let ((*s1* 0)) (let ((*s4* (let ((*s1* (return-from b8 (rational (setf (aref v9) (deposit-field -5 (byte 20 30) a)))))) 0))) (let ((*s8* (cons 0 0))) 0))))))) 399997) 1125898833500797) ;; This also fails in cmucl (11/2003 image). This case has not been fully ;; pruned for cmucl. ;; ;; Error in function LISP::ASSERT-ERROR: The assertion (NOT C::WIN) failed. (deftest misc.381 (funcall (compile nil '(lambda (a) (declare (type (integer -1397457 1846252) a)) (declare (optimize (speed 2) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (let ((v9 (make-array nil :initial-element 0))) (declare (dynamic-extent v9)) (block b8 (let ((s1 0)) (let ((s4 (let ((s1 (return-from b8 (rational (setf (aref v9) (deposit-field -5 (byte 20 30) a)))))) 0))) (let ((s8 (cons 0 0))) 0))))))) 399997) 1125898833500797) ;;; gcl (31 May 2004, cvs head) ;;; Error in SYSTEM:ASET [or a callee]: Expected a FIXNUM (deftest misc.382 (funcall (compile nil '(lambda (b) (declare (type (integer -65822755520 31689335872) b)) (declare (optimize (speed 2) (space 2) (safety 3) (debug 0) (compilation-speed 1))) (let ((s8 (make-array nil :initial-element (catch 'ct4 (complex (dotimes (iv1 1 0) (rational (throw 'ct4 b))) 0))))) (elt '(13423701584) (min 0 (max 0 (rational (let ((s3 (make-array nil :initial-element 0))) (if (ldb-test (byte 0 0) (shiftf (aref s8) (aref s8))) 0 0))))))))) -38169486910) 13423701584) ;;; cmucl 11/2003 ;;; Wrong value (deftest misc.383 (funcall (compile nil '(lambda (a b c) (declare (type (integer -93650 118967004056) a)) (declare (type (integer -429173946 -3892) b)) (declare (type (integer -229669685 -50537386) c)) (declare (ignorable a b c)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 3) (space 1) (safety 0) (debug 3) (compilation-speed 2))) (logorc2 (let* ((*s3* (cons 0 a))) (declare (dynamic-extent *s3*)) (shiftf c -124766263)) 411942919))) 79909316946 -347537841 -210771963) -142606339) ;;; abcl 7 Jun 2004 ;;; catch-throw now enabled in the abcl compiler ;;; Inconsistent stack height (deftest misc.384 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (catch 'ct8 (throw 'ct8 (catch 'ct7 0))))))) 0) (deftest misc.385 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (values 1 (catch 'ct2 2)))))) 1 2) (deftest misc.386 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (values (rationalize (catch 'ct1 1)) 2))))) 1 2) (deftest misc.387 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (block b1 (catch 'ct1 (throw 'ct1 (return-from b1 0)))))))) 0) ;;; ecl (cvs head, 13 June 2004) ;;; Problems with multiple-value-setq ; NIL cannot be coerced to a C int. (deftest misc.388 (funcall (compile nil '(lambda (a b c) (declare (type (integer 200077 60836768) a)) (declare (type (integer 339831915 371006999) b)) (declare (type (integer -13 5553) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) (compilation-speed 0))) (dotimes (iv4 2 0) (multiple-value-setq (c) 4212)))) 8959928 366395687 5048) 0) ;;; wrong return value (deftest misc.389 (funcall (compile nil '(lambda (a b c) (declare (type (integer -49972981888 -48068810368) a)) (declare (type (integer -452283089 -27620701) b)) (declare (type (integer -24815 15089) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 1) (safety 2) (debug 1) (compilation-speed 0))) (multiple-value-setq (c) 8015))) -49966124671 -68547159 12944) 8015) ;;; Evaluation order bug (deftest misc.390 (funcall (compile nil '(lambda (a b c) (declare (type (integer -257 -140) a)) (declare (type (integer -1 1069496658) b)) (declare (type (integer -4 2001960914944) c)) (declare (ignorable a b c)) (declare (optimize (speed 2) (space 0) (safety 1) (debug 0) (compilation-speed 1))) (labels ((%f12 (f12-1 &optional (f12-2 (setq b 63838027)) &key (key1 0) (key2 0)) b)) (boole boole-orc2 b (let ((*s3* (%f12 0))) -14))))) -173 1028908375 1289968133290) 1028908383) ;;; sbcl 0.8.14.14 ;;; "The value NIL is not of type SB-C::LVAR" (deftest misc.391 (funcall (compile nil '(lambda (a b) (declare (optimize (speed 2) (space 0) (safety 0) (debug 1) (compilation-speed 3))) (let* ((v5 (cons b b))) (declare (dynamic-extent v5)) a))) 'x 'y) x) ;;; sbcl 0.8.14.18 ;;; "The value # ;;; is not of type SB-C::REF." (deftest misc.392 (funcall (compile nil '(lambda (a b) (declare (notinline /=)) (declare (optimize (speed 1) (space 2) (safety 1) (debug 3) (compilation-speed 3))) (prog2 0 0 (loop for lv4 below 3 count (or b (/= b)))))) 1 2) 0) ;;; cmucl (2004-09 snapshot) ;;; "Error in function C::CORE-CALL-TOP-LEVEL-LAMBDA: ;;; Unresolved forward reference." ;;; (in C::CORE-CALL-TOP-LEVEL-LAMBDA) (deftest misc.393 (funcall (compile nil '(lambda (a b) (declare (type (integer -995205 1035654) a)) (declare (type (integer 473 114804994247) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 3) (speed 2) (compilation-speed 0) (space 3) (safety 3))) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 (lcm (if (>= b a) 0 a))) (f7-5 0) &key) 0)) (progn (%f7 (%f7 b a a b) b 0) 0)))) 447930 66120263479) 0) (deftest misc.393a (funcall (compile nil '(lambda (a b) (declare (type (integer -76 86) a)) (declare (type (integer -13771285280 109) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (space 1) (debug 2) (compilation-speed 3) (speed 3))) (dotimes (iv1 2 0) (case (min -3693810 a iv1) ((26 -4) (ldb (byte 13 0) a)) (t b))))) 56 -1579426331) 0) ;;; cmucl (2004-09 snapshot) ;;; Wrong values (deftest misc.394 (funcall (compile nil '(lambda (a b) (declare (type (integer -76645001 98715919) a)) (declare (type (integer 0 856472753903) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 2) (space 0) (debug 3) (compilation-speed 0) (safety 3))) (logeqv 0 b))) -34528661 843541658238) -843541658239) (deftest misc.395 (funcall (compile nil '(lambda (a b) (declare (type (integer 6429252570156 8761983588786) a)) (declare (type (integer -400378288 4971722) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 3) (speed 3) (space 2) (safety 0) (compilation-speed 3))) (+ (shiftf a 8496033756259) (min 0 b)))) 8369430915156 -369704905) 8369061210251) ;;; "The assertion (EQ (CAR C::STACK) C::CONT) failed." (deftest misc.396 (funcall (compile nil '(lambda (a b) (declare (type (integer -1601 485) a)) (declare (type (integer -190428560464 -1444494) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 0) (space 2) (speed 0) (safety 3) (compilation-speed 2))) (apply (constantly 0) 0 (list (signum b))))) -1365 -46960621335) 0) ;;; "The assertion (EQ (C::FUNCTIONAL-KIND (C::LAMBDA-HOME C::FUN)) ;;; :TOP-LEVEL) failed." (deftest misc.397 (funcall (compile nil '(lambda (a b) (declare (type (integer -168258525920 -2044) a)) (declare (type (integer -522 54) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 0) (safety 3) (compilation-speed 1) (space 0) (debug 2))) (labels ((%f4 (f4-1 f4-2 &key) (flet ((%f7 (f7-1 f7-2 f7-3 &optional &key (key1 a)) (progv '(*s1* *s6* *s2*) (list a 0 key1) f4-1))) f4-2))) (apply #'%f4 (list a 0))))) -156882103995 -38) 0) ;;; "Error in function C::CLOSURE-POSITION: ;;; Can't find #>" (deftest misc.398 (funcall (compile nil '(lambda (a b) (declare (type (integer -319 7353) a)) (declare (type (integer 31751 4233916489) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (compilation-speed 1) (debug 1) (speed 0) (space 0))) (conjugate (if t (labels ((%f12 (f12-1 f12-2 f12-3) 0)) (%f12 0 b 0)) (dotimes (iv1 2 0) (catch 'ct2 a)))))) 4430 3476635674) 0) ;;; "NIL is not of type C::CONTINUATION" ;;; in C::FIND-PUSHED-CONTINUATIONS (deftest misc.399 (funcall (compile nil '(lambda (a) (declare (type (integer -3 1) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 0) (debug 0) (speed 3) (compilation-speed 2) (safety 3))) (catch 'ct8 (logior a -457019 -1)))) 0) -1) ;;; Wrong value (deftest misc.400 (funcall (compile nil '(lambda (a) (declare (type (integer 3376 4762) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 0) (safety 0) (space 0) (compilation-speed 3) (speed 3))) (case (lognand 775 a) ((-7) 0) (t 4)))) 4182) 0) ;;; Invalid number of arguments: 1 (deftest misc.401 (funcall (compile nil '(lambda (a) (declare (type (integer 7299 257071514003) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (compilation-speed 2) (space 1) (safety 2) (speed 1) (debug 2))) (logeqv (setq a 220250126156) 0))) 157474319912) -220250126157) ;;; "The assertion (EQ (CAR C::NEW-STACK) C::CONT) failed." (deftest misc.402 (funcall (compile nil '(lambda (a) (declare (type (integer -19116544 21344004) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 1) (safety 3) (debug 1) (compilation-speed 0) (speed 0))) (dotimes (iv3 2 0) (progn (apply (constantly 0) (list (let* ((*s1* 0)) *s1*))) 0)))) 10) 0) ;;; "The assertion C::INDIRECT failed." (deftest misc.403 (funcall (compile nil '(lambda (a) (declare (type (integer -6456 -32) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 3) (safety 1) (compilation-speed 1) (speed 0) (debug 0))) (dotimes (iv1 0 a) (loop for lv4 below 3 sum (catch 'ct8 0))))) -1648) -1648) ;;; From abcl (cvs, 15 Sept 2004) ;;; Inconsistent stack height (deftest misc.404 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -77007578505 7500480849) a)) (declare (type (integer 211464 53140083) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 0) (speed 2) (debug 3) (safety 1) (space 3))) (progn (tagbody (let ((v3 (cons (case a ((13 5 -9 2 -13) (go tag8)) (t 0)) 0))) 0) tag8) a))) -1068524571 20786758)) -1068524571) (deftest misc.405 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -82196 13938) a)) (declare (type (integer -44152792 -15846835) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 3) (safety 2) (speed 3) (space 0) (debug 0))) (block b5 (let ((*s7* (cons (if (position (if (eql 0 0) (return-from b5 (return-from b5 (let ((*s6* (cons b a))) 0))) b) #(23) :test-not 'eql) 0 0) b))) 0)))) -10305 -26691848)) 0) (deftest misc.406 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -1 1412366903315) a)) (declare (ignorable a)) (declare (optimize (debug 3) (safety 3) (space 3) (compilation-speed 1) (speed 2))) (progn (tagbody (case 0 ((1 0 4) (values (go 1) 0)) (t 0)) 1) 0))) 251841706892)) 0) ;;; Incorrect binding (deftest misc.407 (funcall (compile nil '(lambda (a) (declare (type (integer -324 175) a)) (declare (ignorable a)) (declare (optimize (safety 0) (space 0) (speed 2) (debug 0) (compilation-speed 0))) (multiple-value-bind (v5) (cons (truncate 0) a) (cdr v5)))) -279) -279) ;;; Stack size too large (deftest misc.408 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 0 0) a)) (declare (ignorable a)) (declare (optimize (compilation-speed 0) (safety 3) (speed 0) (debug 1) (space 0))) (progn (tagbody (dotimes (iv4 0 (let ((v5 (cons 0 (if (go 3) 0 0)))) 0)) (progn 0)) 3) (ash 0 (min 16 0))))) 0)) 0) ;;; ecl (07 Oct 2004) ;;; (0 . 0) is not of type REAL (deftest misc.409 (funcall (compile nil '(lambda (a b) (declare (type (integer -40524 53538) a)) (declare (type (integer -5967075 -235) b)) (declare (ignorable a b)) (declare (optimize (speed 2) (safety 1) (space 2) (compilation-speed 3) (debug 0))) (labels ((%f2 (f2-1 f2-2 &optional (f2-3 0) (f2-4 a)) 0)) (apply #'%f2 a (%f2 b (flet ((%f12 (f12-1 f12-2 f12-3 &optional &key (key1 0) (key2 0)) (%f2 0 0))) (reduce #'(lambda (lmv2 lmv1) (%f2 0 0 a)) (list 0 0 a 0 0 0 a) :end 7)) 0) nil)))) -7465 -3590953) 0) #| ;;; A bug was found in the compiler. Contact worm@arrakis.es. Broken at C::WT-MAKE-CLOSURE. |# (deftest misc.410 (funcall (compile nil '(lambda () (declare (optimize (safety 0) (space 1) (compilation-speed 0) (speed 2) (debug 0))) (let ((*s2* 0)) (declare (special *s2*)) (reduce #'(lambda (lmv1 lmv2) *s2*) (vector 0) :end 1 :start 0))))) 0) ;;; THROW: The catch CT2 is undefined. (deftest misc.411 (funcall (compile nil '(lambda () (declare (optimize (safety 2) (debug 0) (space 0) (compilation-speed 2) (speed 0))) (catch 'ct2 (values 0 (throw 'ct2 0))) 0))) 0) ;;; /tmp/eclDD7aumXi8.c: In function `LC3': ;;; /tmp/eclDD7aumXi8.c:9: `env0' undeclared (first use in this function) (deftest misc.412 (funcall (compile nil '(lambda (a b) (declare (type (integer -25409 1946) a)) (declare (type (integer -215956065 223815244) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 2) (space 3) (debug 2) (safety 1) (speed 3))) (complex (flet ((%f15 (f15-1 &optional &key (key1 0)) 0)) (reduce #'(lambda (lmv6 lmv1) (%f15 lmv1)) (list b 0))) 0))) -21802 -105983932) 0) ;;; Different resutls: #, 0 (deftest misc.413 (funcall (compile nil '(lambda (a b) (declare (type (integer -120206733 37762378) a)) (declare (type (integer 2777758072 5675328792) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 3) (space 3) (debug 3) (safety 0) (speed 1))) (labels ((%f8 (f8-1 f8-2 &optional &key (key1 0)) (let* ((v2 (ash f8-1 (min 63 a)))) 0))) (ignore-errors (logand (apply #'%f8 0 b nil) (unwind-protect 0 (ash (%f8 0 0) (min 48 (flet ((%f12 (f12-1 f12-2 &optional &key (key1 a) (key2 b) &allow-other-keys) 0)) b))))))))) -4794909 4095236669) 0) ;;; sbcl 0.8.14.28 ;;; Wrong value computed (deftest misc.414 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (space 3) (compilation-speed 3) (debug 3) (safety 1))) (if (setq c 2) (case (shiftf c 1) ((2) c) (t 0)) 0))) 0) 1) ;;; cmucl ;;; Sept. 2004 snapshot ;;; Wrong return value (deftest misc.415 (funcall #'(lambda (a c) (catch 'ct2 (flet ((%f17 (&optional x &key) (let* ((y (cons (dotimes (iv3 0)) 0))) a))) c))) :bad :good) :good) ;;; Wrong value (deftest misc.416 (funcall (compile nil '(lambda (b) (declare (type (integer 12052668 22838464) b)) (declare (ignorable a b c)) (declare (optimize (compilation-speed 3) (debug 2) (speed 1) (space 0) (safety 3))) (min (mask-field (byte 2 18) b) 89582))) 13891743) 0) ;;; Invalid number of arguments: 3 (deftest misc.417 (funcall (compile nil '(lambda (c) (declare (type (integer 995 22565094) c)) (declare (optimize (safety 2) (debug 1) (space 0) (compilation-speed 2) (speed 1))) (numerator (floor (numerator (deposit-field 0 (byte 0 0) c)))))) 17190042) 17190042) ;;; Invalid number of arguments: # (deftest misc.418 (funcall (compile nil '(lambda (a b c) (declare (type (integer 1670923021 2536883848) a)) (declare (ignorable a b c)) (declare (optimize (safety 3) (compilation-speed 3) (speed 1) (debug 1) (space 2))) (if (logior (setf c 67) 0 a) a 0))) 2161404325 -1968715305 83) 2161404325) ;;; nil is not of type c::continuation ;;; (c::convert-type-check # ;;; ((nil # #))) (deftest misc.419 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (speed 3) (compilation-speed 1) (space 1) (debug 2))) (boole boole-set 0 (case 2 ((0) 0) (t (numerator (catch 'ct2 0)))))))) -1) ;;; nil is not of type c::continuation ;;; (c::convert-type-check # ;;; ((nil # #))) (deftest misc.420 (funcall (compile nil '(lambda (a b) (declare (type (integer -65954801 6519292634236) a)) (declare (type (integer 5721249203 36508717226) b)) (declare (ignorable a b)) (declare (optimize (space 3) (compilation-speed 2) (safety 3) (speed 0) (debug 2))) (flet ((%f14 (f14-1 f14-2 &key) (prog2 0 f14-2 (min (catch 'ct4 (floor 120378948 (max 22 a))))))) (reduce #'(lambda (lmv6 lmv5) (%f14 0 0)) (vector 0 0 0) :start 0 :from-end t)))) 6313133774518 10840050742) 0) ;;; Invalid number of arguments: 1 (deftest misc.421 (funcall (compile nil '(lambda (a) (declare (optimize (debug 0) (space 2) (compilation-speed 1) (safety 0) (speed 0))) (imagpart (block b8 (logior (catch 'ct7 (return-from b8 a)) -1123785))))) -1021899) 0) ;;; Invalid number of arguments: 2 (deftest misc.422 (funcall (compile nil '(lambda (a) (declare (type (integer -13 -3) a)) (declare (optimize (space 2) (debug 1) (safety 1) (speed 2) (compilation-speed 1))) (logorc2 (sbit #*0010000011101010 (min 15 (max 0 0))) a))) -7) 6) ;;; nil is not of type c::continuation ;;; (c::convert-type-check # ;;; ((t # #))) (deftest misc.423 (funcall (compile nil '(lambda (a b) (declare (type (integer 0 1) a)) (declare (type (integer -8031148528 5509023941) b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 2) (safety 3) (debug 1) (compilation-speed 3) (speed 2))) (min 0 (ignore-errors (logand 0 b 388))))) 0 4604112015) 0) ;;; Argument x is not a real: nil. ;;; (kernel:two-arg-> nil 0) (deftest misc.424 (funcall (compile nil '(lambda (a b) (declare (type (integer -24 15) a)) (declare (type (integer -99661829155 16) b)) (declare (ignorable a b)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (debug 1) (compilation-speed 1) (space 3) (speed 3))) (catch 'ct4 (logandc1 a (ignore-errors (let* ((v8 (complex (throw 'ct4 0) 0))) 0)))))) -18 -47519360453) 0) ;;; Different results (deftest misc.425 (funcall (compile nil '(lambda (a b) (declare (type (integer -394128 80657) a)) (declare (type (integer 13729431 14852298) b)) (declare (optimize (space 2) (compilation-speed 1) (safety 0) (debug 0) (speed 2))) (logorc1 (* a (logior b 0)) 0))) -80334 14527920) 1167085925279) ;;; Unable to display error condition (deftest misc.426 (funcall (compile nil '(lambda () #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (safety 3) (space 3) (speed 3) (debug 1) (compilation-speed 3))) (dotimes (iv3 1 0) (logxor iv3 1285775))))) 0) ;;; sbcl 0.8.15.13 ;;; NIL is not of type REAL ;;; (This appears to be related to DYNAMIC-EXTENT) (deftest misc.427 (funcall (compile nil '(lambda (a) (declare (notinline list reduce logior)) (declare (optimize (safety 2) (compilation-speed 1) ; #+sbcl (sb-c:insert-step-conditions 0) (speed 3) (space 2) (debug 2))) (logior (let* ((v5 (reduce #'+ (list 0 a)))) (declare (dynamic-extent v5)) (1- v5))))) 17) 16) (deftest misc.428 (funcall (compile nil '(lambda () (declare (notinline -)) (declare (optimize (compilation-speed 0) (safety 1) (speed 0) (debug 2) (space 3))) (let ((v10 (catch 'ct2 1))) (declare (dynamic-extent v10)) (- v10))))) -1) (deftest misc.429 (funcall (compile nil '(lambda () (declare (optimize (safety 1) (debug 1) (space 2) (speed 2) (compilation-speed 1))) (let ((v8 (let ((*s3* 0)) *s3*))) (declare (dynamic-extent v8)) (logandc1 v8 28))))) 28) ;;; poplog 15.53 ;;; Excess type specifier(s) in THE special form (deftest misc.430 (unwind-protect 0 (the integer 1)) 0) ;;; Wrong return values: T, 0 (deftest misc.431 (funcall (compile nil '(lambda (a) (declare (notinline > *)) (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) 5445205692802) 5445205692802) ;;; Ste: stack empty (missing argument? missing result?) (deftest misc.432 (loop for x below 2 count (not (not (typep x t)))) 2) (deftest misc.433 (let ((a 1)) (if (not (/= a 0)) a 0)) 0) ;;; sbcl 0.8.16.13 ;;; # is not valid as the first argument to VOP: ;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED ;;; Primitive type: T ;;; SC restrictions: ;;; (SB-VM::UNSIGNED-REG) ;;; The primitive type disallows these loadable SCs: ;;; (SB-VM::UNSIGNED-REG) (deftest misc.434 (funcall (compile nil '(lambda (a b) (declare (type (integer -8431780939320 1571817471932) a)) (declare (type (integer -4085 0) b)) (declare (ignorable a b)) (declare (optimize (space 2) (compilation-speed 0) #+sbcl (sb-c:insert-step-conditions 0) (debug 2) (safety 0) (speed 3))) (let ((*s5* 0)) (dotimes (iv1 2 0) (let ((*s5* (elt '(1954479092053) (min 0 (max 0 (if (< iv1 iv1) (lognand iv1 (ash iv1 (min 53 iv1))) iv1)))))) 0))))) -7639589303599 -1368) 0) ;;; failed AVER: ;;; "(AND (EQ (CTRAN-KIND START) INSIDE-BLOCK) (NOT (BLOCK-DELETE-P BLOCK)))" (deftest misc.435 (funcall (compile nil '(lambda (a b c d) (declare (notinline aref logandc2 gcd make-array)) (declare (optimize (space 0) (safety 0) (compilation-speed 3) (speed 3) (debug 1) )) (progn (tagbody (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) (declare (dynamic-extent v2)) (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) tag2) 0))) 3021871717588 -866608 -2 -17194) 0) ;;; In sbcl 0.8.16.18 ;;; # is not valid as the first argument to VOP: ;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED ;;; Primitive type: T ;;; SC restrictions: ;;; (SB-VM::UNSIGNED-REG) ;;; The primitive type disallows these loadable SCs: ;;; (SB-VM::UNSIGNED-REG) (deftest misc.436 (funcall (compile nil '(lambda (a b) (declare (type (integer -2917822 2783884) a)) (declare (type (integer 0 160159) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 1) (speed 3) (safety 3) (space 0) ; #+sbcl (sb-c:insert-step-conditions 0) (debug 0))) (if (oddp (loop for lv1 below 2 count (logbitp 0 (1- (ash b (min 8 (count 0 '(-10197561 486 430631291 9674068)))))))) b 0))) 1265797 110757) 0) ;;; The value NIL is not of type INTEGER. ;;; (in (SB-C::TN-SC-OFFSET 1 #)) (deftest misc.437 (funcall (compile nil '(lambda (a b c d e) (declare (notinline values complex eql)) (declare (optimize (compilation-speed 3) (speed 3) ; #+sbcl (sb-c:insert-step-conditions 0) (debug 1) (safety 1) (space 0))) (flet ((%f10 (f10-1 f10-2 f10-3 &optional (f10-4 (ignore-errors 0)) (f10-5 0) &key &allow-other-keys) (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) 80043 74953652306 33658947 -63099937105 -27842393) 0) ;;; # is not valid as the second argument to VOP: ;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED ;;; Primitive type: T ;;; SC restrictions: ;;; (SB-VM::UNSIGNED-REG) ;;; The primitive type disallows these loadable SCs: ;;; (SB-VM::UNSIGNED-REG) (deftest misc.438 (funcall (compile nil ' (lambda (a) (declare (type (integer 0 1696) a)) ; (declare (ignorable a)) (declare (optimize (space 2) (debug 0) (safety 1) (compilation-speed 0) (speed 1))) (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) 805) 0) ;;; "The value -13589 is not of type (INTEGER -15205 18871)" (deftest misc.439 (funcall (compile nil '(lambda (a) (declare (type (integer -15205 18871) a)) (declare (ignorable a)) (declare (optimize (space 2) ; (sb-c:insert-step-conditions 0) (speed 1) (safety 1) (debug 1) (compilation-speed 3))) (if (<= a (- (setf a 10305))) a 0))) -13589) 10305) ;;; In ACL 7.0 (sparc, Solaris 8, 11 Nov 2004) ;;; Error: the value of (CAR EXCL::INTEGERS) is NIL, which is not of type INTEGER. (deftest misc.440 (funcall (compile nil '(lambda (a b c) (declare (notinline logior)) (declare (optimize (safety 3) (debug 1) (speed 0) (space 1) (compilation-speed 3))) (flet ((%f10 (&optional &key (key1 (logior (flet ((%f4 (f4-1 &optional &key (key1 0) (key2 b) &allow-other-keys) c)) (%f4 0)))) &allow-other-keys) 0)) (let ((*s8* (%f10))) (declare (special *s8*)) *s8*)))) 13524 4484529434427 8109510572804) 0) ;;; Error: the value of realpart is nil, which is not of type (or rational float). (deftest misc.441 (funcall (compile nil '(lambda (a b) (declare (notinline complex)) (declare (optimize (compilation-speed 1) (space 1) (speed 3) (safety 2) (debug 3))) (flet ((%f8 (f8-1 f8-2 &optional &key (key1 (labels ((%f9 nil a)) (complex (%f9) 0))) (key2 0) &allow-other-keys) 0)) (%f8 0 a)))) 1 2) 0) ;;; Error: the value of excl::x is nil, which is not of type integer. (deftest misc.442 (funcall (compile nil '(lambda (a b) (declare (notinline apply evenp)) (declare (optimize (speed 1) (space 1) (safety 1) (compilation-speed 0) (debug 0))) (labels ((%f18 (f18-1 &optional &key (key1 (flet ((%f8 nil b)) (if (evenp (%f8)) 0 a))) (key2 0)) 0)) (apply #'%f18 b nil)))) 505808341634 -39752189) 0) ;;; Error: No from-creg to move to <3:iparam2@(:iparam 2){4=c{s:<3>}}> before (move-throw-tag nil nil -> ({18}) ([18>>:frame :dfr])) (deftest misc.443 (funcall (compile nil '(lambda (a b c d e) (declare (type (integer -2310674 2) a)) (declare (type (integer -492505702625 -147091001460) b)) (declare (type (integer -27638568 52971156) c)) (declare (type (integer -151 203) d)) (declare (type (integer -1400301 8173230) e)) (declare (ignorable a b c d e)) (declare (optimize (compilation-speed 3) (debug 0) (space 0) (safety 1) (speed 1))) (catch 'ct7 (lcm (case 0 ((-4557) (let ((*s7* (max d))) 0)) ((-15387) c) (t 0)) (unwind-protect (throw 'ct7 b) 0))))) -1748290 -244489705763 38969920 -90 341977) -244489705763) ;;; misc.444 ;;; misc.445 ;;; gcl 25 Nov 2004 ;;; Incorrect return value (deftest misc.446 (funcall (compile nil '(lambda (a b c d) (declare (type (integer -1254 1868060) a)) (declare (type (integer -1 0) b)) (declare (type (integer -424707253248 -82453721088) c)) (declare (type (integer -252962 3018671) d)) (declare (ignorable a b c d)) (declare (optimize (safety 3) (space 3) (speed 3) (compilation-speed 3) (debug 3))) (* (labels ((%f8 (&optional (f8-1 0)) (setq b 0))) (if (> d 1668249724 (%f8)) 0 (complex a 0))) (if (oddp b) 0 c)))) 796131 -1 -338008808923 530637) -269099291056676913) (deftest misc.447 (funcall (compile nil '(lambda (a) (declare (type (integer 38632397 46632460288) a)) (declare (optimize (space 0) (safety 0) (debug 1) (compilation-speed 1) (speed 0))) (catch 'ct2 (if (= a 0 (throw 'ct2 0)) 1 2289596)))) 18160383912) 0) (deftest misc.448 (funcall (compile nil '(lambda (a b) (declare (type (integer -3716 1269) a)) (declare (type (integer -1976579 2312) b)) (declare (optimize (compilation-speed 1) (safety 0) (speed 0) (space 0) (debug 3))) (if (<= 0 b (setq a 117)) 0 a))) -1147 -44004) 117) ;;; gcl 27 Nov 2004 ;;; Incorrect return value (deftest misc.449 (funcall (compile nil '(lambda (a) (* 10 a (setq a 1000)))) 1) 10000) ;;; Error in COMPILER::CMP-ANON [or a callee]: The variable MIN is unbound. (deftest misc.450 (funcall (compile nil '(lambda (a b) (min 0 (reduce #'min (vector a b 0)) 0))) -10 -1) -10) ;;; gcl 28 Nov 2004 ;;; Incorrect return value (deftest misc.451 (funcall (compile nil '(lambda (a b) (flet ((%f3 () (setq a -2210))) (logxor a b (%f3))))) -22650 20595) 171) (deftest misc.452 (funcall (compile nil '(lambda (d) (labels ((%f3 () (setf d -1135) -983)) (+ d (%f3) 11267)))) -2914) 7370) (deftest misc.453 (funcall (compile nil '(lambda (a) (* a (setf a 2) a (identity 5)))) 3) 60) (deftest misc.454 (let* ((form '(let ((v1 0)) (decf v1 (setq v1 -1)))) (val1 (eval form)) (val2 (funcall (compile nil `(lambda () ,form))))) (if (eql val1 val2) :good (list val1 val2))) :good) ;;; sbcl 0.8.17.24 ;;; Bugs in the just-introduced fixnum arithmetic transforms ;;; LOGAND (?) bug (deftest misc.455 (funcall (compile nil '(lambda (a b) (declare (type (integer -4079701634499 2272876436845) b)) (declare (optimize (space 0) (compilation-speed 1) (safety 3) (speed 2) (debug 0))) (logand (* -775 b) a 37284))) -18465060867 832909434173) 32772) (deftest misc.456 (funcall (compile nil '(lambda (b c) (declare (type (integer -30606350847 35078064098) b)) (declare (type (integer -6652 6638) c)) (declare (optimize (space 3) (safety 0) (speed 0) (compilation-speed 2) (debug 1))) (logand (* -9964236 (setq c 6206) 2600) b c))) 17296668225 -6574) 4096) ;;; DEPOSIT-FIELD (?) bug (deftest misc.457 (funcall (compile nil '(lambda (a b) (declare (type (integer -455461 343063) a)) (declare (type (integer -1020097 -12430) b)) (declare (optimize (speed 3) (space 0) (compilation-speed 3) (debug 0) (safety 3))) (deposit-field (* (logeqv a a) b) (byte 6 24) 0))) -212811 -985078) 0) ;;; LDB, * (deftest misc.458 (funcall (compile nil ' (lambda (a) (declare (type (integer -8175 27760966190) a)) (declare (optimize ;; The next optimize declaration is necessary ;; for the bug to occur in sbcl 0.8.17.24 #+sbcl (sb-c:insert-step-conditions 0) (space 2) (speed 0) (compilation-speed 1) (safety 0) (debug 3))) (ldb (byte 29 0) (* a a)))) 14774118941) 101418825) ;;; LOGAND, + (deftest misc.459 (funcall (compile nil '(lambda (a b) (declare (type (integer -32933298905 -168011) a)) (declare (type (integer -190015111797 16) b)) (declare (optimize (speed 2) (compilation-speed 0) (space 0) (safety 1) (debug 0))) (logand (+ b -9255) a 63))) -8166030199 -45872222127) 8) ;;; In sbcl 0.8.17.28-signed-modular-arithmetic.3 ;;; Unreachable code is found or flow graph is not properly depth-first ordered. ;;; (This is apparently a different bug from the previous ones that ;;; were causing this message to be printed.) (deftest misc.460 (funcall (compile nil '(lambda (a) (declare (type (integer 50354997 50514623) a)) (declare (ignorable a)) (declare (optimize (speed 0) (safety 0) (compilation-speed 3) #+sbcl (sb-c:insert-step-conditions 0) (debug 1) (space 1))) (loop for lv3 below 2 sum (if (find 0 '(-17604051 126613572 -795198 12037855 127043241 -2 -59 -3458890 1505 -1 -2 107498637 -977489 172087 421813 543299114 12 4311490 569 -3509 -4051770 -1 1 1 216399387 -2482 143297 2 304550 -61 -195904988 57682175 2344 1294831 -247 -2 25779388 -296 -12115 -158487 -15) :test 'eql) (if (find 0 #(4193594) :test '<) (min (catch 'ct6 0) (catch 'ct8 0) 0) (let ((*s1* (cons a 0))) (car *s1*))) 0)))) 50395193) 0) ;;; gcl 16 Dec 2004 ;;; Error possibly related to type propagation (deftest misc.461 (funcall (compile nil '(lambda (a) (declare (type (integer -26657952320 0) a)) (declare (optimize (compilation-speed 0) (space 3) (speed 3) (safety 0) (debug 2))) (- a (ash -1 (min 31 (- a))) -26715477))) -26179151369) -24004952244) ;;; gcl 18 Dec 2004 ;;; Doesn't cause an error, unless -Werror is added to gcc flags ;;; gazonk0.c: In function `L1': ;;; gazonk0.c:5257: warning: assignment makes integer from pointer without a cast (deftest misc.462 (funcall (compile nil '(lambda (a b) (declare (type (integer -2726808666112 -26532) a)) (declare (type (integer 182701814 171137312256) b)) (declare (ignorable a b)) (declare (optimize (compilation-speed 3) (safety 0) (speed 3) (space 3) (debug 3))) (ash (let* ((v8 (cons 0 0))) 0) (min 15 a)))) -1982565461868 46279989780) 0) ;;; gazonk0.c: In function `L1': ;;; gazonk0.c:5262: warning: assignment makes integer from pointer without a cast (deftest misc.463 (funcall (compile nil '(lambda (a b) (declare (type (integer 0 0) a)) (declare (type (integer -160364747008 264742845184) b)) (declare (ignorable a b)) (declare (optimize (debug 0) (safety 0) (compilation-speed 2) (space 0) (speed 1))) (ash (multiple-value-setq (a) 0) (min 97 13027666096)))) 0 34670845086) 0) ;;; gcl 21 Dec 2004 ;;; Compiler error on ash, rem (deftest misc.464 (funcall (compile nil '(lambda () (declare (optimize (debug 1) (safety 2) (compilation-speed 0) (space 1) (speed 1))) (count (ash (the integer (macrolet () (rem -197 (min -72 215)))) (min 98 442719)) #(0 96) :test '=)))) 0) (deftest misc.465 (funcall (compile nil '(lambda (a) (declare (type (integer -18822 -1280) a)) (declare (optimize (debug 0) (speed 1) (compilation-speed 3) (safety 0) (space 0))) (ash (the integer (logand a (if t a (imagpart -2607360)))) (min 79 (catch 'ct7 0))))) -17635) -17635) ;;; ACL 6.2 (x86 linux) ;;; Bug in type propagation for ISQRT ;;; Found with the special purpose random tester for type propagation ;;; While compiling (:ANONYMOUS-LAMBDA 22203): ;;; Error: -1 is illegal argument to isqrt (deftest misc.466 (funcall (compile nil '(lambda (x) (declare (type (member 4 -1) x) (optimize speed (safety 1))) (isqrt x))) 4) 2) ;;; gcl 24 Dec 2004 ;;; Incorrect results (these may all be related) ;;; These are also produced by the special purpose tester in random-type-prop.lsp (deftest misc.467 (funcall (compile nil '(lambda (p2 p3) (declare (optimize speed (safety 1)) (type (integer -990888631320) p2) (type (integer -20346 -19755) p3)) (+ -77 (the (integer * -990888630255) p2) p3))) -990888630272 -19756) -990888650105) (deftest misc.468 (funcall (compile nil '(lambda (p2 p3) (declare (optimize speed (safety 1)) (type (integer * 151075404030) p2) (type (integer 6515518 *) p3)) (- 12967657127936 (the (eql 151075403520) p2) (the (member 6515658 -14) p3)))) 151075403520 6515658) 12816575208758) (deftest misc.469 (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type integer p2)) (+ 30926 (the (integer -4025987543018 *) p2)))) -4025817763840) -4025817732914) (deftest misc.470 (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type (integer 3689224658939 *) p2)) (+ -1071 (the (integer * 3689229115390) p2)))) 3689228853248) 3689228852177) (deftest misc.471 (funcall (compile nil '(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (integer -9024844 230253450) p1) (type (eql 35716681856) p2)) (* p1 (the (integer * 35716681856) p2)))) -9024809 35716681856) -322336231864165504) (deftest misc.472 (funcall (compile nil '(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (integer -785238 -80) p1) (type (eql -523213622272) p2)) (min p1 (the integer p2)))) -259 -523213622272) -523213622272) (deftest misc.473 (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type (integer * 65861934352) p2)) (max 23939 (the (integer 64863825609 65878336765) p2)))) 65861912512) 65861912512) (deftest misc.474 (funcall (compile nil '(lambda (p1) (declare (optimize speed (safety 1)) (type (integer -6750156308) p1)) (logand (the signed-byte p1) -540165229))) -6750156304) -7289140848) ;;; abcl 25 Dec 2005 ;;; Debugger invoked on condition of type UNDEFINED-FUNCTION: ;;; The function %FAILED-AVER is undefined. (deftest misc.475 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p1 p2 p3 p4 p6) (declare (optimize speed (safety 1)) (type (integer -785238 61564048) p1) (type (integer * 65861934352) p2)) (+ P1 (THE (INTEGER -485480 -7019) P2) P3 P4 463666373060 P6))) 61564048 -7457 24939545512 51 730)) 488667475944) (deftest misc.476 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p4) (declare (optimize speed (safety 1)) (type (integer -115781893486) p4)) (- 1 -35 0 (the (integer -115778245122) p4) -2))) -115778114900)) 115778114938) (deftest misc.477 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p4 p5) (declare (optimize speed (safety 1)) (type (integer -126908726190 -126906628448) p4) (type (integer * 2202) p5)) (* -1950 -33610502463 2 p4 p5))) -126906629040 1839)) -30591843552678654213361992000) (deftest misc.478 (let #+armedbear ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (p2) (declare (optimize speed (safety 1)) (type (integer * 2343679) p2)) (logand 12050257282405 p2 117775123 505354693 -415679150084))) -6189)) 33816832) ;;; Bug in CMUCL Snapshot 2004-10 ;;; Invalid number of arguments: 370632372 (deftest misc.479 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type integer p2)) (setf (aref r) (logxor 0 (the (integer 2797513123 2798027357) p2))) (values))))) (funcall fn r 2797674503) (aref r)) 2797674503) (deftest misc.480 (let ((r (make-array nil :element-type 'integer)) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array integer nil) r) (type (integer -797971 -797511) p1)) (setf (aref r) (logeqv p1 15 1078254884158 -12564176924 0 15096591909)) (values))))) (funcall fn r -797965) (aref r)) -1075415510532) (deftest misc.481 (let ((r (make-array nil :element-type '(unsigned-byte 16))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 16) nil) r) (type (member 4194309 -123 1692 -4432 -760653 -1741 37) p1)) (setf (aref r) (logorc1 (the (eql -4432) p1) 0)) (values))))) (funcall fn r -4432) (aref r)) 4431) ;; Various incorrect results (deftest misc.482 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (eql -4) p2)) (setf (aref r) (logorc2 13 p2)) (values))))) (funcall fn r -4) (aref r)) 15) (deftest misc.483 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p1 p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (integer * 28306533) p1) (type (integer * 1245601) p2)) (setf (aref r) (logandc1 p1 (the (integer -3308174) p2))) (values))))) (funcall fn r -519 -28180) (aref r)) 4) (deftest misc.484 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (member 260646 -348969 34359738370 -110167) p2)) (setf (aref r) (logandc2 9 (the (eql -348969) p2))) (values))))) (funcall fn r -348969) (aref r)) 8) (deftest misc.485 (let ((r (make-array nil :element-type 'bit)) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array bit nil) r) (type (integer -108220 256178) p2)) (setf (aref r) (logand 1 (the (member -1 2147483652 1 -5 3802) p2))) (values))))) (funcall fn r -5) (aref r)) 1) (deftest misc.486 (let ((r (make-array nil :element-type '(unsigned-byte 4))) (fn (compile nil '(lambda (r p1 p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 4) nil) r) (type (integer -9) p1) (type (integer * 1234117) p2)) (setf (aref r) (logior (the (integer -295 *) p1) (the (integer -90 *) p2))) (values))))) (funcall fn r 6 6) (aref r)) 6) (deftest misc.487 (let ((r (make-array nil :element-type '(unsigned-byte 16))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 16) nil) r) (type (integer 1583040351 1587341394) p1)) (setf (aref r) (logandc2 (the (integer 1587211196 1587341392) p1) -166174)) (values))))) (funcall fn r 1587341392) (aref r)) 34832) (deftest misc.488 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type (integer 1960409798 1960426181) p2)) (setf (aref r) (logorc1 -1 p2)) (values))))) (funcall fn r 1960409801) (aref r)) 1960409801) (deftest misc.489 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type (integer -55) p2)) (setf (aref r) (logorc2 0 (the (member -51) p2))) (values))))) (funcall fn r -51) (aref r)) 50) (deftest misc.490 (let ((r (make-array nil :element-type '(unsigned-byte 32))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (unsigned-byte 32) nil) r) (type (integer 761639858 1030075825) p1)) (setf (aref r) (logior (the (integer * 35389813668) p1) 0)) (values))))) (funcall fn r 1030075308) (aref r)) 1030075308) (deftest misc.491 (let ((r (make-array nil :element-type '(signed-byte 16))) (fn (compile nil '(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array (signed-byte 16) nil) r) (type (integer 505774114 573717424) p2)) (setf (aref r) (lognand 58539 (the (integer * 910674467) p2))) (values))))) (funcall fn r 506608551) (aref r)) -8356) (deftest misc.492 (let ((r (make-array nil :element-type '(signed-byte 8))) (fn (compile nil '(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array (signed-byte 8) nil) r) (type (integer * 22050378) p1)) (setf (aref r) (lognand (the (integer 19464371) p1) 2257)) (values))))) (funcall fn r 19469591) (aref r)) -18) ;;; ABCL (25 Dec 2004) ;;; Class verification failed: (class: org/armedbear/lisp/out, method: execute signature: (Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;) Expecting to find integer on stack (deftest misc.493 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (b) (declare (optimize (speed 2) (debug 1) (safety 3) (compilation-speed 3) (space 1))) (aref #(41397376227 18660605846 49244777443) (min 2 (max 0 b))))) -71)) 41397376227) ;;; ABCL (26 Dec 2004) ;;; Class verification failed: [...] Illegal exception table range (deftest misc.494 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda () (declare (optimize (safety 0) (space 2) (debug 3) (speed 0) (compilation-speed 2))) (conjugate (progn (catch 'ct5 (if t 0 0)) 0)))))) 0) ;;; The value 5085 is not of type FUNCTION. (deftest misc.495 (funcall (compile nil '(lambda (a b) (declare (type (integer -4197 284380207) a)) (declare (type (integer -23 5088) b)) (declare (ignorable a b)) (declare (optimize (speed 1) (space 2) (debug 0) (compilation-speed 0) (safety 2))) (if (position (progn (1+ b) 0) '(169496 -726 -13623 53307916 128 -258391 156 7432659 30 20 -11)) 0 a))) 72179019 5084) 72179019) ;;; Inconsistent stack height 1 != 2 (deftest misc.496 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -54915 -3396) a)) (declare (optimize (debug 3) (space 0) (safety 2) (speed 2) (compilation-speed 3))) (progn (1+ a) (catch 'ct6 (progn 0))))) -25986)) 0) (deftest misc.497 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (b) (declare (type (integer -1 0) b)) (declare (optimize (space 3) (compilation-speed 1) (safety 0) (debug 1) (speed 0))) (if 0 (prog2 0 0 (1+ b)) 0))) 0)) 0) ;;; Inconsistent stack height 1 != 0 (deftest misc.498 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -16191 4) a)) (declare (optimize (compilation-speed 2) (space 1) (debug 0) (safety 0) (speed 2))) (conjugate (dotimes (iv1 0 0) (let ((v2 (dotimes (iv3 0 0) (1+ a)))) 0))))) -2840)) 0) ;;; Incompatible object argument for function call (deftest misc.499 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a b) (declare (type (integer -31415 133871) a)) (declare (type (integer -993 6448) b)) (declare (ignorable a b)) (declare (optimize (space 0) (debug 2) (safety 0) (speed 0) (compilation-speed 0))) (progn (ceiling (progn (1+ b) a)) a))) -16435 2620)) -16435) ;;; Stack overflow during compilation (deftest misc.500 (funcall (compile nil '(lambda nil (declare (optimize (space 2) (debug 2) (compilation-speed 2) (speed 1) (safety 3))) (the integer (integer-length (dotimes (iv4 2 15790955))))))) 24) ;;; Inconsistent stack height 1 != 0 (deftest misc.501 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -437165353 179983908) a)) (declare (optimize (compilation-speed 0) (debug 1) (space 1) (safety 2) (speed 1))) (dotimes (iv1 0 0) (1+ a)))) 1)) 0) ;;; Ordering problems (deftest misc.502 (funcall (compile nil '(lambda (a) (declare (type (integer -7 84717795) a)) (declare (ignorable a)) (declare (optimize (speed 1) (space 1) (debug 1) (safety 2) (compilation-speed 0))) (+ a (setq a 35035201)))) 29207264) 64242465) ;;; ABCL 27 Dec 2004 ;;; Different results (deftest misc.503 (funcall (compile nil '(lambda (a) (declare (optimize (space 3) (debug 1) (speed 2) (safety 0) (compilation-speed 1))) (catch 'ct1 (throw 'ct1 (catch 'ct5 (reduce 'min (vector 0 0 0 a a 0 0 (values 0 0) (throw 'ct5 -6)) :end 8 :start 6 :from-end t)))))) 17) -6) ;;; Inconsistent stack height (deftest misc.504 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 196060 241373941) a)) (declare (ignorable a)) (declare (optimize (speed 3) (debug 0) (safety 2) (compilation-speed 3) (space 2))) (prog2 (if 0 (+ a a) 0) 0))) 200000)) 0) (deftest misc.505 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -6 5) a)) (declare (optimize (speed 3) (space 0) (safety 2) (compilation-speed 2) (debug 3))) (dotimes (iv1 0 0) (+ a a)))) 1)) 0) (deftest misc.506 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -53 49) a)) (declare (optimize (debug 0) (compilation-speed 1) (space 2) (safety 0) (speed 0))) (unwind-protect (+ a a) 0))) -38)) -76) ;;; The value 15390 is not of type FUNCTION. (deftest misc.507 (funcall (compile nil '(lambda (a) (declare (type (integer 2697 13005) a)) (declare (optimize (debug 0) (space 2) (speed 2) (compilation-speed 3) (safety 3))) (truncate (prog1 0 a (+ a a))))) 7695) 0 0) ;;; COMPILE-FORM: unsupported special operator LET* ;;; Associated with 'THE' operator (deftest misc.508 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -57853147 -2) a)) (declare (ignorable a)) (declare (optimize (debug 2) (space 1) (compilation-speed 3) (safety 1) (speed 2))) (the integer (mask-field (byte 2 29) (ash (multiple-value-setq (a) -51781613) (min 1 a)))))) -29324754)) 1610612736) (deftest misc.509 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -38984312 657) a)) (declare (ignorable a)) (declare (optimize (debug 1) (compilation-speed 1) (speed 1) (safety 2) (space 3))) (the integer (if (> a -27907941364) 116871 (cl:handler-case (multiple-value-setq (a) -34832621)))))) -26788929)) 116871) (deftest misc.510 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -2827 3400) a)) (declare (optimize (compilation-speed 1) (space 3) (debug 1) (safety 0) (speed 1))) (logand (the integer (dotimes (iv4 2 a) (progn iv4)))))) 155)) 155) (deftest misc.511 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 18967 23584) a)) (declare (ignorable a)) (declare (optimize (space 1) (speed 1) (debug 1) (compilation-speed 3) (safety 1))) (the integer (values (loop for lv4 below 2 count (find a '(16389))))))) 21352)) 0) ;;; Inconsistent stack height (deftest misc.512 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer 1 188902468) a)) (declare (ignorable a)) (declare (optimize (space 2) (speed 3) (safety 3) (compilation-speed 0) (debug 2))) (catch 'ct6 (the integer (let* ((v3 (signum (ignore-errors a)))) (declare (dynamic-extent v3)) (throw 'ct6 (round (case (prog2 (lognor 290171664 v3) -3512003993 -550842867) ((4) (* 1 4092)) ((21 220 225) (block b1 (setf v3 (let* ((v9 v3)) a)))) (t -639367819))))))))) 49008586)) -639367819 0) ;;; COMPILE-FORM: unsupported special operator LET* ;;; Associated with 'THE' operator (deftest misc.513 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -2 75025568) a)) (declare (ignorable a)) (declare (optimize (space 0) (compilation-speed 0) (safety 0) (speed 2) (debug 2))) (let* ((v8 (cons (the integer (prog2 a -1558460 a (ignore-errors (progn (tagbody) -49510826)) a)) 0))) 0))) 68043554)) 0) (deftest misc.514 (let #+abcl ((jvm::*catch-errors* nil)) nil (funcall (compile nil '(lambda (a) (declare (type (integer -6844832476 188341751) a)) (declare (optimize (speed 3) (debug 1) (safety 0) (space 3) (compilation-speed 1))) (the integer (multiple-value-setq (a) -96073358)))) -3792864899)) -96073358) ;;; gcl 27 Dec 2004 ;;; Issue with dynamic extent (deftest misc.515 (funcall (compile nil '(lambda (a) (declare (type (integer -1337016312 832159784) a)) (declare (optimize speed (safety 1))) (let* ((y 0) (v9 0)) (declare (dynamic-extent v9)) (setq v9 (+ a a)) (setq y (1+ v9))))) -1209913207) -2419826413) (deftest misc.516 (funcall (compile nil '(lambda () (declare (optimize (space 0) (debug 0) (safety 2) (compilation-speed 3) (speed 1))) (let ((*s2* (* -507991378 14))) (declare (dynamic-extent *s2*)) (declare (special *s2*)) (1+ *s2*))))) -7111879291) ;;; gcl 29 Dec 2004 ;;; Interference of special variable bindings? (deftest misc.517 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (space 3) (debug 1) (speed 1) (compilation-speed 0))) (let* ((*s8* (let ((*s8* (make-array nil :initial-element 0))) (declare (special *s8*)) (progn (shiftf (aref *s8*) 31508066) 0)) )) (declare (special *s8*)) 0)))) 0) ;;; Incorrect return value (deftest misc.518 (funcall (compile nil '(lambda () (declare (optimize (compilation-speed 0) (safety 1) (debug 1) (space 0) (speed 3))) (flet ((%f10 (&optional (f10-1 0) (f10-2 0) &key) (progn (tagbody (decf f10-2) (return-from %f10 (complex (unwind-protect (go tag7)) 0)) tag7) f10-2))) (if (evenp (%f10 0 0)) 0 2140390))))) 2140390) ;;; Error in APPLY [or a callee]: fixnum or bignum expected ;;; Broken at COMPILER::CMP-ANON. (deftest misc.519 (funcall (compile nil '(lambda () (declare (optimize (compilation-speed 0) (speed 1) (debug 1) (space 1) (safety 3))) (let ((*s3* (* (the integer (expt (rationalize (multiple-value-bind (*s3*) (make-array nil :initial-element 0) (shiftf (aref *s3*) 0))) 2))))) 1)))) 1) ;;; sbcl 0.8.18 (sparc solaris) ;;; identity ASH not transformed away (deftest misc.520 (funcall (compile nil '(lambda (a c e) (declare (type (integer -44330 64753) c)) (declare (type (integer -301534047 4291509) e)) (declare (optimize (safety 3) (debug 2) (speed 3) (space 2) (compilation-speed 2))) (if (oddp (ash (logorc2 c e) (min 2 (mask-field (byte 0 0) (mod 0 (max 69 0)))))) a 0))) 1 -8156 -229264929) 0) ;;; ecl (25 Jan 2005) ;;; Error: In a call to AREF, the type of the form *S6* is FIXNUM, not (ARRAY *). (deftest misc.521 (funcall (compile nil '(lambda (b) (declare (optimize (speed 0) (safety 1) (debug 1) (compilation-speed 3) (space 0))) (if b (let ((*s6* 0)) 0) (let* ((*s6* (make-array nil :initial-element 0))) (aref *s6*))))) nil) 0) ;;; nil is not of type number. (deftest misc.522 (funcall (compile nil '(lambda (a) (declare (type (integer -25 38) a)) (declare (optimize (compilation-speed 3) (safety 3) (debug 1) (space 2) (speed 1))) (flet ((%f2 (f2-1 f2-2 &optional (f2-3 (labels ((%f6 (&optional (f6-1 0) (f6-2 0)) (max a))) (%f6 0))) (f2-4 0) (f2-5 0)) (flet ((%f4 (f4-1 f4-2 f4-3) (flet ((%f15 () f2-3)) a))) 0))) (reduce #'(lambda (lmv1 lmv6) a) (vector 0 0 0 (%f2 a a) 0 a 0 a 0) :start 4 :from-end t)))) 35) 35) ;;; Incorrect return value (deftest misc.523 (funcall (compile nil '(lambda (a) (declare (type (integer -1011 978) a)) (declare (optimize (compilation-speed 1) (safety 3) (debug 0) (speed 2) (space 1))) (let ((*s5* (cons 0 (catch 'ct8 (ash (flet ((%f15 (f15-1) (return-from %f15 a))) 0) (min 57 (lognor (throw 'ct8 (shiftf a 332)) (let ((v1 (setf a 371))) a)))))))) a))) 99) 332) ;;; Seg fault (deftest misc.524 (funcall (compile nil '(lambda (a b) (declare (type (integer -2432551 871) a)) (declare (type (integer -6390 -1) b)) (declare (ignorable b)) (declare (optimize (compilation-speed 0) (safety 0) (space 2) (speed 0) (debug 3))) (flet ((%f18 (f18-1 f18-2 f18-3 &optional &key (key1 0) &allow-other-keys) (labels ((%f12 (f12-1 &optional (f12-2 0) &key (key1 (catch 'ct7 (conjugate key1))) (key2 0) &allow-other-keys) 0)) (%f12 a)))) (%f18 a 0 0)))) -925293 -1603) 0) ;;; Internal error: tried to advance stack. (deftest misc.525 (funcall (compile nil '(lambda (a) (declare (type (integer -17179869184 -2147483648) a)) (declare (ignorable a)) (declare (optimize (space 2) (debug 3) (speed 3) (compilation-speed 3) (safety 1))) (catch 'ct4 (max (conjugate (unwind-protect 0 (catch 'ct4 (values 0)))) (throw 'ct4 0))))) -17179869184) 0) ;;; integer does not specify a sequence type (deftest misc.526 (funcall (compile nil '(lambda (a) (declare (type (integer -4 3025867) a)) (declare (ignorable a)) (declare (optimize (space 1) (safety 0) (debug 0) (speed 3) (compilation-speed 0))) (flet ((%f14 (f14-1 f14-2 f14-3 &key) (let ((v4 (return-from %f14 (flet ((%f11 (&optional (f11-1 0) (f11-2 0) (f11-3 (coerce (reduce (function (lambda (lmv2 lmv5) a)) (vector f14-1 f14-1 0 f14-3 a f14-3 a f14-1 0 f14-2)) (quote integer))) &key (key1 f14-3) (key2 a)) (flet ((%f8 (f8-1 &optional (f8-2 (flet ((%f16 (f16-1 f16-2 f16-3 &optional &key (key1 0) (key2 f11-3)) key1)) 0)) &key (key1 0)) f14-3)) 0))) (if (%f11 f14-1 (%f11 0 f14-3) f14-1) 0 0))))) 0))) (%f14 0 a a)))) 857304) 0) ;;; sbcl 0.8.19.32 ;;; Type propagation problem with BIT-AND (deftest misc.527 (let ((v1 (make-array 1 :element-type 'bit :initial-contents '(1) :fill-pointer 0)) (v2 (make-array 1 :element-type 'bit :initial-contents '(1) :fill-pointer 1)) (r (make-array nil))) (funcall (compile nil `(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type (array *) p2)) (setf (aref r) (bit-and ,v1 (the (bit-vector *) p2))) (values))) r v2) (let ((result (aref r))) (values (notnot (simple-bit-vector-p result)) (=t (array-dimension result 0) 1) (=t (aref result 0) 1)))) t t t) ;;; The value 22717067 is not of type (INTEGER 22717067 22717067) (deftest misc.528 (let* ((x 296.3066f0) (y 22717067) (form `(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array single-float nil) r) (type (integer -9369756340 22717335) p2)) (setf (aref r) (* ,x (the (eql 22717067) p2))) (values))) (r (make-array nil :element-type 'single-float)) (expected (* x y))) (funcall (compile nil form) r y) (let ((actual (aref r))) (unless (eql expected actual) (list expected actual)))) nil) ;;; The value 46790178 is not of type (INTEGER 46790178 46790178). (deftest misc.529 (let* ((x -2367.3296f0) (y 46790178) (form `(lambda (r p2) (declare (optimize speed (safety 1)) (type (simple-array single-float nil) r) (type (eql 46790178) p2)) (setf (aref r) (+ ,x (the (integer 45893897) p2))) (values))) (r (make-array nil :element-type 'single-float)) (expected (+ x y))) (funcall (compile nil form) r y) (let ((actual (aref r))) (unless (eql expected actual) (list expected actual)))) nil) ;;; cmucl (Jan 2005 snapshot) ;;; Segmentation fault (deftest misc.530 (let* ((v (make-array '(11) :element-type 'double-float :initial-contents '(56826.586316245484d0 -57680.53641925701d0 68651.27735979737d0 30934.627728043164d0 47252.736017400945d0 35129.46986219467d0 -57804.412938803005d0 13000.374416975968d0 50263.681826551256d0 89386.08276072948d0 -89508.77479231959d0))) (form `(lambda (r) (declare (optimize speed (safety 1)) (type (simple-array t nil) r)) (setf (aref r) (array-has-fill-pointer-p ,v)))) (r (make-array nil))) (funcall (compile nil form) r) (eqlt (aref r) (array-has-fill-pointer-p v))) t) ;;; gcl ;;; Problem with 0-dim char arrays ;;; Produces wrong return value (#\\320). (deftest misc.532 (let ((r (make-array nil :element-type 'base-char))) (funcall (compile nil '(lambda (r c) (declare (optimize speed (safety 1)) (type (simple-array base-char nil) r) (type base-char c)) (setf (aref r) c) (values))) r #\Z) (aref r)) #\Z) ;;; sbcl 0.8.19.32 ;;; Bound is not *, a INTEGER or a list of a INTEGER: -51494/29889 (deftest misc.533 (let* ((r (make-array nil)) (c #c(208 -51494/29889)) (form `(lambda (r p1) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type number p1)) (setf (aref r) (+ (the (eql ,c) p1) -319284)) (values))) (fn (compile nil form))) (funcall fn r c) (eqlt (aref r) (+ -319284 c))) t) ;;; sbcl 0.8.19.35 ;;; Incorrect return value from conditional (deftest misc.534 (let ((r0 (make-array nil))) (funcall (compile nil '(lambda (r p1 p2 p3) (declare (optimize speed (safety 1)) (type (eql 4134713351/6105637898) p2) (type (eql 2685) p3)) (setf (aref r) (if p1 (the (eql 4134713351/6105637898) p2) (the (integer * 8391301) p3))))) r0 t 4134713351/6105637898 2685) (aref r0)) 4134713351/6105637898) #| The value # :ASSERTED-TYPE # :TYPE-TO-CHECK # {DECFF19}> is not of type SB-C::REF. |# (deftest misc.535 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0))) (funcall (compile nil `(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type (eql ,c0) p1) (type number p2)) (eql (the (complex double-float) p1) p2))) c0 #c(12 612/979))) nil) ;;; Similar to misc.535 (deftest misc.536 (funcall (compile nil '(lambda (p1 p2) (declare (optimize speed (safety 1)) (type (eql #c(11963908204 1/6)) p1) (type (complex rational) p2)) (eql p1 (the complex p2)))) #c(11963908204 1/6) #c(2343315619 5252231066)) nil) ;;; Comparison of bit vectors in compiled code (deftest misc.537 (let ((p1 (make-array '(0) :element-type 'bit :adjustable t))) (notnot (funcall (compile nil `(lambda (p2) (declare (optimize speed (safety 1)) (type (simple-array t nil) r) (type (simple-bit-vector 0) p2)) (equal ,p1 (the (bit-vector 0) p2)))) #*))) t) ;;; abcl (23 Feb 2005) ;;; The value #C(3 4) is not of type number. (deftest misc.538 (notnot (typep (* 2/5 #c(3 4)) 'number)) t) ;;; Allegro CL (6.2 trial edition, x86) ;;; Error: `#c(0 -8)' is not of the expected type `REAL' (deftest misc.539 (notnot-mv (complexp (funcall (compile nil '(lambda (x) (declare (OPTIMIZE SPEED (SAFETY 1)) (type (eql #c(0 -8)) x)) (sqrt x))) #c(0 -8)))) t) ;;; Illegal instruction (deftest misc.540 (let* ((d0 #(a b c d e f g h)) (d1 (make-array 5 :fill-pointer 1 :displaced-to d0 :displaced-index-offset 2))) (find #c(1.0 2.0) d1)) nil) ;;; A crasher bug of REMOVE on non-simple nibble arrays (deftest misc.541 (dotimes (i 1000) (let* ((init '(12 11 8 8 11 10 9 1 3 9 6 12 4 3 6 4 7 10 12 6 11 12 4 15 8 10 7 0 0 0 12 9 6 1 0 14 2 14 6 4 2 2 11 7 13 11 3 9 0 2 3 4 2 11 8 7 9 0 0 3 8 3 10 8 2 8 9 4 9 0 11 4 9 8 12 8 5 2 10 10 1 14 7 8 5 5 7 8 1 13 2 13 12 2 5 11 1 12 12 0 2 5 15 2 14 2 3 10 1 0 7 7 11 3 7 6 1 13 8 4 2 7 14 9 9 7 3 8 1 15 6 11 15 0 11 9 7 15 12 10 6 4 5 6 10 4 4 4 15 5 1 8 9 3 12 11 8 4 10 8 3 15 12 3 4 10 8 12 8 14 2 12 12 14 14 5 14 6 10 13 9 6 4 14 9 6 8 4 11 1 6 0 7 7 5 4 12 15 7 4 4 10 7 3 0 11 10 11 1 8 9 0 12 14 6 2 15 2 5 11 8 3 4 2 9 9 7 0 7 11 13 5 7 12 8 6 12 11 15 3 6 11 0 1 2 7 2 13 14 15 4)) (d0 (make-array '(251) :element-type '(integer 0 15) :initial-contents init :adjustable t))) (assert (equalp (remove 7 d0) (coerce (remove 7 init) '(vector (integer 0 15))))))) nil) ;;; Object identity for bit vectors (deftest misc.542 (funcall (compile nil (let ((bv1 (copy-seq #*1)) (bv2 (copy-seq #*1))) `(lambda () (eq ,bv1 ,bv2))))) nil) ;;; Lispworks personal edition 4.3 (x86 linux) ;;; Error: In PLUSP of (#C(1123113 -260528)) arguments should be of type REAL. (deftest misc.543 (funcall (compile nil '(lambda (p1) (declare (optimize speed (safety 1)) ; (type (simple-array t nil) r) (type (integer 2493220 2495515) p1)) (* p1 #c(1123113 -260528)))) 2493726) #C(2800736089038 -649685447328)) ;;; gcl (deftest misc.544 (let ((n -1.0l0)) (notnot-mv (complexp (funcall (compile nil `(lambda (p1) (declare (optimize speed (safety 1)) (type (long-float ,n 0.0l0) p1)) (sqrt p1))) n)))) t) ;;; OpenMCL ;;; 1/2 is not of type integer (deftest misc.545 (let ((x #c(-1 1/2))) (declare (type (eql #c(-1 1/2)) x)) x) #c(-1 1/2)) ;;; SBCL ;;; 0.8.19.39 ;;; The function SB-KERNEL:CHARACTER-STRING-P is undefined. (deftest misc.546 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 1) (debug 2) (space 3)) (type (eql a) p1)) (typep p1 (type-of "")))) 'a) nil) ;;; The function SB-KERNEL:SIMPLE-CHARACTER-STRING-P is undefined. (deftest misc.547 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 3) (debug 0) (space 3)) (type symbol p1)) (typep (the (eql :c1) p1) (type-of "b")))) :c1) nil) ;;; The value NIL is not of type SB-KERNEL:CTYPE. (deftest misc.548 (notnot (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 3) (space 2))) (atom (the (member f assoc-if write-line t w) p1)))) t)) t) ;;; IR2 type checking of unused values in [sic] not implemented. (deftest misc.549 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 1) (safety 1) (debug 0) (space 3)) (type symbol p2)) (and :a (the (eql t) p2)))) t) t) (deftest misc.550 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) (type atom p1) (type symbol p2)) (or p1 (the (eql t) p2)))) nil t) t) (deftest misc.551 (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 1) (safety 1) (debug 3) (space 3)) (type symbol p1) (type (integer * 55687) p2)) (funcall (the (eql +) p1) (the (integer -93015310 16215) p2) 2952))) '+ 823) 3775) (deftest misc.551a (funcall (compile nil '(lambda (x) (declare (optimize (speed 2)) (type symbol x)) (the (eql t) x))) t) t) ;;; cmucl (mar 2005 snapshot) (deftest misc.552 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 1) (debug 2) (space 2)) (type unsigned-byte p1)) (logbitp (the (integer -780969457 *) p1) 9))) 26) nil) ;;; ecls ;;; REAL is not of type REAL. (deftest misc.553 (funcall (compile nil '(lambda (x) (declare (type (eql #c(1.0 2.0)) x)) x)) #c(1.0 2.0)) #c(1.0 2.0)) ;;; 1 is not of type SEQUENCE (deftest misc.554 (funcall (compile nil '(lambda (x) (declare (type (array t 1) x)) x)) #(a)) #(a)) ;;; sbcl 5 Mar 2005 ;;; failed AVER: "(EQ CHECK SIMPLE)" (deftest misc.555 (notnot (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1)) (keywordp p1))) :c)) t) ; Problem with FLOOR ; Wrong return value (deftest misc.556 (values (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 1) (safety 0) (debug 0) (space 0)) (type (member 8174.8604) p1) (type (member -95195347) p2)) (floor p1 p2))) 8174.8604 -95195347)) -1) ; invalid number of arguments: 1 ; (possible removal of code due to type fumble) (deftest misc.557 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 0) (debug 3) (space 1)) (type (member -94430.086f0) p1)) (floor (the single-float p1) 19311235))) -94430.086f0)) -1) ; FFLOOR ; Wrong return value (deftest misc.558 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 2) (debug 2) (space 3)) (type (eql -39466.56f0) p1)) (ffloor p1 305598613))) -39466.56f0)) -1.0f0) ; CEILING ; invalid number of arguments: 1 (deftest misc.559 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 1) (debug 1) (space 2)) (type (eql -83232.09f0) p1)) (ceiling p1 -83381228))) -83232.09f0)) 1) ; wrong return value (deftest misc.560 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 1) (debug 1) (space 0)) (type (member -66414.414f0) p1)) (ceiling p1 -63019173f0))) -66414.414f0)) 1) ; FCEILING ; wrong return value (deftest misc.561 (values (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 1) (debug 0) (space 1)) (type (eql 20851.398f0) p1)) (fceiling p1 80839863))) 20851.398f0)) 1.0f0) ;;; LOG ;;; The value #C(-215549 39/40) is not of type (COMPLEX RATIONAL). (deftest misc.562 (let ((fn '(lambda (p1) (declare (optimize (speed 0) (safety 0) (debug 0) (space 2)) (type (complex rational) p1)) (log p1)))) (notnot (complexp (funcall (compile nil fn) #C(-215549 39/40))))) t) ;;; CONJUGATE ;;; Wrong result (#c(1 2)) (deftest misc.563 (funcall (compile nil '(lambda (x) (declare (optimize (speed 1) (safety 0) (debug 3) (space 1)) (type (complex rational) x)) (conjugate (the (eql #c(1 2)) x)))) #c(1 2)) #c(1 -2)) ;;; PHASE ;;; The function SB-KERNEL:%ATAN2 is undefined. (deftest misc.564 (notnot (typep (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) (type complex p1)) (phase (the (eql #c(1.0d0 2.0d0)) p1)))) #c(1.0d0 2.0d0)) 'double-float)) t) ;;; ACL 6.2 (trial, x86 linux) ;;; Incorrect return value (t instead of nil) (deftest misc.565 (funcall (compile nil '(lambda (x) (declare (optimize (speed 2) (safety 1) (debug 3) (space 0)) (type double-float x)) (not (the (eql 1.0d0) x)))) 1.0d0) nil) ;;; ASH ;;; Incorrect value (59 == (ash p1 -3)) (deftest misc.566 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 2) (debug 2) (space 0)) (type (integer 465 127871) p1)) (ash p1 -35))) 477) 0) ;;; sbcl ;;; The value -4 is not of type (INTEGER -26794287907 505600792). (deftest misc.567 (eqlt (funcall (compile nil '(lambda (p2) (declare (optimize (speed 3) (safety 1) (debug 0) (space 1)) (type (integer -26794287907 505600792) p2)) (scale-float -15193.341216130497d0 (the (integer * 25) p2)))) -4) (scale-float -15193.341216130497d0 -4)) t) ;;; ACL 7.0 (x86 linux) ;;; Found by random type prop tests ;;; Error: Attempt to divide 13026.059 by zero. (deftest misc.568 (values (funcall (compile nil '(lambda (p2) (declare (optimize (speed 1) (safety 3) (debug 3) (space 1)) (type (rational * 5325/3112) p2)) (floor 13026.059 (the (member 5325/3112 0 -2316/167 -449/460) p2)))) 5325/3112)) 7612) ;;; Error: Attempt to take the car of #2\%b which is not listp. (deftest misc.569 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 3) (safety 2) (debug 1) (space 2)) (type t p2)) (ash -2609443 (the (integer -3 0) p2)))) -1) -1304722) ;;; Incorrect return value (deftest misc.570 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (safety 1))) (char-equal #\: #\: #\;)))) nil) ;;; CODE-CHAR returns incorrect result ;;; (ACL7.0, 8 bit character image) (deftest misc.571 (and (< 1000 char-code-limit) (let ((c1 (code-char 1000)) (c2 (funcall (compile nil '(lambda (x) (declare (optimize speed (safety 1))) (code-char x))) 1000))) (if (not (eql c1 c2)) (list c1 c2) nil))) nil) ;;; sbcl 0.8.20.19 ;;; The value 22 is not of type (MOD 22). (deftest misc.572 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 1) (safety 2) (debug 1) (space 1)) (type (integer -59 65558) p4)) (string<= #.(coerce "1yapt1l7eeenz72u6xqhdfimcyk" 'base-string) #.(coerce "bababababbbabbabbababb" 'base-string) :start2 (the (integer -3735 *) p4)))) 22) nil) ;;; The value 0 is not of type NIL. (deftest misc.573 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 2) (safety 1) (debug 2) (space 2)) (type unsigned-byte p4)) (string<= (coerce "pdhd5oeynvqlthz3xrrdycotf" 'base-string) (coerce "" 'base-string) :start1 (the (integer * 81) p4)))) 10) nil) ;;; incorrect return value (deftest misc.574 (funcall (compile nil '(lambda (p4) (declare (optimize (speed 3) (safety 1) (debug 1) (space 2)) (type (integer * 397079023) p4)) (string<= (coerce "e99mo7yAJ6oU4" 'base-string) (coerce "aaABAAbaa" 'base-string) :start1 (the (member -34 131074 67108872 9 -3305367300 335) p4)))) 9) 9) ;;; In abcl (14 Mar 2005) ;;; The value T is not of type number. (deftest misc.575 (equalp #c(1269346.0 47870.12254712875) t) nil) ;;; The value #C(435422075/240892576 373) is not of type NUMBER. (deftest misc.576 (* -7023900320 #C(435422075/240892576 373)) #C(-95573789122736375/7527893 -2619914819360)) ;;; The value #C(-555014/122849 -6641556271) is not of type NUMBER. (deftest misc.577 (/ -3185994774 #C(-555014/122849 -6641556271)) #C(217230410502882805764/665706755984253572883257634437 -319343563321640207257301634954/665706755984253572883257634437)) ;;; The value "" is not of type (STRING 1). (deftest misc.578 (funcall (compile nil '(lambda (p1) (declare (optimize safety)) (the (string 1) p1))) (make-array '(1) :element-type 'base-char :initial-element #\x :fill-pointer 0)) "") ;;; clisp (11 Jan 2005) ;;; *** - SYSTEM::%RPLACA: NIL is not a pair (deftest misc.579 (funcall (compile nil '(lambda () (declare (optimize (speed 3) (safety 3) (debug 3) (space 0))) (member 61 '(432445) :allow-other-keys t :foo t)))) nil) ;;; sbcl 0.8.20.19 ;;; The component type for COMPLEX is not numeric: (OR RATIO FIXNUM) (deftest misc.580 (notnot-mv (typep #c(1 2) '(complex (or ratio fixnum)))) t) ;;; The value -5067.2056 is not of type (SINGLE-FLOAT -5067.2056 -5067.2056). (deftest misc.581 (notnot (floatp (funcall (compile nil '(lambda (x) (declare (type (eql -5067.2056) x)) (+ 213734822 x))) -5067.2056))) t) (deftest misc.581a (notnot (typep (funcall (compile nil '(lambda (x) (declare (type (eql -1.0) x)) ;;; Note! #x1000001 is the least positive integer ;;; for which this fails on x86 (+ #x1000001 x))) -1.0f0) 'single-float)) t) ;;; Incorrect result (deftest misc.582 (let ((result (funcall (compile nil ' (lambda (p1) (declare (optimize (speed 0) (safety 1) (debug 1) (space 1)) (type (eql -39887.645) p1)) (mod p1 382352925))) -39887.645))) (if (plusp result) t result)) t) ;;; Argument X is not a REAL: # (deftest misc.583 (notnot-mv (complexp (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 0) (debug 2) (space 3)) (type (complex rational) p1)) (sqrt p1))) #c(-9003 -121)))) t) ;;; The value -27 is not of type (INTEGER -34359738403 -24). (deftest misc.584 (approx= (funcall (compile nil '(lambda (p1 p2) (declare (optimize (speed 1) (safety 1) (debug 0) (space 1)) (type (member -3712.8447) p1) (type (integer -34359738403 -24) p2)) (scale-float p1 p2))) -3712.8447 -27) (scale-float -3712.8447 -27)) t) ;;; IR2 type checking of unused values in not implemented. ;;; (note that this test has no THE form) (deftest misc.585 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 0) (safety 0) (debug 3) (space 3)) (type symbol p1)) (copy-list p1))) nil) nil) ;;; The value 4 is not of type (UNSIGNED-BYTE 2). (deftest misc.586 (funcall (compile nil '(lambda (p6) (declare (optimize (speed 0) (safety 2) (debug 0) (space 0)) (type (integer -2 3009181) p6)) (string> (coerce "ababaaabb" 'base-string) (coerce "ubbm" 'base-string) :start1 2 :start2 p6 :end1 8))) 4) 2) ;;; sbcl 0.8.20.27 ;;; Control stack exhausted (deftest misc.587 (let ((result (funcall (compile nil '(lambda (p2) (declare (optimize (speed 0) (safety 3) (debug 1) (space 0)) (type (eql 33558541) p2)) (- 92215.266 p2))) 33558541))) (notnot (typep result 'single-float))) t) ;;; Lispworks 4.3 Personal Edition ;;; Incorrect return value (T instead of NIL) (deftest misc.588 (funcall (compile nil '(lambda nil (declare (optimize (speed 2) (safety 1) (debug 1) (space 1))) (functionp 3502843)))) nil) ;;; (ARRAY NIL) is an illegal type specifier. (deftest misc.589 (typep 1 '(array nil)) nil) ;;; Segmentation violation (deftest misc.590 (funcall (compile nil '(lambda nil (declare (optimize debug)) (symbolp -86755)))) nil) ;;; parse-integer fails on displaced base strings (deftest misc.591 (let* ((s1 (coerce "708553218828630100500" 'base-string)) (s2 (make-array '(13) :element-type 'base-char :displaced-to s1 :displaced-index-offset 5))) (parse-integer s2)) 3218828630100 13) ;;; abcl, 19 Mar 2005 ;;; Stack overflow (deftest misc.592 (equalp #*0 "0") nil) ;;; clisp 21 Mar 2005 (-ansi -q, x86 Linux, gcc 3.2.2) ;;; *** - Compiler bug!! Occurred in SP-DEPTH at <0. (deftest misc.593 (funcall (compile nil '(lambda (a b) (declare (ignorable a b)) (declare (optimize (space 3) (debug 0) (safety 1) (compilation-speed 3) (speed 1))) (prog2 (catch 'ct1 (if (or (and t (not (and (and (or a t) nil) nil))) nil) a (reduce #'(lambda (lmv5 lmv2) 0) (vector b 0 a)))) 0))) 2212755 3154856) 0) ;;; OpenMCL 0.14.3 ;;; 28192897: value doesn't match constraint :U8CONST in template for CCL::MATCH-VREG (deftest misc.594 (funcall (compile nil '(lambda (a b c) (declare (ignorable a b c)) (declare (type (integer -1 0) a) (type (integer -1065019672 -181184465) b) (type (integer 30074 1948824693) c)) (declare (optimize (safety 2) (compilation-speed 1) (speed 2) (space 0) (debug 0))) (ash c (min 82 -28192897)))) 0 -714979492 1474663829) 0) ;;; ecl ;;; 10000000.0d0 is not of type INTEGER. (deftest misc.595 (floor 1/2 1.0d0) 0 #.(float 1/2 1.0d0)) ;;; sbcl 0.8.21.45 (x86) ;;; The function SB-KERNEL:VECTOR-NIL-P is undefined. (deftest misc.596 (notnot (let ((s (coerce "a" 'base-string))) (funcall (compile nil `(lambda () (declare (optimize (speed 0) (safety 3) (debug 2) (space 1))) (typep ,s '(string 1))))))) t) ;;; OpenMCL ;;; Incorrect value (deftest misc.597 (funcall (compile nil '(lambda (c) (declare (optimize (speed 1) (compilation-speed 2) (space 1) (debug 1) (safety 2))) (declare (type (integer 1 41) c)) (logxor -1 c))) 8) -9) ;;; SBCL 0.9.1.19 ;;; Failure of IMAGPART in compiled code (deftest misc.598 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 2) (safety 0) (debug 3) (space 1)) (type short-float p1)) (imagpart (the short-float p1)))) -79916.61s0) -0.0s0) ;;; The value 20408096470 is not of type (INTEGER 19856842407 20640917103) (deftest misc.599 (funcall (compile nil '(lambda (b) (declare (type (integer 19856842407 20640917103) b)) (declare (optimize (debug 1) (speed 3) (compilation-speed 2) (safety 3) (space 3))) (lognand b (deposit-field b (byte 0 0) 3762528061)))) 20408096470) -3225589269) ;;; SBCL 0.9.1.21 ;;; The function SB-C::SPECIFER-TYPE is undefined. (deftest misc.600 (funcall (compile nil '(lambda () (declare (notinline min ash)) (declare (optimize (speed 0) (debug 1) (safety 1) (space 1) (compilation-speed 3))) (logxor (ash 0 (min 90 0)) 0)))) 0) (deftest misc.601 (funcall (compile nil '(lambda () (declare (notinline gcd)) (declare (optimize (debug 3) (space 3) (safety 3) (compilation-speed 2) (speed 3))) (logeqv 0 (gcd 0))))) -1) ;;; Lispworks 4450 ;;; Show sporadic bugs in compiled code (deftest misc.602 (let ((form '(lambda () (if (oddp (progn (vector) 3747237)) 'a nil)))) (loop repeat 10 collect (funcall (compile nil form)))) (a a a a a a a a a a)) ;;; gcl 2.7.0 (12 Jul 2005) ;;; Error in WHEN [or a callee]: The GO tag #:G3614 is missing. (deftest misc.603 (funcall (compile nil '(lambda () (let ((x (values 0))) 0)))) 0) ;;; gcl 2.7.0 (23 Jul 2005, experimental cvs HEAD) ;;; Error in COMPILER::T1EXPR [or a callee]: ;;; LOAD-TIME-VALUE is not of type (OR RATIONAL FLOAT). (deftest misc.604 (let ((form '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) (type real p1) (type t p2)) (eql (the (rational -55253767/37931089) p1) (the atom p2))))) (funcall (compile nil form) -55253767/37931089 'a)) nil) ;;; Error in FUNCALL [or a callee]: LOAD-TIME-VALUE is not of type NUMBER. (deftest misc.605 (let ((form '(lambda (p1 p2) (declare (optimize (speed 3) (safety 1) (debug 0) (space 0)) (type number p1) (type (float 0.0 3579.314s0) p2)) (eql (the real p1) p2)))) (not (funcall (compile nil form) 3579.314s0 3579.314s0))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: #\a is not of type FIXNUM. (deftest misc.606 (let ((form '(lambda () (declare (optimize (speed 3) (safety 2) (debug 3) (space 2))) (equal #\a #c(-1775806.0s0 88367.29s0))))) (funcall (compile nil form))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: #*1 is not of type FIXNUM. (deftest misc.607 (funcall (compile nil '(lambda () (declare (optimize (speed 0) (safety 2) (debug 2) (space 2))) (equal #*1 1)))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: #\& is not of type FIXNUM. (deftest misc.608 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) (type (integer -62603278 -31187) p1)) (equal p1 #\&))) -31228) nil) ;;; Wrong return value (was returning T) (deftest misc.609 (funcall (compile nil '(lambda () (declare (optimize (speed 0) (safety 0) (debug 0) (space 3))) (equalp "b" #*)))) nil) ;;; Error in COMPILER::CMP-ANON [or a callee]: 7933992 is not of type SYMBOL. (deftest misc.610 (not (funcall (compile nil '(lambda (p2) (declare (optimize (speed 1) (safety 1) (debug 3) (space 2)) (type (cons symbol) p2)) (typep -32 p2))) '(eql -32))) nil) ;;; Error in CAR [or a callee]: -757161859 is not of type LIST. (deftest misc.611 (funcall (compile nil '(lambda (p1) (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) (type (cons atom) p1)) (car p1))) '(48144509 . a)) 48144509) ;;; gcl (09 Aug 2005) ;;; Error in COMPILER::POSSIBLE-EQ-LIST-SEARCH [or a callee]: COMPILER::POSSIBLE-EQ-LIST-SEARCH does not allow the keyword :B. (deftest misc.612 (funcall (compile nil '(lambda (p1 p2) ((lambda (x y) (typep x (type-of y))) p1 (the (member "foo" #\- :b "bar") p2)))) #*1 :b) nil) ;;; Error in APPLY [or a callee]: The tag CT1 is undefined. (deftest misc.613 (funcall (compile nil '(lambda (a) (declare (optimize (space 3) (safety 1) (debug 3) (speed 1) (compilation-speed 3))) (catch 'ct1 (reduce #'(lambda (lmv6 lmv5) (throw 'ct1 0)) (list a 0 0) :end 2)))) 1) 0) ;;; Error in MULTIPLE-VALUE-BIND [or a callee]: Cannot get relocated section contents (deftest misc.614 (funcall (compile nil '(lambda (a) (declare (type (integer -3873004182 -3717314779) a)) (declare (ignorable a)) (declare (optimize (debug 0) (safety 1) (speed 3) (space 0) (compilation-speed 0))) (let* ((v1 (make-array nil :initial-element (reduce #'logand (list a 0 a))))) (declare (dynamic-extent v1)) 0))) -3755148485) 0) ;;; gcl type-prop test failures (10/30/2005) (deftest misc.615 (let* ((x -8183.7625s0) (form `(lambda (p1) (eql p1 ,x)))) (not (not (funcall (compile nil form) x)))) t) ;;; cmucl 19c ;;; Wrong return value (deftest misc.616 (funcall (compile nil '(lambda (a b c) (declare (type (integer -153105 -36629) a)) (declare (type (integer -7811721705 3704985368) b)) (declare (type (integer 0 15) c)) (declare (ignorable a b c)) (declare (optimize (safety 1) (space 0) (compilation-speed 0) (speed 3) (debug 3))) (catch 'ct7 (labels ((%f12 (f12-1 f12-2 &optional &key (key1 0) (key2 (reduce #'(lambda (lmv2 lmv1) 0) (vector 0 0) :end 2 :start 0 :from-end t)) &allow-other-keys) a)) c)))) -134217 -3699719058 10) 10) ;;; sbcl 0.9.7.33 (x86) ;;; The value 16561216769 is not of type (INTEGER -2147483648 4294967295). ;;; On sparc solaris, the error message is: ;;; debugger invoked on a SB-KERNEL:CASE-FAILURE: ;;; 16561216769 fell through ETYPECASE expression. ;;; Wanted one of (SB-C:FIXUP (OR (SIGNED-BYTE 32) (UNSIGNED-BYTE 32)) ;;; (SIGNED-BYTE 13)). (deftest misc.617 (funcall (compile nil '(lambda (b) (declare (optimize (space 3) (safety 2) (debug 1) (speed 3) (compilation-speed 2))) (let* ((v2 16561216769)) (lognand (loop for lv3 below 0 sum (setf v2 lv3)) (if (typep v2 '(integer -39 7)) b 0))))) -10298) -1) ;;; failed AVER: "(EQ POP (CAR END-STACK))" ;;; (same on sparc solaris) (deftest misc.618 (funcall (compile nil '(lambda (c) (declare (optimize (space 0) (compilation-speed 2) (debug 0) (speed 3) (safety 0))) (block b1 (ignore-errors (multiple-value-prog1 0 (apply (constantly 0) c (catch 'ct2 (return-from b1 0)) nil)))))) -4951) 0) ;;; sbcl 0.9.7.33 (sparc solaris) ;;; Incorrect return value (deftest misc.619 (funcall (compile nil '(lambda (b) (declare (type (integer 75 206) b)) (declare (optimize (speed 0) (compilation-speed 2) (debug 2) (space 2) (safety 2))) (mask-field (byte 4 28) (ash b 70)))) 79) 0) ;;; The value 64 is not of type (OR SB-C:TN (UNSIGNED-BYTE 6) NULL). (deftest misc.620 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (compilation-speed 3) (debug 1) (space 3) (speed 1))) (loop for lv2 below 1 sum (ash lv2 64))))) 0) ;;; sbcl 0.9.8.17, x86 linux ;;; The value 32 is not of type (OR (INTEGER -67 -67) (INTEGER -63 -63)). (deftest misc.621 (funcall (compile nil '(lambda () (declare (optimize (debug 1) (space 0) (compilation-speed 3) (speed 1) (safety 3))) (loop for lv1 below 2 sum (dotimes (iv2 2 0) (mod (dotimes (iv4 2 0) (progn (count lv1 #*0) 0)) (min -63 (rem 0 (min -67 0))))))))) 0) ;;; sbcl 0.9.9.8, x86 linux ;;; TYPE-ERROR: The value 17549.955 is not of type REAL. (deftest misc.622 (funcall (compile nil '(lambda (p2) (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) (type real p2)) (+ 81535869 (the (member 17549.955 #:g35917) p2)))) 17549.955) #.(+ 81535869 17549.955)) ;;; sbcl 0.9.9.19 ;;; The function SB-VM::%LOGBITP is undefined. (deftest misc.623 (funcall (compile nil '(lambda () (declare (optimize (space 2) (speed 0) (debug 2) (compilation-speed 3) (safety 0))) (loop for lv3 below 1 count (minusp (loop for lv2 below 2 count (logbitp 0 (bit #*1001101001001 (min 12 (max 0 lv3)))))))))) 0) ;;; failed AVER: "(< Y 29)" (deftest misc.624 (funcall (compile nil '(lambda (a) (declare (type (integer 21 28) a)) (declare (optimize (compilation-speed 1) (safety 2) (speed 0) (debug 0) (space 1))) (let* ((v7 (flet ((%f3 (f3-1 f3-2) (loop for lv2 below 1 count (logbitp 29 (sbit #*10101111 (min 7 (max 0 (eval '0)))))))) (%f3 0 a)))) 0))) 22) 0) ;;; sbcl 0.9.9.22 (x86 linux) ;;; The following two errors appear to require the presence ;;; of two ELT forms. Somehow, the type check for one is ;;; misplaced into the other. ;;; TYPE-ERROR: The value 0 is not of type (INTEGER 3 3). (deftest misc.625 (funcall (compile nil '(lambda (a) (declare (type (integer -2 -1) a)) (declare (optimize (speed 0) (space 0) (safety 1) #+sbcl (sb-c:insert-step-conditions 0) (debug 3) (compilation-speed 1))) (elt '(47119 39679 57498 35248 23784 40597 53473 29454) (min 7 (max 0 (flet ((%f7 (f7-1 f7-2 &optional &key (key1 (elt '(0 25 30 12 27 5) (min 5 (max 0 3))))) 0)) (flet ((%f6 (&optional &key (key1 (progn (%f7 0 a) a)) (key2 0)) 0)) (%f7 a a)))))))) -2) 47119) ;;; TYPE-ERROR: The value 2 is not of type (INTEGER 12 12) (deftest misc.625a (funcall (compile nil '(lambda (a b) (declare (type (integer 1 5) b)) (declare (optimize (safety 2) (speed 2) (space 0) (compilation-speed 3) (debug 3))) (progn (flet ((%f3 (f3-1 f3-2 &optional (f3-3 b) f3-4 (f3-5 (prog1 0 (elt '(a b c d e f g h i j k l m) 12)))) f3-1)) (%f3 0 (%f3 0 a 0 a) a 0 a)) (elt '(a b c d) (min 3 b)) ))) 0 2) c) ;;; failed AVER: "(<= Y 29)" (deftest misc.626 (funcall (compile nil '(lambda (a) (declare (type (integer -902970 2) a)) (declare (optimize (space 2) (debug 0) (compilation-speed 1) (speed 0) (safety 3))) (prog2 (if (logbitp 30 a) 0 (block b3 0)) a))) -829253) -829253) ;;; The value -93368855 is not of type UNSIGNED-BYTE. ;;; [...] ;;; (LOGBITP -93368855 0) (deftest misc.628 (funcall (compile nil '(lambda () (declare (optimize (safety 3) (space 3) (compilation-speed 3) (speed 0) (debug 1))) (not (not (logbitp 0 (floor 2147483651 (min -23 0)))))))) t) ;;; sbcl 0.9.9.35 ;;; The value #S(MISC-629 :A 1 :B 3) is not of type SB-KERNEL:INSTANCE. (defstruct misc-629 a b) (deftest misc.629 (let* ((s (make-misc-629 :a 1 :b 3)) (form `(lambda (x) (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) (type (member 0 2 ,s) x)) (misc-629-a x)))) (funcall (compile nil form) s)) 1) ;;; sbcl 0.9.10.11 ;;; Failures associated with MULTIPLE-VALUE-PROG1 ;;; Argument X is not a NUMBER: NIL ;;; (SB-KERNEL:TWO-ARG-/ NIL 1) (deftest misc.630 (funcall (compile nil '(lambda () (declare (optimize (speed 1) (debug 0) (space 2) (safety 0) (compilation-speed 0))) (unwind-protect 0 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1)))))) 0) ;;; Argument X is not a INTEGER: NIL ;;; (SB-KERNEL:TWO-ARG-AND NIL 1) (deftest misc.631 (if (flet ((%f17 (&key (key2 (if (evenp (multiple-value-prog1 0)) 0 0))) 0)) 0) :a :b) :a) ;;; gcl 2.7.0 (7 Mar 2006) ;;; Wrong value -- NIL (deftest misc.632 (funcall (compile nil '(lambda () (let (b) (multiple-value-setq (b) 10))))) 10) ;;; sbcl (x86 linux) 0.9.10.43 ;;; The value -17045.0 ;;; is not of type ;;; (OR (MEMBER #:|u4m7k0jz6o| 1+) ;;; (MEMBER #\b) ;;; (SINGLE-FLOAT -17045.0 -17045.0)). (deftest misc.633 (let* ((x -17045.0) (form `(lambda (p3 p4) (declare (optimize (speed 1) (safety 3) (debug 0) (space 1)) (type number p3) (type (member -1451.1257 47889 #:|3| ,x #:|aabbaaaaaababa|) p4)) (min 1 -251.2455 (the number p3) (the (member 1+ ,x #\b #:|u4m7k0jz6o|) p4) -1506/1283 65681158/19740963)))) (funcall (compile nil form) 1861 x)) -17045.0) ;;; sbcl (x86 linux) 0.9.10.48 ;;; The value 35182846 is not of type (INTEGER 35182846 35182846). (deftest misc.634 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 3) (debug 3) (space 2)) (type number p2)) (- -83659.0 (the (member 35182846) p2))))) (funcall (compile nil form) 35182846)) #.(- -83659.0 35182846)) ;;; sbcl (x86 linux) 0.9.11.4 ;;; Different results (deftest misc.635 (let* ((form '(lambda (p2) (declare (optimize (speed 0) (safety 1) (debug 2) (space 2)) (type (member -19261719) p2)) (ceiling -46022.094 p2)))) (values (funcall (compile nil form) -19261719))) 1) ;;; TYPE-ERROR: The value 26899.875 is not of type NUMBER. (deftest misc.636 (let* ((x 26899.875) (form `(lambda (p2) (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) (type (member ,x #:g5437 char-code #:g5438) p2)) (* 104102267 p2)))) (not (not (floatp (funcall (compile nil form) x))))) t) ;;; attempt to THROW to a tag that does not exist: SB-C::LOCALL-ALREADY-LET-CONVERTED (deftest misc.637 (labels ((%f11 (f11-2 &key key1) (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0))) :bad1)) (%f8 (%f8 0))) :bad2)) :good) :good) ;;; full call to SB-KERNEL:DATA-VECTOR-REF (deftest misc.638 (let* ((codes '(32779 60674 33150 60033 41146 23916 28908 58886 12776 21282 37346 25537 56184 40736 4845 41954 6663 44378 23466 46903 13661 36445 18784 6114 6266)) (chars (loop for code in codes collect (or (code-char code) #\x))) (c (elt chars 21)) (s (make-array '(25) :element-type 'character :initial-contents chars))) (let ((form `(lambda (p1) (declare (optimize (speed 2) (safety 0) (debug 3) (space 1)) (type (simple-string 25) p1)) (char (the (member ,(let ((s2 "abbbabbaaabbaba")) (make-array (length s2) :element-type 'base-char :initial-contents s2)) ,s) p1) 21)))) (not (not (eql c (funcall (compile nil form) s)))))) t) ;;; sbcl 0.9.11.24 (x86 linux) ;;; failed AVER: "(EQ PHYSENV (LAMBDA-PHYSENV (LAMBDA-VAR-HOME THING)))" (deftest misc.639 (let ((form '(lambda (a b d) (declare (notinline >= eql)) (declare (optimize (debug 2) (speed 3) (safety 0) (compilation-speed 3) (space 0))) (labels ((%f8 (f8-1 &optional (f8-4 (if (if (eql 0 -16) (>= d) nil) 0 0))) a)) (%f8 b))))) (funcall (compile nil form) :good 18 0)) :good) ;;; sbcl 0.9.11.45 (x86 linux) ;;; Incorrect value: -32377322164 (deftest misc.640 (let ((form '(lambda (b g) (declare (type (integer 303184 791836) b)) (declare (optimize (compilation-speed 2) (debug 0) (space 1) (speed 1) (safety 2))) (loop for lv1 below 2 sum (if (<= g lv1) (labels ((%f7 () (prog1 b 0))) (%f7)) (setf g -16188661082)))))) (funcall (compile nil form) 335562 4655131896)) -16188325520) ;;; sbcl 0.9.12.27 (x86 linux) ;;; The value NIL is not of type SB-C::IR2-NLX-INFO. (deftest misc.641 (let ((form '(lambda () (declare (optimize (speed 1) (space 0) (debug 2) (compilation-speed 0) (safety 1))) (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #()))) 0)) (apply #'%f3 0 nil))))) (funcall (compile nil form))) 0) ;;; cmucl 19c (x86 linux) ;;; The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL))) failed. (deftest misc.642 (let ((form ' (lambda (a b c d e f g h i j) (declare (type (integer 174130 60165950) a)) (declare (type (integer -4076 6783) b)) (declare (type (integer -178481569 -1) c)) (declare (type (integer 236 954963169) d)) (declare (type (integer -1334 407047) e)) (declare (type (integer -507 -426) f)) (declare (type (integer -1164301 148213922) g)) (declare (type (integer -184324 14515) h)) (declare (type (integer 258 323) i)) (declare (type (integer -11825 109247) j)) (declare (ignorable a b c d e f g h i j)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (compilation-speed 2) (debug 0) (space 1) (speed 3) (safety 2))) (labels ((%f4 (f4-1) (flet ((%f2 (f2-1 f2-2 f2-3 &key) (progn (return-from %f4 0) f2-2))) (common-lisp:handler-bind nil (/ (coerce (unwind-protect (reduce #'(lambda (lmv2 lmv4) (reduce #'* (vector (let () h) c (reduce #'(lambda (lmv4 lmv3) (return-from %f4 (deposit-field lmv4 (byte 23 16) (mask-field (byte 3 27) (elt '(5309746) (min 0 (max 0 j))))))) (vector (%f2 (%f2 12762 f4-1 6646240924) 1501 -15) 277 (multiple-value-call #'%f2 (values -1486981 i (%f2 a 16777222 j))) 1033) :end 4 :start 3) (/ 823 -1)) :end 3 :start 1)) (vector (common-lisp:handler-bind nil (- 0 h j b -2539837 28596 d 8161548 h -61)) -183768642 -1 31404552 81593) :start 3) (dpb i (byte 14 16) e) (dpb (count f4-1 #(524279 8388596 1021351 101986) :test '/=) (byte 4 4) 131064) (if (= 524287 f) (prog2 (denominator (elt '(1663 120) (min 1 (max 0 -17745)))) f (deposit-field e (byte 31 31) 0) (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 (coerce (coerce (the integer (+ -11045 114)) 'integer) 'integer)) (f7-5 h)) -2286515)) j)) (macrolet () (prog2 -2195 1921675 h -183085 a)))) 'integer) 1))))) 0)))) (funcall (compile nil form) 58162926 -3652 -63561386 935157597 63716 -504 108893677 -146677 308 99009)) 0) ;;; Wrong return value (deftest misc.643 (let ((form '(lambda (a) (declare (type (integer 6 1273) a)) (declare (optimize (space 0) (safety 0) (debug 3) (compilation-speed 2) (speed 3))) (logorc2 0 (restart-bind nil (shiftf a 522)))))) (funcall (compile nil form) 807)) -808) ;;; -1520586839 is not of type INTEGER (deftest misc.644 (let ((form '(lambda (a) (declare (type (integer -6568333536 -12667) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (compilation-speed 1) (safety 3) (speed 1) (debug 1) (space 3))) (unwind-protect 0 (the integer (locally (declare (special *s3* *s4*)) (progv '(*s4* *s3*) (list a a) (expt *s3* 0)))))))) (let ((*s3* 0)) (declare (special *s3*)) (funcall (compile nil form) -1520586839))) 0) ;;; NIL is not of type C::CBLOCK (deftest misc.645 (let ((form '(lambda (a) (declare (notinline abs isqrt)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (debug 3) (safety 1) (space 2) (compilation-speed 1) (speed 0))) (progn (tagbody (prog2 a 0 (labels ((%f9 (&key &allow-other-keys) (go 3))) (%f9))) (isqrt (abs (unwind-protect 0))) 3) a)))) (eval `(,form 0))) 0) ;;; Segmentation violation (deftest misc.646 (let ((form '(lambda (a) (declare (type (integer -125 -44) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 0) (debug 0) (space 2) (compilation-speed 3) (safety 3))) (mask-field (byte 0 0) (block b3 (isqrt (abs (catch 'ct2 (return-from b3 0))))))))) (funcall (compile nil form) -50)) 0) ;;; 1928431123 is not of type (MOD 536870911) (deftest misc.647 (let ((form '(lambda (a) (declare (type (integer -2494 534) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (speed 0) (space 0) (compilation-speed 3) (safety 1) (debug 1))) (dotimes (iv3 1 0) (block b1 (loop for lv1 below 1 count (logbitp 0 (reduce #'(lambda (lmv6 lmv2) (if (> 2208446653 lmv6) (return-from b1 lmv2) lv1)) (list 0 0 0 1928431123 iv3 iv3 a a) :end 5 :from-end t)))))))) (funcall (compile nil form) 1)) 0) ;;; The assertion (AND C::SUCC (NULL (CDR C::SUCC))) failed. (deftest misc.648 (let ((form '(lambda (a) (declare (type (integer -8 11754838336) a)) (declare (ignorable a)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize (space 0) (compilation-speed 0) (speed 3) (debug 3) (safety 0))) (labels ((%f13 () (logorc1 (unwind-protect 0) (prog1 0 (prog2 (max 0 a) 0 (progn (return-from %f13 a) a)))))) 0)))) (funcall (compile nil form) 2582756596)) 0) ;;; sbcl 0.9.13.8 (x86 linux) ;;; VALUES type illegal in this context: * (deftest misc.649 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 0) (debug 2) (space 2)) (type (member integer *) p2)) (coerce 523242 p2)))) (funcall (compile nil form) 'integer)) 523242) ;;; The symbol AND is not valid as a type specifier (deftest misc.650 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer and) p2)) (coerce -12 p2)))) (funcall (compile nil form) 'integer)) -12) ;;; The symbol OR is not valid as a type specifier (deftest misc.651 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer or) p2)) (coerce 1 p2)))) (funcall (compile nil form) 'integer)) 1) ;;; The symbol NOT is not valid as a type specifier. (deftest misc.652 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer not) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; The symbol SATISFIES is not valid as a type specifier. (deftest misc.653 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer satisfies) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; error while parsing arguments to DEFTYPE EQL: ;;; invalid number of elements in ;;; () ;;; to satisfy lambda list ;;; (SB-KERNEL::N): ;;; exactly 1 expected, but 0 found (deftest misc.654 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer eql) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; The symbol MEMBER is not valid as a type specifier. (deftest misc.655 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer member) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; error while parsing arguments to DEFTYPE MOD: ;;; invalid number of elements in ;;; () ;;; to satisfy lambda list ;;; (SB-KERNEL::N): ;;; exactly 1 expected, but 0 found (deftest misc.656 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer mod) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) ;;; The symbol VALUES is not valid as a type specifier. (deftest misc.657 (let ((form '(lambda (p2) (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) (type (member integer values) p2)) (coerce 2 p2)))) (funcall (compile nil form) 'integer)) 2) gcl-2.7.1/ansi-tests/PaxHeaders/set-macro-character.lsp0000644000000000000000000000013214542551763020016 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.633789803 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/set-macro-character.lsp0000644000175000017500000000341514542551763017417 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 3 10:37:16 2005 ;;;; Contains: Tests of SET-MACRO-CHARACTER (in-package :cl-test) (def-syntax-test set-macro-character.1 (let ((*readtable* (copy-readtable)) (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!"))) (assert (eql v1 '?!)) (flet ((%f (stream char) (declare (ignore stream)) (assert (eql char #\?)) 17)) (let ((fn #'%f)) (assert (equal (multiple-value-list (set-macro-character #\? fn nil)) '(t))) (values (multiple-value-list (read-from-string "?!")) (multiple-value-list (read-from-string "!?"))))))) (17 1) (! 1)) (def-syntax-test set-macro-character.2 (let ((rt (copy-readtable)) (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!"))) (assert (eql v1 '?!)) (flet ((%f (stream char) (declare (ignore stream)) (assert (eql char #\?)) 17)) (let ((fn #'%f)) (assert (equal (multiple-value-list (set-macro-character #\? fn t rt)) '(t))) (let ((*readtable* rt)) (values (multiple-value-list (read-from-string "?!")) (multiple-value-list (read-from-string "!?")))))))) (17 1) (!? 2)) (defun set-macro-character.3-test-fn (stream char) (declare (ignore stream)) (assert (eql char #\?)) :foo) (def-syntax-test set-macro-character.3 (let ((*readtable* (copy-readtable)) (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!")) (fn 'set-macro-character.3-test-fn)) (assert (eql v1 '?!)) (assert (equal (multiple-value-list (set-macro-character #\? fn nil)) '(t))) (values (multiple-value-list (read-from-string "?!")) (multiple-value-list (read-from-string "!?"))))) (:foo 1) (! 1)) gcl-2.7.1/ansi-tests/PaxHeaders/set-difference.lsp0000644000000000000000000000013214542551763017055 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.633789803 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/set-difference.lsp0000644000175000017500000001673214542551763016464 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:44:06 2003 ;;;; Contains: Tests of SET-DIFFERENCE (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless set-difference.test-and-test-not.1 (set-difference (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless set-difference.test-and-test-not.2 (set-difference (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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) (def-fold-test set-difference.fold.1 (set-difference '(a b c d e f g h) '(b w h x e y))) ;;; Error tests (deftest set-difference.error.1 (signals-error (set-difference) program-error) t) (deftest set-difference.error.2 (signals-error (set-difference nil) program-error) t) (deftest set-difference.error.3 (signals-error (set-difference nil nil :bad t) program-error) t) (deftest set-difference.error.4 (signals-error (set-difference nil nil :key) program-error) t) (deftest set-difference.error.5 (signals-error (set-difference nil nil 1 2) program-error) t) (deftest set-difference.error.6 (signals-error (set-difference nil nil :bad t :allow-other-keys nil) program-error) t) (deftest set-difference.error.7 (signals-error (set-difference (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest set-difference.error.8 (signals-error (set-difference (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest set-difference.error.9 (signals-error (set-difference (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest set-difference.error.10 (signals-error (set-difference (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest set-difference.error.11 (signals-error (set-difference (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest set-difference.error.12 (signals-error (set-difference (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest set-difference.error.13 (check-type-error #'(lambda (x) (set-difference x '(a b c))) #'listp) nil) (deftest set-difference.error.14 (check-type-error #'(lambda (x) (set-difference '(a b c) x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/eval.lsp0000644000000000000000000000013214542551762015120 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.633789803 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/eval.lsp0000644000175000017500000000170314542551762014517 0ustar00cammcamm;-*- 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 (signals-error (eval) program-error) t) (deftest eval.error.2 (signals-error (eval nil nil) program-error) t) (deftest eval.error.3 (let ((v (gensym))) (eval `(signals-error (eval (list ',v)) undefined-function :name ,v))) t) (deftest eval.error.4 (let ((v (gensym))) (eval `(signals-error (eval ',v) unbound-variable :name ,v))) t)gcl-2.7.1/ansi-tests/PaxHeaders/prog2.lsp0000644000000000000000000000013114542551763015222 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.633789803 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/prog2.lsp0000644000175000017500000000204014542551763014615 0ustar00cammcamm;-*- 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) ;;; Test that prog2 doesn't have a tagbody (deftest prog2.7 (block nil (tagbody (return (prog2 17 'bad (go 10) 10)) 10 (return 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog2.8 (macrolet ((%m (z) z)) (prog2 (expand-in-current-env (%m 'bad1)) (expand-in-current-env (%m 'good)) (expand-in-current-env (%m 'bad2)))) good) (def-macro-test prog2.error.1 (prog2 nil nil)) gcl-2.7.1/ansi-tests/PaxHeaders/type.lsp0000644000000000000000000000013114542551763015152 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.633789803 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/type.lsp0000644000175000017500000000262114542551763014552 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 29 08:25:46 2005 ;;;; Contains: Tests of TYPE declarations (in-package :cl-test) ;;; Also of implicit type declarations (deftest type.1 (let ((x 1)) (declare (type (integer 0 1) x)) (values x (setq x 0) (1+ x))) 1 0 1) (deftest type.2 (let ((x 1)) (declare (type (integer -1 1) x)) (locally (declare (type (integer 0 2) x)) (values x (setq x 0) (1+ x)))) 1 0 1) (deftest type.3 (loop for x in *mini-universe* for tp = (type-of x) for form = `(let ((y ',x)) (declare (type ,tp y)) y) for val = (eval form) unless (eql val x) collect (list x tp form val)) nil) (deftest type.4 (loop for x in *mini-universe* for tp = (type-of x) for form = `(let ((y ',x)) (declare (,tp y)) y) for val = (eval form) unless (eql val x) collect (list x tp form val)) nil) (deftest type.5 (loop for x in *mini-universe* for class = (class-of x) for form = `(let ((y ',x)) (declare (,class y)) y) for val = (eval form) unless (eql val x) collect (list x class form val)) nil) ;;; Free TYPE declaration ;;; It should not apply to the occurence of X in the form ;;; whose value is being bound to Y. (deftest type.6 (let ((x 2)) (let ((y (+ (decf x) 2))) (declare (type (integer 0 1) x)) (values x y))) 1 3) gcl-2.7.1/ansi-tests/PaxHeaders/reader-test.lsp0000644000000000000000000000013114542551763016410 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.633789803 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/reader-test.lsp0000644000175000017500000001761214542551763016016 0ustar00cammcamm;-*- 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) (compile-and-load "reader-aux.lsp") (def-syntax-test read-symbol.1 (read-from-string "a") a 1) (def-syntax-test read-symbol.2 (read-from-string "|a|") |a| 3) (def-syntax-test read-symbol.3 (multiple-value-bind (s n) (read-from-string "#:abc") (not (and (symbolp s) (eql n 5) (not (symbol-package s)) (string-equal (symbol-name s) "abc")))) nil) (def-syntax-test read-symbol.4 (multiple-value-bind (s n) (read-from-string "#:|abc|") (not (and (symbolp s) (eql n 7) (not (symbol-package s)) (string= (symbol-name s) "abc")))) nil) (def-syntax-test read-symbol.5 (multiple-value-bind (s n) (read-from-string "#:||") (if (not (symbolp s)) s (not (not (and (eql n 4) (not (symbol-package s)) (string= (symbol-name s) "")))))) t) (def-syntax-test read-symbol.6 (let ((str "cl-test::abcd0123")) (multiple-value-bind (s n) (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) (def-syntax-test read-symbol.7 (multiple-value-bind (s n) (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 &optional (chars +standard-chars+)) (loop repeat 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 (random-from-seq chars))) (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) (read-from-string (concatenate 'string "#:|" actual-string "|")) (unless (and (symbolp sym) (eql nread (+ 4 actual-len)) (string-equal s2 (symbol-name sym))) (let ((*print-readably* t)) (format t "Symbol read failed: ~S (~S) read as ~S~%" actual-string s2 sym)) t)))))) (def-syntax-test read-symbol.9 (read-symbol.9-body 1000 100) 0) (def-syntax-test read-symbol.9a (let ((chars (coerce (loop for i below (min 256 char-code-limit) for c = (code-char i) when c collect c) 'string))) (if (> (length chars) 0) (read-symbol.9-body 1000 100) 0)) 0) (def-syntax-test read-symbol.9b (let ((chars (coerce (loop for i below (min 65536 char-code-limit) for c = (code-char i) when c collect c) 'string))) (if (> (length chars) 0) (read-symbol.9-body 1000 100) 0)) 0) (def-syntax-test read-symbol.10 (equalt (symbol-name (read-from-string (with-output-to-string (s) (write (make-symbol ":") :readably t :stream s)))) ":") t) (def-syntax-test read-symbol.11 (loop for c across +standard-chars+ for str = (make-array 2 :element-type 'character :initial-contents (list #\\ c)) for sym = (read-from-string str) unless (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c))) collect (list c str sym)) nil) (def-syntax-test read-symbol.12 (loop for c across +standard-chars+ for str = (make-array 2 :element-type 'base-char :initial-contents (list #\\ c)) for sym = (read-from-string str) unless (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c))) collect (list c str sym)) nil) (def-syntax-test read-symbol.13 (loop for i below (min 65536 char-code-limit) for c = (code-char i) for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) for sym = (and c (read-from-string str)) unless (or (not c) (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c)))) collect (list c str sym)) nil) (def-syntax-test read-symbol.14 (loop for i = (random (min (ash 1 24) char-code-limit)) for c = (code-char i) for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) for sym = (and c (read-from-string str)) repeat 1000 unless (or (not c) (and (symbolp sym) (eql sym (find-symbol (string c))) (equal (symbol-name sym) (string c)))) collect (list c str sym)) nil) (def-syntax-test read-symbol.15 (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) unless (eql sym (find-symbol (string (char-upcase c)))) collect (list c str sym)) nil) (def-syntax-test read-symbol.16 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :downcase) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) unless (eql sym (find-symbol (string (char-downcase c)))) collect (list c str sym))) nil) (def-syntax-test read-symbol.17 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :preserve) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) unless (eql sym (find-symbol str)) collect (list c str sym))) nil) (def-syntax-test read-symbol.18 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :invert) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" for str = (string c) for sym = (read-from-string str) for c2 = (cond ((upper-case-p c) (char-downcase c)) ((lower-case-p c) (char-upcase c)) (t c)) unless (eql sym (find-symbol (string c2))) collect (list c c2 str sym))) nil) (def-syntax-test read-symbol.19 (read-from-string "123||") |123| 5) (def-syntax-test read-symbol.20 (read-from-string "123\\4") |1234| 5) (def-syntax-test read-symbol.21 (read-from-string "\\:1234") |:1234| 6) (def-syntax-test read-symbol.22 (read-from-string "||") #.(intern "" (find-package "CL-TEST")) 2) (def-syntax-test read-symbol.23 (loop for c across +standard-chars+ for s = (concatenate 'string (string c) ".") for sym = (intern (string-upcase s)) when (alpha-char-p c) nconc (let ((sym2 (let ((*read-base* 36)) (read-from-string s)))) (if (eq sym sym2) nil (list c s sym sym2)))) nil) (def-syntax-test read-symbol.24 (loop for c1 = (random-from-seq +alpha-chars+) for c2 = (random-from-seq +alpha-chars+) for d1 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) for d2 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) for s = (concatenate 'string d1 (list c1 c2) d2) for sym = (intern (string-upcase s)) repeat 1000 nconc (let ((sym2 (read-from-string s))) (if (eq sym sym2) nil (list c1 c2 d1 d2 s sym sym2)))) nil) (def-syntax-test read-symbol.25 (let ((potential-chars "01234567890123456789+-esdlf_^/") (*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :preserve) (loop for d1 = (loop repeat (random 6) collect (random-from-seq potential-chars)) for c = (random-from-seq potential-chars) for d2 = (loop repeat (random 6) collect (random-from-seq potential-chars)) for s1 = (concatenate 'string d1 (list c) d2) for sym1 = (intern s1) for s2 = (concatenate 'string d1 (list #\\ c) d2) for sym2 = (read-from-string s2) repeat 1000 unless (eql sym1 sym2) collect (list d1 c d2 s1 sym1 s2 sym2))) nil) (deftest read-float.1 (eqlt -0.0 (- 0.0)) t) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-eql.lsp0000644000000000000000000000013114542551763016623 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.637789821 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-eql.lsp0000644000175000017500000000252014542551763016221 0ustar00cammcamm;-*- 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) (compile-and-load "types-aux.lsp") (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.7.1/ansi-tests/PaxHeaders/do.lsp0000644000000000000000000000013214542551762014573 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.637789821 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/do.lsp0000644000175000017500000000712314542551762014174 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:25:18 2005 ;;;; Contains: Tests of DO (in-package :cl-test) (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)) ;;; Scope of free declarations (deftest do.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do ((i (return-from done x) 0)) (t nil) (declare (special x)))))) :good) (deftest do.17 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do ((i 0 (return-from done x))) (nil nil) (declare (special x)))))) :good) (deftest do.18 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do ((i 0 0)) ((return-from done x) nil) (declare (special x)))))) :good) (deftest do.19 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do () (t x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do.20 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x (expand-in-current-env (%m 0)) (+ x 2))) ((> x 10) result) (push x result)))) (10 8 6 4 2 0)) (deftest do.21 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x 0 (expand-in-current-env (%m (+ x 2))))) ((> x 10) result) (push x result)))) (10 8 6 4 2 0)) (deftest do.22 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x 0 (+ x 2))) ((expand-in-current-env (%m (> x 10))) result) (push x result)))) (10 8 6 4 2 0)) (deftest do.23 (let ((result nil)) (macrolet ((%m (z) z)) (do ((x 0 (+ x 2))) ((> x 10) (expand-in-current-env (%m result))) (push x result)))) (10 8 6 4 2 0)) (def-macro-test do.error.1 (do ((i 0 (1+ i))) ((= i 5) 'a))) gcl-2.7.1/ansi-tests/PaxHeaders/loop16.lsp0000644000000000000000000000013214542551763015312 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.637789821 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop16.lsp0000644000175000017500000001226414542551763014715 0ustar00cammcamm;-*- 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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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 (let () (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.7.1/ansi-tests/PaxHeaders/defclass.lsp0000644000000000000000000000013214542551762015755 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.637789821 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defclass.lsp0000644000175000017500000000066414542551762015361 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 24 03:39:54 2003 ;;;; Contains: Tests of DEFCLASS (in-package :cl-test) (defclass-with-tests defclass-1 nil nil) (defclass-with-tests defclass-2 nil (slot1 slot2 slot3)) (defclass-with-tests defclass-3 (defclass-1) nil) (defclass-with-tests defclass-4 (defclass-1 defclass-2) (slot1 slot4)) ;;; At end, generate slot tests (generate-slot-tests) ;; a macro gcl-2.7.1/ansi-tests/PaxHeaders/map.lsp0000644000000000000000000000013214542551763014747 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.637789821 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/map.lsp0000644000175000017500000002455614542551763014361 0ustar00cammcamm;-*- 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.37 (map 'simple-string #'identity '(#\a #\b #\c)) "abc") (deftest map.38 (map '(simple-string) #'identity '(#\a #\b #\c)) "abc") (deftest map.39 (map '(simple-string *) #'identity '(#\a #\b #\c)) "abc") (deftest map.40 (map '(simple-string 3) #'identity '(#\a #\b #\c)) "abc") (deftest map.41 (map '(base-string) #'identity '(#\a #\b #\c)) "abc") (deftest map.42 (map '(base-string *) #'identity '(#\a #\b #\c)) "abc") (deftest map.43 (map '(base-string 3) #'identity '(#\a #\b #\c)) "abc") (deftest map.44 (map 'simple-base-string #'identity '(#\a #\b #\c)) "abc") (deftest map.45 (map '(simple-base-string) #'identity '(#\a #\b #\c)) "abc") (deftest map.46 (map '(simple-base-string *) #'identity '(#\a #\b #\c)) "abc") (deftest map.47 (map '(simple-base-string 3) #'identity '(#\a #\b #\c)) "abc") (deftest map.48 :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector t 10) (vector t 5)))) (if (subtypep type '(vector t)) (equalpt (map type #'identity '(1 2 3 4 5)) #(1 2 3 4 5)) t)) t) ;;; Error tests (deftest map.error.1 (signals-error-always (map 'symbol #'identity '(a b c)) type-error) t t) (deftest map.error.1a (signals-error (map 'symbol #'identity '(a b c)) type-error) t) (deftest map.error.2 (signals-error (map '(vector * 8) #'identity '(a b c)) type-error) t) (deftest map.error.3 (signals-error (map 'list #'identity '(a b . c)) type-error) t) (deftest map.error.4 (signals-error (map) program-error) t) (deftest map.error.5 (signals-error (map 'list) program-error) t) (deftest map.error.6 (signals-error (map 'list #'null) program-error) t) (deftest map.error.7 (signals-error (map 'list #'cons '(a b c d)) program-error) t) (deftest map.error.8 (signals-error (map 'list #'cons '(a b c d) '(1 2 3 4) '(5 6 7 8)) program-error) t) (deftest map.error.9 (signals-error (map 'list #'car '(a b c d)) type-error) t) (deftest map.error.10 :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector bit) (vector t)))) (if (subtypep type 'vector) (eval `(signals-error-always (map ',type #'identity '(1 0 1)) error)) (values t t))) t t) (deftest map.error.11 (let ((type '(or (vector t 5) (vector t 10)))) (if (subtypep type 'vector) (eval `(signals-error (map ',type #'identity '(1 2 3 4 5 6)) type-error)) t)) t) (deftest map.error.12 (check-type-error #'(lambda (x) (map 'list #'identity x)) #'sequencep) nil) (deftest map.error.13 (check-type-error #'(lambda (x) (map 'vector #'cons '(a b c d) x)) #'sequencep) nil) ;;; 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)) ;;; Specialized string tests (deftest map.specialized-string.1 (do-special-strings (s "abcde" nil) (let ((s2 (map 'list #'identity s))) (assert (equal s2 '(#\a #\b #\c #\d #\e))))) nil) (deftest map.specialized-string.2 (do-special-strings (s "abcde" nil) (let ((s2 (map 'list #'(lambda (x y) y) '(1 2 3 4 5) s))) (assert (equal s2 '(#\a #\b #\c #\d #\e))))) nil) (deftest map.specialized-string.3 (let ((s (map 'base-string #'identity '(#\a #\b #\c)))) (assert (typep s 'base-string)) s) "abc") ;;; FIXME: Add tests for building strings of other character types ;;; Special vector types (deftest map.specialized-vector.1 (do-special-integer-vectors (v #(0 1 1 0 0 1) nil) (assert (equal (map 'list #'list v v) '((0 0) (1 1) (1 1) (0 0) (0 0) (1 1))))) nil) (deftest map.specialized-vector.2 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (equal (map 'list #'identity v) '(1 2 3 4 5 6 7)))) nil) (deftest map.specialized-vector.3 (do-special-integer-vectors (v #(-1 -2 -3 -4 -5 -6 -7) nil) (assert (equal (map 'list #'- v) '(1 2 3 4 5 6 7)))) nil) (deftest map.specialized-vector.4 (loop for i from 1 to 40 for type = `(unsigned-byte ,i) for bound = (ash 1 i) for len = 10 for vals = (loop repeat len collect (random i)) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list i vals result)) nil) (deftest map.specialized-vector.5 (loop for i from 1 to 40 for type = `(signed-byte ,i) for bound = (ash 1 i) for len = 10 for vals = (loop repeat len collect (- (random i) (/ bound 2))) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list i vals result)) nil) (deftest map.specialized-vector.6 (loop for type in '(short-float single-float long-float double-float) for len = 10 for vals = (loop for i from 1 to len collect (coerce i type)) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list type vals result)) nil) (deftest map.specialized-vector.7 (loop for etype in '(short-float single-float long-float double-float integer rational) for type = `(complex ,etype) for len = 10 for vals = (loop for i from 1 to len collect (complex (coerce i etype) (coerce (- i) etype))) for result = (map `(vector ,type) #'identity vals) unless (and (= (length result) len) (every #'eql vals result)) collect (list type vals result)) nil) ;;; 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) ;;; Constant folding test (def-fold-test map.fold.1 (map 'vector #'identity '(a b c))) gcl-2.7.1/ansi-tests/PaxHeaders/count.lsp0000644000000000000000000000013214542551762015321 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.637789821 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/count.lsp0000644000175000017500000003735214542551762014731 0ustar00cammcamm;-*- 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) (deftest count-list.17 (count 10 '(1 11 2 4 14 5 18 6 7) :test #'<) 3) (deftest count-list.18 (count 10 '(1 11 2 4 14 5 18 6 7) :test-not #'>=) 3) (defharmless count-list.test-and-test-not.1 (count 0 '(0 1 2 0 1 2 3 0 1) :test #'eql :test-not #'eql)) (defharmless count-list.test-and-test-not.2 (count 0 '(0 1 2 0 1 2 3 0 1) :test-not #'eql :test #'eql)) ;;; 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-vector.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) (deftest count-vector.17 (count 10 #(1 11 2 4 14 5 18 6 7) :test #'<) 3) (deftest count-vector.18 (count 10 #(1 11 2 4 14 5 18 6 7) :test-not #'>=) 3) (defharmless count-vector.test-and-test-not.1 (count 0 #(0 1 2 0 1 2 3 0 1) :test #'eql :test-not #'eql)) (defharmless count-vector.test-and-test-not.2 (count 0 #(0 1 2 0 1 2 3 0 1) :test-not #'eql :test #'eql)) ;;; 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) ;;; Other specialized vectors (deftest count.special-vector.1 (do-special-integer-vectors (v #(0 1 1 0 1 1 1 0 1 1 1 1 0) nil) (assert (eql (count 0 v) 4)) (assert (eql (count 1 v) 9)) (assert (eql (count 2 v) 0)) (assert (eql (count 0 v :start 2) 3)) (assert (eql (count 1 v :end 11) 8))) nil) (deftest count.special-vector.2 (do-special-integer-vectors (v #(1 2 3 4 5 6 7) nil) (assert (eql (count 0 v) 0)) (assert (eql (count 1 v) 1)) (assert (eql (count 2 v) 1)) (assert (eql (count 3 v) 1)) (assert (eql (count 4 v) 1)) (assert (eql (count 5 v) 1)) (assert (eql (count 6 v) 1)) (assert (eql (count 7 v) 1))) nil) (deftest count.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for e in '(0 1 2 1 3 1 4 5 6 0) collect (coerce e etype)) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count (coerce 1 etype) vec) unless (= result 3) collect (list etype vals vec result)) nil) (deftest count.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float rational integer) for etype = `(complex ,cetype) for vals = (loop for e in '(4 1 2 1 3 1 4 5 6 6) collect (complex 0 (coerce e cetype))) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count (complex 0 (coerce 1 cetype)) vec) unless (= result 3) collect (list etype vals vec result)) nil) ;;; 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) (deftest count-bit-vector.21 (count 1 #*00001100100 :test #'<=) 3) (deftest count-bit-vector.22 (count 1 #*00001100100 :test-not #'>) 3) (defharmless count-bit-vector.test-and-test-not.1 (count 0 #*0011010101100010000 :test #'eql :test-not #'eql)) (defharmless count-bit-vector.test-and-test-not.2 (count 0 #*0011010101100010000 :test-not #'eql :test #'eql)) ;;; 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) (deftest count-string.21 (count #\1 "00001100100" :test #'char<=) 3) (deftest count-string.22 (count #\1 "00001100100" :test-not #'char>) 3) (deftest count-string.23 (do-special-strings (s "a1a3abcda" nil) (assert (= (count #\a s) 4))) nil) (defharmless count-string.test-and-test-not.1 (count #\0 "0011010101100010000" :test #'eql :test-not #'eql)) (defharmless count-string.test-and-test-not.2 (count #\0 "0011010101100010000" :test-not #'eql :test #'eql)) ;;; 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 (check-type-error #'(lambda (x) (count 'a x)) #'sequencep) nil) (deftest count.error.4 (signals-error (count) program-error) t) (deftest count.error.5 (signals-error (count nil) program-error) t) (deftest count.error.6 (signals-error (count nil nil :bad t) program-error) t) (deftest count.error.7 (signals-error (count nil nil :bad t :allow-other-keys nil) program-error) t) (deftest count.error.8 (signals-error (count nil nil :key) program-error) t) (deftest count.error.9 (signals-error (count nil nil 3 3) program-error) t) ;;; Only leftmost :allow-other-keys argument matters (deftest count.error.10 (signals-error (count 'a nil :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest count.error.11 (signals-error (locally (count 'a 1) t) type-error) t) (deftest count.error.12 (signals-error (count 'b '(a b c) :test #'identity) program-error) t) (deftest count.error.13 (signals-error (count 'b '(a b c) :key #'car) type-error) t) (deftest count.error.14 (signals-error (count 'b '(a b c) :test-not #'identity) program-error) t) (deftest count.error.15 (signals-error (count 'b '(a b c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/namestring.lsp0000644000000000000000000000013114542551763016340 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.637789821 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/namestring.lsp0000644000175000017500000000361314542551763015742 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/dostar.lsp0000644000000000000000000000013214542551762015465 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.637789821 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/dostar.lsp0000644000175000017500000000712314542551762015066 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 07:26:22 2005 ;;;; Contains: Tests of DO* (in-package :cl-test) (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)) ;;; Scope of free declarations (deftest do*.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do* ((i (return-from done x) 0)) (t nil) (declare (special x)))))) :good) (deftest do*.17 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do* ((i 0 (return-from done x))) (nil nil) (declare (special x)))))) :good) (deftest do*.18 (block done (let ((x :good)) (declare (special x)) (let ((x :bad)) (do* ((i 0 0)) ((return-from done x) nil) (declare (special x)))))) :good) (deftest do*.19 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do* () (t x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do*.20 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x (expand-in-current-env (%m 1)) (1+ x))) ((> x 10) result) (incf result x)))) 55) (deftest do*.21 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x 1 (expand-in-current-env (%m (1+ x))))) ((> x 10) result) (incf result x)))) 55) (deftest do*.22 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x 1 (1+ x))) ((expand-in-current-env (%m (> x 10))) result) (incf result x)))) 55) (deftest do*.23 (let ((result 0)) (macrolet ((%m (z) z)) (do* ((x 1 (1+ x))) ((> x 10) (expand-in-current-env (%m result))) (incf result x)))) 55) (def-macro-test do*.error.1 (do* ((i 0 (1+ i))) ((= i 5) 'a))) gcl-2.7.1/ansi-tests/PaxHeaders/user-homedir-pathname.lsp0000644000000000000000000000013214542551763020370 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.637789821 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/user-homedir-pathname.lsp0000644000175000017500000000225614542551763017773 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 11 22:26:24 2004 ;;;; Contains: Tests of USER-HOMEDIR-PATHNAME (in-package :cl-test) (deftest user-homedir-pathname.1 (let ((pn (user-homedir-pathname))) (notnot pn)) t) (deftest user-homedir-pathname.2 (let* ((pn-list (multiple-value-list (user-homedir-pathname))) (pn (first pn-list))) (values (length pn-list) (notnot-mv (pathnamep pn)))) 1 t) (deftest user-homedir-pathname.3 (let ((pn (user-homedir-pathname))) (pathname-name pn)) nil) (deftest user-homedir-pathname.4 (let ((pn (user-homedir-pathname))) (pathname-type pn)) nil) (deftest user-homedir-pathname.5 (let ((pn (user-homedir-pathname))) (pathname-version pn)) nil) ;; (deftest user-homedir-pathname.6 ;; (let* ((pn (user-homedir-pathname)) ;; (host (pathname-host pn))) ;; (or (not host) ;; (equalt pn (user-homedir-pathname host)))) ;; t) (deftest user-homedir-pathname.7 (let* ((pn (user-homedir-pathname :unspecific))) (or (null pn) (notnot (pathnamep pn)))) t) (deftest user-homedir-pathname.error.1 (signals-error (user-homedir-pathname :unspecific nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/nset-exclusive-or.lsp0000644000000000000000000000013114542551763017565 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.637789821 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nset-exclusive-or.lsp0000644000175000017500000002154414542551763017172 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:47:05 2003 ;;;; Contains: Tests of NSET-EXCLUSIVE-OR (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (defharmless nset-exclusive-or.test-and-test-not.1 (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) (defharmless nset-exclusive-or.test-and-test-not.2 (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) ;;; 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) ;;; Randomized test (deftest random-nset-exclusive-or (random-set-exclusive-or-test 10 1000 'nset-exclusive-or) nil) ;;; Error tests (deftest nset-exclusive-or.error.1 (signals-error (nset-exclusive-or) program-error) t) (deftest nset-exclusive-or.error.2 (signals-error (nset-exclusive-or nil) program-error) t) (deftest nset-exclusive-or.error.3 (signals-error (nset-exclusive-or nil nil :bad t) program-error) t) (deftest nset-exclusive-or.error.4 (signals-error (nset-exclusive-or nil nil :key) program-error) t) (deftest nset-exclusive-or.error.5 (signals-error (nset-exclusive-or nil nil 1 2) program-error) t) (deftest nset-exclusive-or.error.6 (signals-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nset-exclusive-or.error.7 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest nset-exclusive-or.error.8 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest nset-exclusive-or.error.9 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest nset-exclusive-or.error.10 (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest nset-exclusive-or.error.11 (signals-error (nset-exclusive-or (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest nset-exclusive-or.error.12 (signals-error (nset-exclusive-or (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nset-exclusive-or.error.13 (check-type-error #'(lambda (x) (nset-exclusive-or x (list 'a 'b))) #'listp) nil) (deftest nset-exclusive-or.error.14 (check-type-error #'(lambda (x) (nset-exclusive-or (list 'a 'b) x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/define-condition-aux.lsp0000644000000000000000000000013214542551762020202 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.641789838 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-condition-aux.lsp0000644000175000017500000000560614542551762017607 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 9 05:40:13 2003 ;;;; Contains: Auxiliary functions for testing DEFINE-CONDITION (in-package :cl-test) (defun make-def-cond-name (name &rest suffixes) (intern (apply #'concatenate 'string (string name) "/" (mapcar #'string suffixes)) :cl-test)) (defmacro define-condition-with-tests (name-symbol parents slot-specs &rest options) "Create a condition and some associated tests." (assert (symbolp name-symbol)) (dolist (parent parents) (assert (symbolp parent))) (let ((name (symbol-name name-symbol))) `(eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (eval '(define-condition ,name-symbol ,parents ,slot-specs ,@options))) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) (subtypep* ',name-symbol ',parent) t t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) (check-all-subtypep ',name-symbol ',parent) nil)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-NOT-SUPERTYPE-OF/" parent) (subtypep* ',parent ',name-symbol) nil t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-A/" parent) (let ((c (make-condition ',name-symbol))) (notnot-mv (typep c ',parent))) t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) (subtypep* (find-class ',name-symbol) (find-class ',parent)) t t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-NOT-SUPERCLASS-OF/" parent) (subtypep* (find-class ',parent) (find-class ',name-symbol)) nil t)) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" parent) (let ((c (make-condition ',name-symbol))) (notnot-mv (typep c (find-class ',parent)))) t)) (deftest ,(make-def-cond-name name "HANDLER-CASE-1") (let ((c (make-condition ',name-symbol))) (handler-case (normally (signal c)) (,name-symbol (c1) (eqt c c1)))) t) (deftest ,(make-def-cond-name name "HANDLER-CASE-2") (let ((c (make-condition ',name-symbol))) (handler-case (normally (signal c)) (condition (c1) (eqt c c1)))) t) ,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) `((deftest ,(make-def-cond-name name "HANDLER-CASE-3") (let ((c (make-condition ',name-symbol))) (handler-case (normally (signal c)) (error () nil) (,name-symbol (c2) (eqt c c2)))) t))) ))) gcl-2.7.1/ansi-tests/PaxHeaders/copy-symbol.lsp0000644000000000000000000000013214542551762016446 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.641789838 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/copy-symbol.lsp0000644000175000017500000000427614542551762016055 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:44:41 2003 ;;;; Contains: Tests of COPY-SYMBOL (in-package :cl-test) (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) ;;; Error tests (deftest copy-symbol.error.1 (signals-error (copy-symbol) program-error) t) (deftest copy-symbol.error.2 (signals-error (copy-symbol 'a t 'foo) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/inspect.lsp0000644000000000000000000000013114542551762015635 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.641789838 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/inspect.lsp0000644000175000017500000000066014542551762015236 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 15 12:54:22 2005 ;;;; Contains: Tests of INSPECT (in-package :cl-test) ;;; INSPECT's normal behavior is entirely implementation-dependent, ;;; so it cannot be tested here. Only test simple error cases. (deftest inspect.error.1 (signals-error (inspect) program-error) t) (deftest inspect.error.2 (signals-error (inspect nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/aref.lsp0000644000000000000000000000013214542551762015106 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.641789838 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/aref.lsp0000644000175000017500000000653514542551762014515 0ustar00cammcamm;-*- 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.special-integer.1 (do-special-integer-vectors (v #(1 1 0 1 0 1) nil) (assert (= (aref v 0) 1)) (assert (= (aref v 1) 1)) (assert (= (aref v 2) 0)) (assert (= (aref v 3) 1)) (assert (= (aref v 4) 0)) (assert (= (aref v 5) 1))) nil) (deftest aref.special-strings.1 (do-special-strings (s "ABCDE" nil) (assert (eql (aref s 0) #\A)) (assert (eql (aref s 1) #\B)) (assert (eql (aref s 2) #\C)) (assert (eql (aref s 3) #\D)) (assert (eql (aref s 4) #\E))) nil) ;;; Error tests (deftest aref.error.1 (signals-error (aref) program-error) t) (deftest aref.error.2 (signals-error (funcall #'aref) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/complex.lsp0000644000000000000000000000013014542551762015636 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.641789838 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/complex.lsp0000644000175000017500000000236414542551762015243 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 19:56:29 2003 ;;;; Contains: Tests of COMPLEX (in-package :cl-test) ;;; Error tests (deftest complex.error.1 (signals-error (complex) program-error) t) (deftest complex.error.2 (signals-error (complex 1 1 nil) program-error) t) ;;; Non-error tests (deftest complex.1 (loop for x in *rationals* for c = (complex x) always (eql c x)) t) (deftest complex.2 (loop for x in *floats* for c = (complex x) always (and (complexp c) (eql x (realpart c)) (eql (float 0 x) (imagpart c)))) t) (deftest complex.3 (loop for x in *rationals* for c = (complex 0 x) unless (or (zerop x) (and (complexp c) (eql (realpart c) 0) (eql (imagpart c) x))) collect (list c x)) nil) (deftest complex.4 (loop for x in *floats* for c = (complex 0 x) always (and (complexp c) (eql (float 0 x) (realpart c)) (eql x (imagpart c)))) t) ;;; Tests of some properties of complex numbers (deftest complex.5 (loop for c in *complexes* unless (loop for type in '(short-float single-float double-float long-float) always (if (typep (realpart c) type) (typep (imagpart c) type) (not (typep (imagpart c) type)))) collect c) nil) gcl-2.7.1/ansi-tests/PaxHeaders/abort.lsp0000644000000000000000000000013214542551762015300 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.641789838 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/abort.lsp0000644000175000017500000000213514542551762014677 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 08:25:50 2003 ;;;; Contains: Tests of the ABORT restart and function (in-package :cl-test) (deftest abort.1 (restart-case (progn (abort) 'bad) (abort () 'good)) good) (deftest abort.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (abort c2)) (abort () 'bad) (abort () 'good))) good) (deftest abort.3 (restart-case (progn (abort nil) 'bad) (abort () 'good)) good) (deftest abort.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (abort nil)) (abort () 'good) (abort () 'bad))) good) (deftest abort.5 (signals-error (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (abort c2))) control-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/floatp.lsp0000644000000000000000000000013214542551762015456 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.641789838 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/floatp.lsp0000644000175000017500000000075414542551762015062 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 23:07:33 2003 ;;;; Contains: Tests of FLOATP (in-package :cl-test) ;;; Error tests (deftest floatp.error.1 (signals-error (floatp) program-error) t) (deftest floatp.error.2 (signals-error (floatp 1.0 nil) program-error) t) ;;; Non-error tests (deftest floatp.1 (notnot-mv (floatp 1.0)) t) (deftest floatp.2 (floatp nil) nil) (deftest floatp.3 (check-type-predicate #'floatp 'float) nil) gcl-2.7.1/ansi-tests/PaxHeaders/with-package-iterator.lsp0000644000000000000000000000013214542551763020365 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.641789838 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-package-iterator.lsp0000644000175000017500000001124214542551763017763 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:03:36 1998 ;;;; Contains: Tests of WITH-PACKAGE-ITERATOR (in-package :cl-test) (declaim (optimize (safety 3))) (compile-and-load "package-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 (progn (set-up-packages) (with-package-iterator-all '("A"))) t) (deftest with-package-iterator.6 (progn (set-up-packages) (with-package-iterator-all '(#:|A|))) t) (deftest with-package-iterator.7 (progn (set-up-packages) (with-package-iterator-all '(#\A))) t) (deftest with-package-iterator.8 (progn (set-up-packages) (with-package-iterator-internal (list (find-package "A")))) t) (deftest with-package-iterator.9 (progn (set-up-packages) (with-package-iterator-external (list (find-package "A")))) t) (deftest with-package-iterator.10 (progn (set-up-packages) (with-package-iterator-inherited (list (find-package "A")))) t) (deftest with-package-iterator.11 (signals-error (with-package-iterator (x "COMMON-LISP-USER")) program-error) t) (defun t-count (x) (if (eq x t) nil x)) ;;; 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 (eq t (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 (eq t (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 (eq t (with-package-iterator-inherited (list p))))) (error (c) (format t "Error ~S on package ~S~%" c p) t))) 0) (def-macro-test with-package-iterator.error.1 (with-package-iterator (x "CL" :external) nil)) ;;; Specialized sequence tests (defmacro def-with-package-iterator-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let* ((p (make-package name :use nil)) (result nil) (s (intern "X" p))) (with-package-iterator (x name :internal) (loop (multiple-value-bind (good? sym) (x) (unless good? (safely-delete-package name) (return (equalt (list s) result))) (push sym result)))))) t)) (def-with-package-iterator-test with-package-iterator.15 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.16 (make-array 8 :initial-contents "TEST1XXX" :fill-pointer 5 :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.17 (make-array 8 :initial-contents "TEST1XXX" :fill-pointer 5 :element-type 'character)) (def-with-package-iterator-test with-package-iterator.18 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.19 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-with-package-iterator-test with-package-iterator.20 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "XTEST1YzYY" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-with-package-iterator-test with-package-iterator.21 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "XTEST1YzYY" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope (deftest with-package-iterator.22 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-package-iterator (s (return-from done x) :internal) (declare (special x)))))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/nreverse.lsp0000644000000000000000000000013114542551763016022 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.645789856 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nreverse.lsp0000644000175000017500000000756014542551763015431 0ustar00cammcamm;-*- 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-vector.4 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (nreverse x)) #()) (deftest nreverse-vector.5 (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-vector.6 (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) ;;; Unusual vectors (deftest nreverse-vector.7 (do-special-integer-vectors (v #(0 0 1 0 1 1) nil) (let ((nv (nreverse v))) (assert (= (length nv) 6)) (assert (every #'= nv #(1 1 0 1 0 0))))) nil) (deftest nreverse-vector.8 (do-special-integer-vectors (v #(0 0 -1 0 -1 -1 0 -1) nil) (let ((nv (nreverse v))) (assert (= (length nv) 8)) (assert (every #'= nv #(-1 0 -1 -1 0 -1 0 0))))) nil) (deftest nreverse-vector.9 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i from 1 to len collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (nreverse vec) unless (and (eql (length nvec) len) (every #'eql (reverse vals) nvec)) collect (list etype vals nvec))) nil) (deftest nreverse-vector.10 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float rational integer) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for nvec = (nreverse vec) unless (and (eql (length nvec) len) (every #'eql (reverse vals) nvec)) collect (list etype vals nvec))) nil) ;;; Bit vectors (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) ;;; Strings (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-string.5 (do-special-strings (s (copy-seq "12345") nil) (let ((s2 (nreverse s))) (assert (stringp s2)) (assert (string= s2 "54321")) (assert (equal (array-element-type s) (array-element-type s2))))) nil) ;;; Argument is evaluated only once (deftest nreverse.order.1 (let ((i 0)) (values (nreverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) ;;; Error tests (deftest nreverse.error.1 (check-type-error #'nreverse #'sequencep) nil) (deftest nreverse.error.6 (signals-error (nreverse) program-error) t) (deftest nreverse.error.7 (signals-error (nreverse nil nil) program-error) t) (deftest nreverse.error.8 (signals-error (locally (nreverse 'a) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/with-open-file.lsp0000644000000000000000000000013214542551763017021 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.645789856 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-open-file.lsp0000644000175000017500000000447614542551763016432 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/loop4.lsp0000644000000000000000000000013214542551763015227 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.645789856 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop4.lsp0000644000175000017500000000370614542551763014633 0ustar00cammcamm;-*- 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 (signals-error (loop for (x . x) = '(nil nil nil) until x count t) program-error) t) (deftest loop.4.7 (signals-error (macroexpand '(loop for (x . x) = '(nil nil nil) until x count t)) program-error) t) (deftest loop.4.8 (signals-error (macroexpand '(loop for x = '(nil nil nil) for x = 1 count x until t)) program-error) t) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.4.9 (macrolet ((%m (z) z)) (loop for x = (expand-in-current-env (%m 1)) then (1+ x) until (> x 5) collect x)) (1 2 3 4 5)) (deftest loop.4.10 (macrolet ((%m (z) z)) (loop for x = 1 then (expand-in-current-env (%m (1+ x))) until (> x 5) collect x)) (1 2 3 4 5)) (deftest loop.4.11 (macrolet ((%m (z) z)) (loop for x = 1 then (1+ x) until (expand-in-current-env (%m (> x 5))) collect x)) (1 2 3 4 5)) (deftest loop.4.12 (macrolet ((%m (z) z)) (loop for x = 1 then (1+ x) while (expand-in-current-env (%m (<= x 5))) collect x)) (1 2 3 4 5)) (deftest loop.4.13 (macrolet ((%m (z) z)) (loop for x = 1 then (1+ x) until (> x 5) collect (expand-in-current-env (%m x)))) (1 2 3 4 5)) gcl-2.7.1/ansi-tests/PaxHeaders/define-condition.lsp0000644000000000000000000000013214542551762017407 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.645789856 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-condition.lsp0000644000175000017500000005042614542551762017014 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 8 22:38:53 2003 ;;;; Contains: Tests of DEFINE-CONDITION (part 1) (in-package :cl-test) ;;; (define-condition-with-tests condition-1 nil nil) (define-condition-with-tests condition-2 (condition) nil) #-gcl (define-condition-with-tests #:condition-3 nil nil) (define-condition-with-tests condition-4 nil ((slot1 :initarg :slot1 :reader condition-4/slot-1) (slot2 :initarg :slot2 :reader condition-4/slot-2))) (deftest condition-4-slots.1 (let ((c (make-condition 'condition-4 :slot1 'a :slot2 'b))) (and (typep c 'condition-4) (eqlt (condition-4/slot-1 c) 'a) (eqlt (condition-4/slot-2 c) 'b))) t) (define-condition-with-tests condition-5 nil ((slot1 :initarg :slot1 :initform 'x :reader condition-5/slot-1) (slot2 :initarg :slot2 :initform 'y :reader condition-5/slot-2))) (deftest condition-5-slots.1 (let ((c (make-condition 'condition-5 :slot1 'a :slot2 'b))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'b))) t) (deftest condition-5-slots.2 (let ((c (make-condition 'condition-5 :slot1 'a))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'y))) t) (deftest condition-5-slots.3 (let ((c (make-condition 'condition-5 :slot2 'b))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'b))) t) (deftest condition-5-slots.4 (let ((c (make-condition 'condition-5))) (and (typep c 'condition-5) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'y))) t) (define-condition-with-tests condition-6 nil ((slot1 :initarg :slot1 :initarg :both-slots :initform 'x :reader condition-6/slot-1) (slot2 :initarg :slot2 :initarg :both-slots :initform 'y :reader condition-6/slot-2))) (deftest condition-6-slots.1 (let ((c (make-condition 'condition-6 :both-slots 'a))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'a))) t) (deftest condition-6-slots.2 (let ((c (make-condition 'condition-6))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'x) (eqlt (condition-6/slot-2 c) 'y))) t) (deftest condition-6-slots.3 (let ((c (make-condition 'condition-6 :slot1 'a :both-slots 'b))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'b))) t) (deftest condition-6-slots.4 (let ((c (make-condition 'condition-6 :slot2 'b :both-slots 'a))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'b))) t) (deftest condition-6-slots.5 (let ((c (make-condition 'condition-6 :both-slots 'a :slot1 'c :slot2 'd))) (and (typep c 'condition-6) (eqlt (condition-6/slot-1 c) 'a) (eqlt (condition-6/slot-2 c) 'a))) t) (define-condition-with-tests condition-7 nil ((s :initarg :i1 :initarg :i2 :reader condition-7/s))) (deftest condition-7-slots.1 (let ((c (make-condition 'condition-7 :i1 'a))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.2 (let ((c (make-condition 'condition-7 :i2 'a))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.3 (let ((c (make-condition 'condition-7 :i1 'a :i2 'b))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.4 (let ((c (make-condition 'condition-7 :i2 'a :i1 'b))) (and (typep c 'condition-7) (eqlt (condition-7/s c) 'a))) t) (defparameter *condition-8-counter* 0) (define-condition-with-tests condition-8 nil ((s :initarg :i1 :initform (incf *condition-8-counter*) :reader condition-8/s))) (deftest condition-8-slots.1 (let ((*condition-8-counter* 100)) (declare (special *condition-8-counter*)) (values (condition-8/s (make-condition 'condition-8)) *condition-8-counter*)) 101 101) (define-condition-with-tests condition-9 nil ((s1 :initarg :i1 :initform 15 :reader condition-9/s1) (s2 :initarg :i2 :initform 37 :reader condition-9/s2))) (deftest condition-9-slots.1 (let ((c (make-condition 'condition-9))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 15 37) (deftest condition-9-slots.2 (let ((c (make-condition 'condition-9 :i1 3))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 3 37) (deftest condition-9-slots.3 (let ((c (make-condition 'condition-9 :i2 3))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 15 3) (deftest condition-9-slots.4 (let ((c (make-condition 'condition-9 :i2 3 :i2 8))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 15 3) (deftest condition-9-slots.5 (let ((c (make-condition 'condition-9 :i1 3 :i2 8))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 3 8) (deftest condition-9-slots.6 (let ((c (make-condition 'condition-9 :i1 3 :i2 8 :i1 100 :i2 500))) (values (notnot (typep c 'condition-9)) (condition-9/s1 c) (condition-9/s2 c))) t 3 8) ;;; (define-condition-with-tests condition-10 nil ;;; ((s1 :initarg :i1 :writer condition-10/s1-w :reader condition-10/s1-r))) ;;; ;;; (deftest condition-10-slots.1 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-r c)) ;;; 11) ;;; ;;; (deftest condition-10-slots.2 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-w 17 c)) ;;; 17) ;;; ;;; (deftest condition-10-slots.3 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-w 107 c) ;;; (condition-10/s1-r c)) ;;; 107) ;;; ;;; (define-condition-with-tests condition-11 nil ;;; ((s1 :initarg :i1 :writer (setf condition-11/w) :reader condition-11/r))) ;;; ;;; (deftest condition-11-slots.1 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (condition-11/r c)) ;;; 11) ;;; ;;; (deftest condition-11-slots.2 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (setf (condition-11/w c) 17)) ;;; 17) ;;; ;;; (deftest condition-11-slots.3 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (setf (condition-11/w c) 117) ;;; (condition-11/r c)) ;;; 117) ;;; ;;; (deftest condition-11-slots.4 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (values ;;; (funcall #'(setf condition-11/w) 117 c) ;;; (condition-11/r c))) ;;; 117 117) ;;; The condition-12 and condition-13 tests have been removed. Duane Rettig ;;; convincingly argued that the feature being tested (non-symbol ;;; slot names) remains in the standard only because of editing errors. ;;; (define-condition-with-tests condition-12 nil ;;; (((slot1) :initarg :slot1 :reader condition-12/slot-1) ;;; ((slot2) :initarg :slot2 :reader condition-12/slot-2))) ;;; ;;; (deftest condition-12-slots.1 ;;; (let ((c (make-condition 'condition-12 :slot1 'a :slot2 'b))) ;;; (and (typep c 'condition-12) ;;; (eqlt (condition-12/slot-1 c) 'a) ;;; (eqlt (condition-12/slot-2 c) 'b))) ;;; t) ;;; ;;; (define-condition-with-tests condition-13 nil ;;; (((slot1 10) :initarg :slot1 :reader condition-13/slot-1))) ;;; ;;; (deftest condition-13-slots.1 ;;; (let ((c (make-condition 'condition-13))) ;;; (and (typep c 'condition-13) ;;; (condition-13/slot-1 c))) ;;; 10) (define-condition-with-tests condition-14 nil ((s1 :initarg :i1 :type fixnum :reader condition-14/s1) (s2 :initarg :i2 :type t :reader condition-14/s2))) (deftest condition-14-slots.1 (let ((c (make-condition 'condition-14 :i1 10))) (and (typep c 'condition-14) (condition-14/s1 c))) 10) (deftest condition-14-slots.2 (let ((c (make-condition 'condition-14 :i2 'a))) (and (typep c 'condition-14) (condition-14/s2 c))) a) (deftest condition-14-slots.3 (let ((c (make-condition 'condition-14 :i1 10 :i2 'h))) (and (typep c 'condition-14) (eqlt (condition-14/s1 c) 10) (condition-14/s2 c))) h) (define-condition-with-tests condition-15 nil ((s1 :type nil))) (define-condition-with-tests condition-16 nil ((slot1)) (:report "The report for condition-16")) (deftest condition-16-report.1 (let ((*print-escape* nil) (c (make-condition 'condition-16))) (with-output-to-string (s) (print-object c s))) "The report for condition-16") (defun condition-17-report (c s) (format s "condition-17: ~A" (condition-17/s c))) (define-condition-with-tests condition-17 nil ((s :initarg :i1 :reader condition-17/s )) (:report condition-17-report)) (deftest condition-17-report.1 (let ((*print-escape* nil) (c (make-condition 'condition-17 :i1 1234))) (with-output-to-string (s) (print-object c s))) "condition-17: 1234") (define-condition-with-tests condition-18 nil ((s :initarg :i1 :reader condition-18/s )) (:report (lambda (c s) (format s "condition-18: ~A" (condition-18/s c))))) (deftest condition-18-report.1 (let ((*print-escape* nil) (c (make-condition 'condition-18 :i1 4321))) (with-output-to-string (s) (print-object c s))) "condition-18: 4321") ;;; ;;; Tests of :default-initargs ;;; ;;; There is an inconsistency in the ANSI spec. DEFINE-CONDITION ;;; says that in (:default-initargs . ), is a list of pairs. ;;; However, DEFCLASS says it's a list whose alternate elements ;;; are initargs and initforms. I have taken the second interpretation. ;;; (define-condition-with-tests condition-19 nil ((s1 :reader condition-19/s1 :initarg :i1) (s2 :reader condition-19/s2 :initarg :i2)) (:default-initargs :i1 10 :i2 20)) (deftest condition-19-slots.1 (let ((c (make-condition 'condition-19))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t 10 20) (deftest condition-19-slots.2 (let ((c (make-condition 'condition-19 :i1 'a))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t a 20) (deftest condition-19-slots.3 (let ((c (make-condition 'condition-19 :i2 'a))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t 10 a) (deftest condition-19-slots.4 (let ((c (make-condition 'condition-19 :i1 'x :i2 'y))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t x y) (deftest condition-19-slots.5 (let ((c (make-condition 'condition-19 :i2 'y :i1 'x))) (values (notnot (typep c 'condition-19)) (condition-19/s1 c) (condition-19/s2 c))) t x y) (defparameter *condition-20/s1-val* 0) (defparameter *condition-20/s2-val* 0) (define-condition-with-tests condition-20 nil ((s1 :reader condition-20/s1 :initarg :i1) (s2 :reader condition-20/s2 :initarg :i2)) (:default-initargs :i1 (incf *condition-20/s1-val*) :i2 (incf *condition-20/s2-val*))) (deftest condition-20-slots.1 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t 1 11 1 11) (deftest condition-20-slots.2 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i1 'x))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t x 11 0 11) (deftest condition-20-slots.3 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i2 'y))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t 1 y 1 10) (deftest condition-20-slots.4 (let ((*condition-20/s1-val* 0) (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i2 'y :i1 'x))) (values (notnot (typep c 'condition-20)) (condition-20/s1 c) (condition-20/s2 c) *condition-20/s1-val* *condition-20/s2-val*))) t x y 0 10) ;;;;;;;;; tests of inheritance (define-condition-with-tests condition-21 (condition-4) nil) (deftest condition-21-slots.1 (let ((c (make-condition 'condition-21 :slot1 'a :slot2 'b))) (and (typep c 'condition-4) (typep c 'condition-21) (eqlt (condition-4/slot-1 c) 'a) (eqlt (condition-4/slot-2 c) 'b))) t) (define-condition-with-tests condition-22 (condition-4) ((slot3 :initarg :slot3 :reader condition-22/slot-3) (slot4 :initarg :slot4 :reader condition-22/slot-4))) (deftest condition-22-slots.1 (let ((c (make-condition 'condition-22 :slot1 'a :slot2 'b :slot3 'c :slot4 'd))) (and (typep c 'condition-4) (typep c 'condition-22) (eqlt (condition-4/slot-1 c) 'a) (eqlt (condition-4/slot-2 c) 'b) (eqlt (condition-22/slot-3 c) 'c) (eqlt (condition-22/slot-4 c) 'd) )) t) (define-condition-with-tests condition-23 (condition-5) nil) (deftest condition-23-slots.1 (let ((c (make-condition 'condition-23 :slot1 'a :slot2 'b))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'b) )) t) (deftest condition-23-slots.2 (let ((c (make-condition 'condition-23 :slot1 'a))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'y) )) t) (deftest condition-23-slots.3 (let ((c (make-condition 'condition-23 :slot2 'b))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'b) )) t) (deftest condition-23-slots.4 (let ((c (make-condition 'condition-23))) (and (typep c 'condition-5) (typep c 'condition-23) (eqlt (condition-5/slot-1 c) 'x) (eqlt (condition-5/slot-2 c) 'y) )) t) (define-condition-with-tests condition-24 (condition-5) nil (:default-initargs :slot1 'z)) (deftest condition-24-slots.1 (let ((c (make-condition 'condition-24))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'z) (eqlt (condition-5/slot-2 c) 'y) )) t) (deftest condition-24-slots.2 (let ((c (make-condition 'condition-24 :slot1 'a))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'a) (eqlt (condition-5/slot-2 c) 'y) )) t) (deftest condition-24-slots.3 (let ((c (make-condition 'condition-24 :slot2 'a))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'z) (eqlt (condition-5/slot-2 c) 'a) )) t) (deftest condition-24-slots.4 (let ((c (make-condition 'condition-24 :slot1 'b :slot2 'a))) (and (typep c 'condition-5) (typep c 'condition-24) (eqlt (condition-5/slot-1 c) 'b) (eqlt (condition-5/slot-2 c) 'a) )) t) ;;; Multiple inheritance (define-condition-with-tests condition-25a nil ((s1 :initarg :s1 :initform 'a :reader condition-25a/s1))) (define-condition-with-tests condition-25b nil ((s2 :initarg :s2 :initform 'b :reader condition-25b/s2))) (define-condition-with-tests condition-25 (condition-25a condition-25b) ((s3 :initarg :s3 :initform 'c :reader condition-25/s3))) (deftest condition-25-slots.1 (let ((c (make-condition 'condition-25))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'a) (eqlt (condition-25b/s2 c) 'b) (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.2 (let ((c (make-condition 'condition-25 :s1 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'x) (eqlt (condition-25b/s2 c) 'b) (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.3 (let ((c (make-condition 'condition-25 :s2 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'a) (eqlt (condition-25b/s2 c) 'x) (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.4 (let ((c (make-condition 'condition-25 :s3 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'a) (eqlt (condition-25b/s2 c) 'b) (eqlt (condition-25/s3 c) 'x))) t) (deftest condition-25-slots.5 (let ((c (make-condition 'condition-25 :s3 'z :s2 'y :s1 'x))) (and (typep c 'condition-25a) (typep c 'condition-25b) (typep c 'condition-25) (eqlt (condition-25a/s1 c) 'x) (eqlt (condition-25b/s2 c) 'y) (eqlt (condition-25/s3 c) 'z))) t) ;;; (define-condition-with-tests condition-26a nil ((s1 :initarg :s1 :initform 'a :reader condition-26a/s1))) (define-condition-with-tests condition-26b (condition-26a) nil) (define-condition-with-tests condition-26c (condition-26a) nil) (define-condition-with-tests condition-26 (condition-26b condition-26c) nil) (deftest condition-26-slots.1 (let ((c (make-condition 'condition-26))) (and (typep c 'condition-26a) (typep c 'condition-26b) (typep c 'condition-26c) (typep c 'condition-26) (eqlt (condition-26a/s1 c) 'a))) t) (deftest condition-26-slots.2 (let ((c (make-condition 'condition-26 :s1 'x))) (and (typep c 'condition-26a) (typep c 'condition-26b) (typep c 'condition-26c) (typep c 'condition-26) (eqlt (condition-26a/s1 c) 'x))) t) ;;; Test that a slot reader is truly a generic function (define-condition-with-tests condition-27a nil ((s0 :initarg :s0 :initform 10 :reader condition-27a/s0) (s1 :initarg :s1 :initform 'a :reader condition-27/s1))) (define-condition-with-tests condition-27b nil ((s1 :initarg :s1 :initform 'a :reader condition-27/s1) (s2 :initarg :s2 :initform 16 :reader condition-27b/s2))) (deftest condition-27-slots.1 (let ((c (make-condition 'condition-27a))) (and (typep c 'condition-27a) (not (typep c 'condition-27b)) (eqlt (condition-27/s1 c) 'a))) t) (deftest condition-27-slots.2 (let ((c (make-condition 'condition-27b))) (and (typep c 'condition-27b) (not (typep c 'condition-27a)) (eqlt (condition-27/s1 c) 'a))) t) (deftest condition-27-reader-is-generic (notnot-mv (typep #'condition-27/s1 'generic-function)) t) ;;; More inheritance ;;; These test that condition slots are inherited like CLOS ;;; slots. It's not entirely clear to me if the standard ;;; demands this (one of the issues does, but that issue wasn't ;;; fully integrated into the standard.) #| (define-condition-with-tests condition-28a nil ((s1 :initarg :i1 :initform 'x :reader condition-28a/s1))) (define-condition-with-tests condition-28 (condition-28a) ((s1 :initarg :i1a :reader condition-28/s1))) (deftest condition-28-slots.1 (let ((c (make-condition 'condition-28))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'x) (eqlt (condition-28/s1 c) 'x))) t) (deftest condition-28-slots.2 (let ((c (make-condition 'condition-28 :i1 'z))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'z) (eqlt (condition-28/s1 c) 'z))) t) (deftest condition-28-slots.3 (let ((c (make-condition 'condition-28 :i1a 'w))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'w) (eqlt (condition-28/s1 c) 'w))) t) (deftest condition-28-slots.4 (let ((c (make-condition 'condition-28 :i1 'y :i1a 'w))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'y) (eqlt (condition-28/s1 c) 'y))) t) (deftest condition-28-slots.5 (let ((c (make-condition 'condition-28 :i1a 'y :i1 'w))) (and (typep c 'condition-28a) (typep c 'condition-28) (eqlt (condition-28a/s1 c) 'y) (eqlt (condition-28/s1 c) 'y))) t) |# ;;; Documentation ;;; Pitman says this should have been in the spec, but it isn't really ;;; (define-condition-with-tests condition-29 nil ;;; ((s1 :initarg :i1 :initform 'x ;;; :documentation "This is slot s1 in condition condition-29"))) (define-condition-with-tests condition-30 nil ((s1 :initarg :i1 :initform 'x)) (:documentation "This is class condition-30")) gcl-2.7.1/ansi-tests/PaxHeaders/modules7.lsp0000644000000000000000000000013114542551763015730 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.645789856 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/modules7.lsp0000644000175000017500000000006414542551763015327 0ustar00cammcamm(in-package :cl-test) (defun modules7-fun () :good) gcl-2.7.1/ansi-tests/PaxHeaders/sort-aux.lsp0000644000000000000000000000013214542551763015754 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.645789856 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sort-aux.lsp0000644000175000017500000000222314542551763015351 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jul 17 06:42:27 2003 ;;;; Contains: Routines for testing SORT, NSORT (in-package :cl-test) (defun my-numeric-sort (list) "Sort (nondestructively) a list of reals." (if (null (cdr list)) list (let* ((len2 (ash (length list) -1)) (l1 (my-numeric-sort (subseq list 0 len2))) (l2 (my-numeric-sort (subseq list len2)))) (my-numeric-merge l1 l2)))) (defun my-numeric-merge (l1 l2) (cond ((null l1) l2) ((null l2) l1) ((<= (car l1) (car l2)) (cons (car l1) (my-numeric-merge (cdr l1) l2))) (t (cons (car l2) (my-numeric-merge l1 (cdr l2)))))) (defun generate-random-sort-test (n m) (loop for i below n collect (random m))) (defun random-sort-test (n m reps) (loop for i below reps for list = (generate-random-sort-test (random n) m) unless (equal (my-numeric-sort list) (sort (copy-seq list) #'<)) collect list)) (defun random-stable-sort-test (n m reps) (loop for i below reps for list = (generate-random-sort-test (random n) m) unless (equal (my-numeric-sort list) (stable-sort (copy-seq list) #'<)) collect list)) gcl-2.7.1/ansi-tests/PaxHeaders/replace.lsp0000644000000000000000000000013114542551763015604 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.645789856 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/replace.lsp0000644000175000017500000004137314542551763015213 0ustar00cammcamm;-*- 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") (deftest replace-string.22 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ"))) (assert (string= s "XYZdefg"))) nil) (deftest replace-string.23 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :start1 1))) (assert (string= s "aXYZefg"))) nil) (deftest replace-string.24 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :start1 1 :end2 2))) (assert (string= s "aXYdefg"))) nil) (deftest replace-string.25 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :end1 2))) (assert (string= s "XYcdefg"))) nil) (deftest replace-string.26 (do-special-strings (s "abcdefg" nil) (assert (eq s (replace s "XYZ" :start2 1))) (assert (string= s "YZcdefg"))) nil) ;;; 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 (signals-error (replace) program-error) t) (deftest replace.error.2 (signals-error (replace nil) program-error) t) (deftest replace.error.3 (signals-error (replace nil nil :start) program-error) t) (deftest replace.error.4 (signals-error (replace nil nil 'bad t) program-error) t) (deftest replace.error.5 (signals-error (replace nil nil :allow-other-keys nil 'bad t) program-error) t) (deftest replace.error.6 (signals-error (replace nil nil 1 2) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/lambda.lsp0000644000000000000000000000013114542551762015410 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.645789856 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/lambda.lsp0000644000175000017500000001737314542551762015022 0ustar00cammcamm;-*- 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) (ignorable x))) 'z) nil) (deftest lambda.11 ((lambda (x &optional y z) (list x y z)) 1 2) (1 2 nil)) (deftest lambda.12 ((lambda (&optional (x 'a) (y 'b) (z 'c)) (list x y z)) 1 nil) (1 nil c)) (deftest lambda.13 ((lambda (&optional (x 'a x-p) (y 'b y-p) (z 'c z-p)) (list* x y z (mapcar #'notnot (list x-p y-p z-p)))) 1 nil) (1 nil c t t nil)) (deftest lambda.14 (let ((x 1)) ((lambda (&optional (x (1+ x))) x))) 2) (deftest lambda.15 ((lambda (y &optional (x (1+ y))) (list y x)) 10) (10 11)) (deftest lambda.16 ((lambda (y &optional (x (1+ y))) (list y x)) 10 14) (10 14)) (deftest lambda.17 ((lambda (&rest x) x) 1 2 3) (1 2 3)) (deftest lambda.18 (let ((b 10)) ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3 7)) (3 7)) (deftest lambda.19 (let ((b 10)) ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3)) (3 4)) (deftest lambda.20 (let ((b 10)) ((lambda (&optional (a b) (b (1+ a))) (list a b)))) (10 11)) (deftest lambda.21 (flet ((%f () (locally (declare (special *x*)) (incf *x*)))) ((lambda (*x*) (declare (special *x*)) (%f) *x*) 10)) 11) (deftest lambda.22 (flet ((%f () (locally (declare (special *x*)) (1+ *x*)))) ((lambda (*x*) (declare (special *x*)) (%f)) 15)) 16) (deftest lambda.23 ((lambda (&key a) a)) nil) (deftest lambda.24 ((lambda (&key a b c) (list a b c))) (nil nil nil)) (deftest lambda.25 ((lambda (&key (a 1) (b 2) (c 3)) (list a b c))) (1 2 3)) (deftest lambda.26 ((lambda (&key))) nil) (deftest lambda.27 ((lambda (&key) 'good) :allow-other-keys nil) good) (deftest lambda.28 ((lambda (&key) 'good) :allow-other-keys t :foo t) good) (deftest lambda.29 ((lambda (&key) 'good) :allow-other-keys t :allow-other-keys nil :foo t) good) (deftest lambda.30 ((lambda (&key x) x) :allow-other-keys t :x 10 :allow-other-keys nil :foo t) 10) (deftest lambda.31 ((lambda (&rest x &key) x)) nil) (deftest lambda.32 ((lambda (&rest x &key) x) :allow-other-keys nil) (:allow-other-keys nil)) (deftest lambda.33 ((lambda (&rest x &key) x) :w 5 :allow-other-keys t :x 10) (:w 5 :allow-other-keys t :x 10)) (deftest lambda.34 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) b (notnot b-p) c (notnot c-p))) :c 5 :a 0) (0 t 2 nil 5 t)) (deftest lambda.35 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) b (notnot b-p) c (notnot c-p))) :c 5 :a nil :a 17 :c 100) (nil t 2 nil 5 t)) (deftest lambda.36 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) b (notnot b-p) c (notnot c-p))) :c 5 :a 0 :allow-other-keys t 'b 100) (0 t 2 nil 5 t)) (deftest lambda.37 (let ((b 1)) ((lambda (&key (a b) b) (list a b)) :b 'x)) (1 x)) (deftest lambda.38 (let ((b 1)) ((lambda (&key (a b) b) (list a b)) :b 'x :a nil)) (nil x)) (deftest lambda.39 (let ((a-p :bad)) (declare (ignorable a-p)) ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))))) (nil nil nil)) (deftest lambda.40 (let ((a-p :bad)) (declare (ignorable a-p)) ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) :a 1)) (1 t t)) (deftest lambda.41 (let ((a-p :bad)) (declare (ignorable a-p)) ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) :a nil)) (nil t t)) (deftest lambda.42 ((lambda (&key a b &allow-other-keys) (list a b)) :a 1 :b 2) (1 2)) (deftest lambda.43 ((lambda (&key a b &allow-other-keys) (list a b)) :b 2 :a 1) (1 2)) (deftest lambda.44 ((lambda (&key a b &allow-other-keys) (list a b)) :z 10 :b 2 :b nil :a 1 :a 2 'x 100) (1 2)) (deftest lambda.45 ((lambda (&key a b &allow-other-keys) (list a b)) :allow-other-keys nil :z 10 :b 2 :b nil :a 1 :a 2 'x 100) (1 2)) (deftest lambda.46 ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) :allow-other-keys nil :a 1 :b 2) (nil 1 2)) (deftest lambda.47 ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) :c 10 :allow-other-keys t :a 1 :b 2 :d 20) (t 1 2)) (deftest lambda.48 ((lambda (&key a b allow-other-keys &allow-other-keys) (list allow-other-keys a b)) :d 40 :allow-other-keys nil :a 1 :b 2 :c 20) (nil 1 2)) (deftest lambda.49 ((lambda (&key a b allow-other-keys &allow-other-keys) (list allow-other-keys a b)) :d 40 :a 1 :b 2 :c 20) (nil 1 2)) (deftest lambda.50 ((lambda (&key a b ((:allow-other-keys aok))) (list aok a b)) :d 40 :a 1 :allow-other-keys t :b 2 :c 20) (t 1 2)) (deftest lambda.51 ((lambda (&key &allow-other-keys)) :a 1 :b 2 :c 3) nil) ;;; Free declaration scope (deftest lambda.52 (let ((x :bad)) (declare (special x)) (let ((x :good)) ((lambda (&optional (y x)) (declare (special x)) y)))) :good) (deftest lambda.53 (let ((x :bad)) (declare (special x)) (let ((x :good)) ((lambda (&key (y x)) (declare (special x)) y)))) :good) (deftest lambda.54 (let ((x :bad)) (declare (special x)) (let ((x :good)) ((lambda (&aux (y x)) (declare (special x)) y)))) :good) (deftest lambda.55 (let* ((doc "LMB55") (fn (eval `#'(lambda () ,doc nil))) (cfn (compile nil fn))) (values (or (documentation fn t) doc) (or (documentation cfn t) doc))) "LMB55" "LMB55") (deftest lambda.56 (let* ((doc "LMB56") (fn (eval `#'(lambda () ,doc nil))) (cfn (compile nil fn))) (values (or (documentation fn 'function) doc) (or (documentation cfn 'function) doc))) "LMB56" "LMB56") ;;; Uninterned symbols as lambda variables (deftest lambda.57 ((lambda (#1=#:foo) #1#) 17) 17) (deftest lambda.58 ((lambda (&rest #1=#:foo) #1#) 'a 'b 'c) (a b c)) (deftest lambda.59 ((lambda (&optional #1=#:foo) #1#)) nil) (deftest lambda.60 ((lambda (&optional (#1=#:foo t)) #1#)) t) (deftest lambda.61 ((lambda (&optional (#1=#:foo t)) #1#) 'bar) bar) (deftest lambda.62 ((lambda (&key #1=#:foo) #1#) :foo 12) 12) ;;; Test that declarations for aux variables are handled properly (deftest lambda.63 (let ((y :bad1)) (declare (ignore y)) (let ((y :bad2)) (declare (special y)) (flet ((%f () y)) ((lambda (x &aux (y :good)) (declare (special y) (ignore x)) (%f)) nil)))) :good) (deftest lambda.64 (let ((x :bad)) (declare (special x)) (flet ((%f () x)) ((lambda (x &aux (y (%f))) (declare (type t y) (special x)) y) :good))) :good) ;;; 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) ;;; Error tests (deftest lambda.error.1 (signals-error (funcall (macro-function 'lambda)) program-error) t) (deftest lambda.error.2 (signals-error (funcall (macro-function 'lambda) '(lambda ())) program-error) t) (deftest lambda.error.3 (signals-error (funcall (macro-function 'lambda) '(lambda ()) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/compileit.lsp0000644000000000000000000000013014542551762016154 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.645789856 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compileit.lsp0000644000175000017500000000144514542551762015560 0ustar00cammcamm;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE ;;; tests require that a missing :initial-element argument defaults ;;; to a single value, rather than leaving the string/sequence filled ;;; with arbitrary legal garbage. ;; (pushnew :ansi-tests-strict-initial-element *features*) #+allegro (run-shell-command "rm -f *.fasl") #+cmu (run-program "rm -f *.x86f") (load "gclload1.lsp") (load "gclload2.lsp") (setq rt::*compile-tests* t) #+allegro (progn (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :standardized-package-nicknames) (rt:disable-note :type-of/strict-builtins) (rt:disable-note :assume-no-simple-streams) (rt:disable-note :assume-no-gray-streams)) (in-package :cl-test) (time (regression-test:do-tests)) #+allegro :exit #+(or cmu sbcl gcl) (quit) gcl-2.7.1/ansi-tests/PaxHeaders/sxhash.lsp0000644000000000000000000000013114542551763015467 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.645789856 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sxhash.lsp0000644000175000017500000001703314542551763015072 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 21:18:12 2003 ;;;; Contains: Tests of SXHASH (in-package :cl-test) (deftest sxhash.1 (check-predicate #'(lambda (x) (typep (sxhash x) '(and unsigned-byte fixnum)))) nil) (deftest sxhash.2 (loop for i from 0 below 256 for c = (code-char i) when (and c (not (= (sxhash (string c)) (sxhash (string c))))) collect c) nil) (deftest sxhash.3 (=t (sxhash "") (sxhash (copy-seq ""))) t) (deftest sxhash.4 (loop for bv1 in '(#* #*0 #*1 #*01 #*00 #*10 #*11 #*1100101101100 #*110010101011001011010000111001011) for bv2 = (copy-seq bv1) for sx1 = (sxhash bv1) for sx2 = (sxhash bv2) always (and (not (eq bv1 bv2)) (equal bv1 bv2) (typep sx1 '(and unsigned-byte fixnum)) (typep sx2 '(and unsigned-byte fixnum)) (= sx1 sx2))) t) (deftest sxhash.5 (let ((s1 "abcd") (s2 (make-array 10 :element-type 'character :initial-contents "abcdefghij" :fill-pointer 4))) (and (equalt s1 s2) (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.6 (let ((s1 #*01101) (s2 (make-array 10 :element-type 'bit :initial-contents #*0110111101 :fill-pointer 5))) (and (equalt s1 s2) (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.7 (let* ((a (make-array 10 :initial-element nil)) (sx1 (sxhash a))) (setf (aref a 4) 'x) (let ((sx2 (sxhash a))) (and (typep sx1 '(and unsigned-byte fixnum)) (eqlt sx1 sx2)))) t) (deftest sxhash.8 :notes (:nil-vectors-are-strings) (eqlt (sxhash (make-array 0 :element-type nil)) (sxhash "")) t) (deftest sxhash.9 (let ((s1 (make-array 5 :element-type 'base-char :initial-contents "abcde")) (s2 (copy-seq "abcde"))) (eqlt (sxhash s1) (sxhash s2))) t) (deftest sxhash.10 (let ((s1 "abcd") (s2 (make-array 10 :element-type 'base-char :initial-contents "abcdefghij" :fill-pointer 4))) (and (equalt s1 s2) (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.11 (let* ((x (cons 'a 'b)) (sx1 (sxhash x)) (sx2 (sxhash '(a . b)))) (setf (car x) 'c) (let* ((sx3 (sxhash x)) (sx4 (sxhash '(c . b)))) (and (=t sx1 sx2) (=t sx3 sx4)))) t) (deftest sxhash.12 (let ((x (1+ most-positive-fixnum)) (y (1+ most-positive-fixnum))) (=t (sxhash x) (sxhash y))) t) (deftest sxhash.13 (let ((sx1 (sxhash (make-symbol "FOO"))) (sx2 (sxhash (make-symbol "FOO")))) (and (typep sx1 '(and unsigned-byte fixnum)) (eqlt sx1 sx2))) t) ;; (deftest sxhash.14 ;; (let ((sx1 (sxhash :foo)) ;; (sx2 (sxhash '#:foo))) ;; (and (typep sx1 '(and unsigned-byte fixnum)) ;; (eqlt sx1 sx2))) ;; t) (deftest sxhash.15 (let* ((package-name (loop for i from 0 for name = (format nil "PACKAGE-~A" i) for package = (find-package name) unless package do (return name))) (sx1 (let* ((package (make-package package-name :nicknames nil :use nil)) (symbol (intern "FOO" package))) (prog1 (sxhash symbol) (delete-package package)))) (sx2 (let* ((package (make-package package-name :nicknames nil :use nil)) (symbol (intern "FOO" package))) (prog1 (sxhash symbol) (delete-package package))))) (assert (typep sx1 '(and unsigned-byte fixnum))) (if (= sx1 sx2) :good (list sx1 sx2))) :good) (deftest sxhash.16 (let ((c1 (list 'a)) (c2 (list 'a))) (setf (cdr c1) c1) (setf (cdr c2) c2) (let ((sx1 (sxhash c1)) (sx2 (sxhash c2))) (or (eqlt sx1 sx2) (list sx1 sx2)))) t) ;;; Since similarity of numbers is 'same type and same mathematical value', ;;; and since sxhash must produce the same value for similar numeric arguments, ;;; (sxhash 0.0) and (sxhash -0.0) must be eql for all float types. ;;; This may be a spec bug, so I've added a note. (deftest sxhash.17 :notes (:negative-zero-is-similar-to-positive-zero) (loop for c1 in '(0.0s0 0.0f0 0.0d0 0.0l0) for c2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) for t1 = (type-of c1) for t2 = (type-of c2) for sx1 = (sxhash c1) for sx2 = (sxhash c2) unless (or (not (subtypep t1 t2)) (not (subtypep t2 t1)) (eql sx1 sx2)) collect (list c1 c2 sx1 sx2)) nil) (deftest sxhash.18 :notes (:negative-zero-is-similar-to-positive-zero) (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) for c1 = (complex r1) for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) for c2 = (complex r2) for t1 = (type-of c1) for t2 = (type-of c2) for sx1 = (sxhash c1) for sx2 = (sxhash c2) unless (or (not (subtypep t1 t2)) (not (subtypep t2 t1)) (eql sx1 sx2)) collect (list c1 c2 sx1 sx2)) nil) (deftest sxhash.19 :notes (:negative-zero-is-similar-to-positive-zero) (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) for c1 = (complex 0 r1) for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) for c2 = (complex 0 r2) for t1 = (type-of c1) for t2 = (type-of c2) for sx1 = (sxhash c1) for sx2 = (sxhash c2) unless (or (not (subtypep t1 t2)) (not (subtypep t2 t1)) (eql sx1 sx2)) collect (list c1 c2 sx1 sx2)) nil) ;;; Similar pathnames have the same hash (deftest sxhash.20 (let* ((pathspec "sxhash.lsp") (sx1 (sxhash (pathname (copy-seq pathspec)))) (sx2 (sxhash (pathname (copy-seq pathspec))))) (if (and (typep sx1 '(and fixnum unsigned-byte)) (eql sx1 sx2)) :good (list sx1 sx2))) :good) ;;; Similarity for strings (deftest sxhash.21 (let* ((s1 "abc") (s2 (make-array '(3) :element-type 'character :initial-contents s1)) (s3 (make-array '(3) :element-type 'base-char :initial-contents s1)) (s4 (make-array '(3) :element-type 'standard-char :initial-contents s1)) (s5 (make-array '(3) :element-type 'character :adjustable t :initial-contents "abc")) (s6 (make-array '(5) :element-type 'character :fill-pointer 3 :initial-contents "abcde")) (s7 (make-array '(3) :element-type 'character :displaced-to s2 :displaced-index-offset 0)) (s8 (make-array '(3) :element-type 'character :displaced-to (make-array '(7) :element-type 'character :initial-contents "xxabcyy") :displaced-index-offset 2)) (strings (list s1 s2 s3 s4 s5 s6 s7 s8)) (hashes (mapcar #'sxhash strings))) (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) (not (position (car hashes) hashes :test #'/=))) :good hashes)) :good) ;;; Similarity for bit vectors (deftest sxhash.22 (let* ((bv1 #*010) (bv2 (make-array '(3) :element-type 'bit :initial-contents bv1)) (bv5 (make-array '(3) :element-type 'bit :adjustable t :initial-contents bv1)) (bv6 (make-array '(5) :element-type 'bit :fill-pointer 3 :initial-contents #*01010)) (bv7 (make-array '(3) :element-type 'bit :displaced-to bv2 :displaced-index-offset 0)) (bv8 (make-array '(3) :element-type 'bit :displaced-to (make-array '(7) :element-type 'bit :initial-contents #*1101001) :displaced-index-offset 2)) (bit-vectors (list bv1 bv2 bv5 bv6 bv7 bv8)) (hashes (mapcar #'sxhash bit-vectors))) (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) (not (position (car hashes) hashes :test #'/=))) :good hashes)) :good) ;;; The hash of a symbol does not change when its package changes (deftest sxhash.23 (progn (safely-delete-package "A") (defpackage "A" (:use)) (let* ((pkg (find-package "A")) (sym (intern "FOO" pkg)) (hash (sxhash sym))) (unintern sym pkg) (let ((hash2 (sxhash sym))) (if (eql hash hash2) nil (list hash hash2))))) nil) ;;; Error cases (deftest sxhash.error.1 (signals-error (sxhash) program-error) t) (deftest sxhash.error.2 (signals-error (sxhash nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-o.lsp0000644000000000000000000000013214542551762015715 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.645789856 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-o.lsp0000644000175000017500000003721614542551762015324 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 06:36:30 2004 ;;;; Contains: Tests of format directive ~O (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.o.1 (let ((fn (formatter "~o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~O" i) for j = (let ((*read-base* 8)) (read-from-string s1)) for s2 = (formatter-call-to-string fn i) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j s2)))) nil) (deftest format.o.2 (let ((fn (formatter "~@O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@o" i) for j = (let ((*read-base* 8)) (read-from-string s1)) for s2 = (formatter-call-to-string fn i) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) ;; (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j s2)))) nil) (deftest format.o.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~do" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~do" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.o.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@O" i) for fmt = (format nil "~~~d@o" mincol) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@O" i) for fmt = (format nil "~~~d@o" mincol) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.o.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "oO")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "oO")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.o.6 (let ((fn (formatter "~V,Vo"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~o" i) for s2 = (format nil "~v,vO" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.o.7 (let ((fn (formatter "~v,V@O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@o" i) for s2 = (format nil "~v,v@o" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests (deftest format.o.8 (let ((fn (formatter "~:O"))) (loop for i from #o-777 to #o777 for s1 = (format nil "~o" i) for s2 = (format nil "~:o" i) for s3 = (formatter-call-to-string fn i) unless (and (string= s1 s2) (string= s2 s3)) collect (list i s1 s2 s3))) nil) (deftest format.o.9 (let ((fn (formatter "~:o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~o" i) for s2 = (format nil "~:O" i) for s3 = (formatter-call-to-string fn i) repeat 1000 unless (and (string= s1 (remove commachar s2)) (string= s2 s3) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "01234567"))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.10 (let ((fn (formatter "~,,v:o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~o" i) for s2 = (format nil "~,,v:o" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~o" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) for s2 = (format nil fmt i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.o.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~o" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.o.12 (let ((fn (formatter "~,,V,v:O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~o" i) for s2 = (format nil "~,,v,v:O" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.13 (let ((fn (formatter "~,,v,V@:O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@o" i) for s2 = (format nil "~,,v,v:@o" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.o.14 "~vO" (nil #o100) "100") (def-format-test format.o.15 "~6,vO" (nil #o100) " 100") (def-format-test format.o.16 "~,,v:o" (nil #o12345) "12,345") (def-format-test format.o.17 "~,,'*,v:o" (nil #o12345) "12*345") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.o.18 (let ((fn (formatter "~o"))) (loop for x in *mini-universe* for s1 = (format nil "~o" x) for s2 = (let ((*print-base* 8)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.o.19 (let ((fn (formatter "~:o"))) (loop for x in *mini-universe* for s1 = (format nil "~:o" x) for s2 = (let ((*print-base* 8)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.o.20 (let ((fn (formatter "~@o"))) (loop for x in *mini-universe* for s1 = (format nil "~@o" x) for s2 = (let ((*print-base* 8)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.o.21 (let ((fn (formatter "~:@o"))) (loop for x in *mini-universe* for s1 = (let ((*print-base* 8)) (format nil "~A" x)) for s2 = (format nil "~@:o" x) for s3 = (formatter-call-to-string fn x) for s4 = (let ((*print-base* 8)) (format nil "~A" x)) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3)) (string/= s1 s4)) collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.o.22 (apply #'values (let ((fn (formatter "~#o")) (n #o12345)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#o" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "12345" "12345" "12345" "12345" "12345" " 12345" " 12345" " 12345" " 12345" " 12345" " 12345") (deftest format.o.23 (apply #'values (let ((fn (formatter "~,,,#:o")) (n #o1234567012)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:o" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "1,2,3,4,5,6,7,0,1,2" "12,34,56,70,12" "1,234,567,012" "12,3456,7012" "12345,67012" "1234,567012" "123,4567012" "12,34567012" "1,234567012" "1234567012" "1234567012") (deftest format.o.24 (apply #'values (let ((fn (formatter "~,,,#:@o")) (n #o1234567012)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:O" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "+1,2,3,4,5,6,7,0,1,2" "+12,34,56,70,12" "+1,234,567,012" "+12,3456,7012" "+12345,67012" "+1234,567012" "+123,4567012" "+12,34567012" "+1,234567012" "+1234567012" "+1234567012") (def-format-test format.o.25 "~+10o" (#o1234) " 1234") (def-format-test format.o.26 "~+10@O" (#o1234) " +1234") (def-format-test format.o.27 "~-1O" (#o1234) "1234") (def-format-test format.o.28 "~-1000000000000000000o" (#o1234) "1234") (def-format-test format.o.29 "~vo" ((1- most-negative-fixnum) #o1234) "1234") ;;; Randomized test (deftest format.o.30 (let ((fn (formatter "~v,v,v,vo"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~do" commaint) "o")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vo" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/ignore-errors.lsp0000644000000000000000000000013114542551762016765 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.649789874 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ignore-errors.lsp0000644000175000017500000000132314542551762016363 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 2 20:38:25 2003 ;;;; Contains: Tests of IGNORE-ERRORS (in-package :cl-test) (deftest ignore-errors.1 (ignore-errors) nil) (deftest ignore-errors.2 (ignore-errors 'a) a) (deftest ignore-errors.3 (ignore-errors (values 1 2 3 4 5 6 7 8)) 1 2 3 4 5 6 7 8) (deftest ignore-errors.4 (multiple-value-bind (val cond) (ignore-errors (error "foo")) (and (null val) (typep cond 'simple-error) t)) t) (deftest ignore-errors.5 (handler-case (ignore-errors (signal "foo")) (condition () 'good)) good) (deftest ignore-errors.6 (handler-case (ignore-errors (signal "foo")) (simple-condition () 'good)) good) gcl-2.7.1/ansi-tests/PaxHeaders/print-pathname.lsp0000644000000000000000000000013114542551763017120 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.649789874 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-pathname.lsp0000644000175000017500000000170414542551763016521 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 25 08:22:03 2004 ;;;; Contains: Printer tests for pathnames (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.pathname.1 (loop for p in *universe* when (typep p 'pathname) nconc (loop repeat 10 nconc (randomly-check-readability p :test #'is-similar :can-fail t))) nil) (deftest print.pathname.2 (loop for p in *universe* when (typep p 'pathname) nconc (let ((ns (ignore-errors (namestring p)))) "Read 22.1.3.11 before commenting on this test" (when ns (let ((expected-result (concatenate 'string "#P" (with-standard-io-syntax (write-to-string ns :readably nil :escape t)))) (result (with-standard-io-syntax (write-to-string p :readably nil :escape t)))) (unless (string= expected-result result) (list (list expected-result result))))))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/search-list.lsp0000644000000000000000000000013214542551763016410 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.649789874 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/search-list.lsp0000644000175000017500000001740514542551763016015 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:22:10 2002 ;;;; Contains: Tests for SEARCH on lists (in-package :cl-test) (compile-and-load "search-aux.lsp") (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) ;; Order of test, test-not (deftest search-list.15 (let ((pat '(10)) (target '(1 4 6 10 15 20))) (search pat target :test #'<)) 4) (deftest search-list.16 (let ((pat '(10)) (target '(1 4 6 10 15 20))) (search pat target :test-not #'>=)) 4) (defharmless search.test-and-test-not.1 (search '(b c) '(a b c d) :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.2 (search '(b c) '(a b c d) :test-not #'eql :test #'eql)) (defharmless search.test-and-test-not.3 (search #(b c) #(a b c d) :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.4 (search #(b c) #(a b c d) :test-not #'eql :test #'eql)) (defharmless search.test-and-test-not.5 (search "bc" "abcd" :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.6 (search "bc" "abcd" :test-not #'eql :test #'eql)) (defharmless search.test-and-test-not.7 (search #*01 #*0011 :test #'eql :test-not #'eql)) (defharmless search.test-and-test-not.8 (search #*01 #*0011 :test-not #'eql :test #'eql)) ;;; 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 (signals-error (search) program-error) t) (deftest search.error.2 (signals-error (search "a") program-error) t) (deftest search.error.3 (signals-error (search "a" "a" :key) program-error) t) (deftest search.error.4 (signals-error (search "a" "a" 'bad t) program-error) t) (deftest search.error.5 (signals-error (search "a" "a" 'bad t :allow-other-keys nil) program-error) t) (deftest search.error.6 (signals-error (search "a" "a" 1 2) program-error) t) (deftest search.error.7 (signals-error (search "c" "abcde" :test #'identity) program-error) t) (deftest search.error.8 (signals-error (search "c" "abcde" :test-not #'identity) program-error) t) (deftest search.error.9 (signals-error (search "c" "abcde" :key #'cons) program-error) t) (deftest search.error.10 (signals-error (search "c" "abcde" :key #'car) type-error) t) ;;; 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.7.1/ansi-tests/PaxHeaders/char-schar.lsp0000644000000000000000000000013014542551762016202 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.649789874 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/char-schar.lsp0000644000175000017500000001017114542551762015602 0ustar00cammcamm;-*- 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) ;;; Error tests (deftest char.error.1 (signals-error (char) program-error) t) (deftest char.error.2 (signals-error (char "abc") program-error) t) (deftest char.error.3 (signals-error (char "abc" 1 nil) program-error) t) ;;; 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) ;;; Error tests (deftest schar.error.1 (signals-error (schar) program-error) t) (deftest schar.error.2 (signals-error (schar "abc") program-error) t) (deftest schar.error.3 (signals-error (schar "abc" 1 nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/fceiling.lsp0000644000000000000000000000013214542551762015751 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.649789874 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fceiling.lsp0000644000175000017500000000713514542551762015355 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:22:23 2003 ;;;; Contains: Tests of FCEILING (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "fceiling-aux.lsp") (deftest fceiling.error.1 (signals-error (fceiling) program-error) t) (deftest fceiling.error.2 (signals-error (fceiling 1.0 1 nil) program-error) t) ;;; (deftest fceiling.1 (fceiling.1-fn) nil) (deftest fceiling.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (fceiling x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fceiling.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (fceiling (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fceiling.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'short-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'short-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'single-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'single-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'double-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'double-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce (1+ i) 'long-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) (deftest fceiling.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fceiling x)) unless (and (eql q (coerce i 'long-float)) (eql r (- rrad 1))) collect (list i x q r))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/host-namestring.lsp0000644000000000000000000000013114542551762017312 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.649789874 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/host-namestring.lsp0000644000175000017500000000216514542551762016715 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/prog1.lsp0000644000000000000000000000013114542551763015221 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.649789874 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/prog1.lsp0000644000175000017500000000143614542551763014624 0ustar00cammcamm;-*- 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) ;;; Test that prog1 doesn't have a tagbody (deftest prog1.6 (block nil (tagbody (return (prog1 'bad (go 10) 10)) 10 (return 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest prog1.7 (macrolet ((%m (z) z)) (prog1 (expand-in-current-env (%m 'good)))) good) (def-macro-test prog1.error.1 (prog1 nil)) gcl-2.7.1/ansi-tests/PaxHeaders/fill-pointer.lsp0000644000000000000000000000013214542551762016575 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.649789874 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fill-pointer.lsp0000644000175000017500000000353414542551762016200 0ustar00cammcamm;-*- 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 (signals-error (fill-pointer) program-error) t) (deftest fill-pointer.error.2 (signals-error (fill-pointer (make-array '(10) :fill-pointer 4) nil) program-error) t) (deftest fill-pointer.error.3 (let ((a (make-array '(10) :fill-pointer nil))) (if (array-has-fill-pointer-p a) t (eval `(signals-error (fill-pointer ',a) type-error)))) t) (deftest fill-pointer.error.4 (signals-error (fill-pointer #0aNIL) type-error) t) (deftest fill-pointer.error.5 (signals-error (fill-pointer #2a((a b c)(d e f))) type-error) t) (deftest fill-pointer.error.6 (check-type-error #'fill-pointer #'(lambda (x) (and (vectorp x) (array-has-fill-pointer-p x)))) nil) (deftest fill-pointer.error.7 (signals-error (locally (fill-pointer #2a((a b c)(d e f))) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ldb.lsp0000644000000000000000000000013114542551762014731 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.649789874 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ldb.lsp0000644000175000017500000000371014542551762014331 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 20:45:17 2003 ;;;; Contains: Tests of LDB (in-package :cl-test) ;;; Error tests (deftest ldb.error.1 (signals-error (ldb) program-error) t) (deftest ldb.error.2 (signals-error (ldb (byte 1 1)) program-error) t) (deftest ldb.error.3 (signals-error (ldb (byte 1 1) -1 0) program-error) t) ;;; Non-error tests (deftest ldb.1 (loop for x = (random-fixnum) for pos = (random 30) for size = (random 30) repeat 10000 unless (eql (ldb (byte size pos) x) (logand (1- (ash 1 size)) (ash x (- pos)))) collect (list x pos size)) nil) (deftest ldb.2 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) for pos = (random 300) for size = (random 300) repeat 1000 unless (eql (ldb (byte size pos) x) (logand (1- (ash 1 size)) (ash x (- pos)))) collect (list x pos size))) nil) (deftest ldb.3 (loop for i of-type fixnum from -1000 to 1000 always (eql (ldb (byte 0 0) i) 0)) t) (deftest ldb.order.1 (let ((i 0) a b c d) (values (ldb (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (progn (setf d (incf i)) -1)) i a b c d)) 7 4 1 2 3 4) ;;; ldb on places (deftest ldb.place.1 (let ((x 0)) (values (setf (ldb (byte 4 1) x) -1) x)) -1 30) (deftest ldb.place.2 (loop for pos from 0 to 100 always (loop for size from 0 to 100 always (let ((x 0)) (and (eql (setf (ldb (byte size pos) x) -1) -1) (eql x (ash (1- (ash 1 size)) pos)))))) t) (deftest ldb.place.order.1 (let ((i 0) a b c d e f (x (copy-seq #(63)))) (values (setf (ldb (progn (setf a (incf i)) (byte (progn (setf b (incf i)) 3) (progn (setf c (incf i)) 1))) (aref (progn (setf d (incf i)) x) (progn (setf e (incf i)) 0))) (progn (setf f (incf i)) 0)) x i a b c d e f)) 0 #(49) 6 1 2 3 4 5 6) gcl-2.7.1/ansi-tests/PaxHeaders/with-compilation-unit.lsp0000644000000000000000000000013214542551763020436 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.649789874 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-compilation-unit.lsp0000644000175000017500000000226314542551763020037 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 30 07:36:26 2005 ;;;; Contains: Tests of WITH-COMPILATION-UNIT ;;; WITH-COMPILATION-UNIT doesn't have much in the way of standardized ;;; semantics, so there's not much to test. (in-package :cl-test) (deftest with-compilation-unit.1 (with-compilation-unit ()) nil) (deftest with-compilation-unit.2 (with-compilation-unit () t) t) (deftest with-compilation-unit.3 (with-compilation-unit () (values))) (deftest with-compilation-unit.4 (with-compilation-unit () (values 1 2 3 4 5)) 1 2 3 4 5) (deftest with-compilation-unit.5 (with-compilation-unit (:override nil) :foo) :foo) (deftest with-compilation-unit.6 (with-compilation-unit (:override t) (values 10 17)) 10 17) (deftest with-compilation-unit.7 (let ((x nil)) (values (block done (with-compilation-unit (:override nil) (setq x 1) (return-from done 2) (setq x 2))) x)) 2 1) ;;; Add a test that (1) checks if the compiler normally delays ;;; warnings until the end of a file and, if so, (2) checks that ;;; with-compilation-unit delays the warnings for more than one ;;; file compilation until the end of the unit. gcl-2.7.1/ansi-tests/PaxHeaders/structures-03.lsp0000644000000000000000000000013214542551763016635 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.649789874 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/structures-03.lsp0000644000175000017500000002362314542551763016241 0ustar00cammcamm;-*- 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 (signals-error (sbt-15-con :a 1) program-error) t) (deftest structure-boa-test-15/3 (signals-error (sbt-15-con :b 1) program-error) t) (deftest structure-boa-test-15/4 (signals-error (sbt-15-con 'x 1) program-error) t) (deftest structure-boa-test-15/5 (signals-error (sbt-15-con :y 1) program-error) t) (deftest structure-boa-test-15/6 (signals-error (sbt-15-con 'c 1) program-error) t) (deftest structure-boa-test-15/7 (signals-error (sbt-15-con 'a 1) program-error) t) (deftest structure-boa-test-15/8 (signals-error (sbt-15-con 'b 1) program-error) t) ;;; 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 (signals-error (make-sbt-16 :d 1) program-error) t) (deftest structure-boa-test-16/4 (signals-error (make-sbt-16 :a) program-error) t) (deftest structure-boa-test-16/5 (signals-error (make-sbt-16 'a) program-error) t) (deftest structure-boa-test-16/6 (signals-error (make-sbt-16 1 1) program-error) t) (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)) ;;; Error test (def-macro-test struct.error.1 (defstruct nonexistent-structure-type a b c)) gcl-2.7.1/ansi-tests/PaxHeaders/print-integers.lsp0000644000000000000000000000013114542551763017143 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.649789874 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-integers.lsp0000644000175000017500000004353514542551763016554 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 06:26:25 2004 ;;;; Contains: Printing tests for integers (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Tests with *print-base* (def-print-test print.integers.1 1 "1") (def-print-test print.integers.2 2 "2") (def-print-test print.integers.3 3 "3") (def-print-test print.integers.4 4 "4") (def-print-test print.integers.5 5 "5") (def-print-test print.integers.6 6 "6") (def-print-test print.integers.7 7 "7") (def-print-test print.integers.8 8 "8") (def-print-test print.integers.9 9 "9") (def-print-test print.integers.10 -0 "0") (def-print-test print.integers.11 -1 "-1") (def-print-test print.integers.12 -2 "-2") (def-print-test print.integers.13 -3 "-3") (def-print-test print.integers.14 -4 "-4") (def-print-test print.integers.15 -5 "-5") (def-print-test print.integers.16 -6 "-6") (def-print-test print.integers.17 -7 "-7") (def-print-test print.integers.18 -8 "-8") (def-print-test print.integers.19 -9 "-9") (def-print-test print.integers.20 (expt 10 20) "100000000000000000000") (def-print-test print.integers.21 (- (expt 10 20)) "-100000000000000000000") (def-print-test print.integers.base.2.0 0 "0" (*print-base* 2)) (def-print-test print.integers.base.2.1 1 "1" (*print-base* 2)) (def-print-test print.integers.base.2.2 2 "10" (*print-base* 2)) (def-print-test print.integers.base.2.3 3 "11" (*print-base* 2)) (def-print-test print.integers.base.2.4 -1 "-1" (*print-base* 2)) (def-print-test print.integers.base.2.5 -2 "-10" (*print-base* 2)) (def-print-test print.integers.base.2.6 -3 "-11" (*print-base* 2)) (def-print-test print.integers.base.2.7 255 "11111111" (*print-base* 2)) (def-print-test print.integers.base.2.8 -252 "-11111100" (*print-base* 2)) (def-print-test print.integers.base.2.9 (expt 2 40) "10000000000000000000000000000000000000000" (*print-base* 2)) (def-print-test print.integers.base.2.10 (- (expt 2 40)) "-10000000000000000000000000000000000000000" (*print-base* 2)) (def-print-test print.integers.base.3.0 0 "0" (*print-base* 3)) (def-print-test print.integers.base.3.1 1 "1" (*print-base* 3)) (def-print-test print.integers.base.3.2 2 "2" (*print-base* 3)) (def-print-test print.integers.base.3.3 3 "10" (*print-base* 3)) (def-print-test print.integers.base.3.4 -1 "-1" (*print-base* 3)) (def-print-test print.integers.base.3.5 -2 "-2" (*print-base* 3)) (def-print-test print.integers.base.3.6 -3 "-10" (*print-base* 3)) (def-print-test print.integers.base.3.7 80 "2222" (*print-base* 3)) (def-print-test print.integers.base.3.8 -78 "-2220" (*print-base* 3)) (def-print-test print.integers.base.3.9 (expt 3 40) "10000000000000000000000000000000000000000" (*print-base* 3)) (def-print-test print.integers.base.3.10 (- (expt 3 40)) "-10000000000000000000000000000000000000000" (*print-base* 3)) (def-print-test print.integers.base.4.0 0 "0" (*print-base* 4)) (def-print-test print.integers.base.4.1 1 "1" (*print-base* 4)) (def-print-test print.integers.base.4.2 2 "2" (*print-base* 4)) (def-print-test print.integers.base.4.3 3 "3" (*print-base* 4)) (def-print-test print.integers.base.4.4 4 "10" (*print-base* 4)) (def-print-test print.integers.base.4.5 5 "11" (*print-base* 4)) (def-print-test print.integers.base.4.6 -1 "-1" (*print-base* 4)) (def-print-test print.integers.base.4.7 -2 "-2" (*print-base* 4)) (def-print-test print.integers.base.4.8 -3 "-3" (*print-base* 4)) (def-print-test print.integers.base.4.9 -4 "-10" (*print-base* 4)) (def-print-test print.integers.base.4.10 -5 "-11" (*print-base* 4)) (def-print-test print.integers.base.4.11 255 "3333" (*print-base* 4)) (def-print-test print.integers.base.4.12 -255 "-3333" (*print-base* 4)) (def-print-test print.integers.base.4.13 (expt 4 40) "10000000000000000000000000000000000000000" (*print-base* 4)) (def-print-test print.integers.base.4.14 (- (expt 4 40)) "-10000000000000000000000000000000000000000" (*print-base* 4)) (def-print-test print.integers.base.7.0 0 "0" (*print-base* 7)) (def-print-test print.integers.base.7.1 1 "1" (*print-base* 7)) (def-print-test print.integers.base.7.2 2 "2" (*print-base* 7)) (def-print-test print.integers.base.7.3 16 "22" (*print-base* 7)) (def-print-test print.integers.base.7.4 66 "123" (*print-base* 7)) (def-print-test print.integers.base.7.5 -1 "-1" (*print-base* 7)) (def-print-test print.integers.base.7.6 -7 "-10" (*print-base* 7)) (def-print-test print.integers.base.7.7 -48 "-66" (*print-base* 7)) (def-print-test print.integers.base.7.8 (expt 7 40) "10000000000000000000000000000000000000000" (*print-base* 7)) (def-print-test print.integers.base.7.9 (- (expt 7 40)) "-10000000000000000000000000000000000000000" (*print-base* 7)) (def-print-test print.integers.base.11.0 0 "0" (*print-base* 11)) (def-print-test print.integers.base.11.1 1 "1" (*print-base* 11)) (def-print-test print.integers.base.11.2 2 "2" (*print-base* 11)) (def-print-test print.integers.base.11.3 10 "A" (*print-base* 11)) (def-print-test print.integers.base.11.4 11 "10" (*print-base* 11)) (def-print-test print.integers.base.11.5 121 "100" (*print-base* 11)) (def-print-test print.integers.base.11.6 -1 "-1" (*print-base* 11)) (def-print-test print.integers.base.11.7 -10 "-A" (*print-base* 11)) (def-print-test print.integers.base.11.8 -21 "-1A" (*print-base* 11)) (def-print-test print.integers.base.11.9 -110 "-A0" (*print-base* 11)) (def-print-test print.integers.base.11.10 (expt 11 40) "10000000000000000000000000000000000000000" (*print-base* 11)) (def-print-test print.integers.base.11.11 (- (expt 11 40)) "-10000000000000000000000000000000000000000" (*print-base* 11)) (def-print-test print.integers.base.16.0 0 "0" (*print-base* 16)) (def-print-test print.integers.base.16.1 1 "1" (*print-base* 16)) (def-print-test print.integers.base.16.2 2 "2" (*print-base* 16)) (def-print-test print.integers.base.16.3 12 "C" (*print-base* 16)) (def-print-test print.integers.base.16.4 17 "11" (*print-base* 16)) (def-print-test print.integers.base.16.5 256 "100" (*print-base* 16)) (def-print-test print.integers.base.16.6 -1 "-1" (*print-base* 16)) (def-print-test print.integers.base.16.7 -14 "-E" (*print-base* 16)) (def-print-test print.integers.base.16.8 -30 "-1E" (*print-base* 16)) (def-print-test print.integers.base.16.9 -208 "-D0" (*print-base* 16)) (def-print-test print.integers.base.16.10 (expt 16 40) "10000000000000000000000000000000000000000" (*print-base* 16)) (def-print-test print.integers.base.16.11 (- (expt 16 40)) "-10000000000000000000000000000000000000000" (*print-base* 16)) (def-print-test print.integers.base.36.0 0 "0" (*print-base* 36)) (def-print-test print.integers.base.36.1 1 "1" (*print-base* 36)) (def-print-test print.integers.base.36.2 2 "2" (*print-base* 36)) (def-print-test print.integers.base.36.3 12 "C" (*print-base* 36)) (def-print-test print.integers.base.36.4 37 "11" (*print-base* 36)) (def-print-test print.integers.base.36.5 (* 36 36) "100" (*print-base* 36)) (def-print-test print.integers.base.36.6 -1 "-1" (*print-base* 36)) (def-print-test print.integers.base.36.7 -14 "-E" (*print-base* 36)) (def-print-test print.integers.base.36.8 -35 "-Z" (*print-base* 36)) (def-print-test print.integers.base.36.9 -37 "-11" (*print-base* 36)) (def-print-test print.integers.base.36.10 (- 2 (* 36 36)) "-ZY" (*print-base* 36)) (def-print-test print.integers.base.36.11 (expt 36 40) "10000000000000000000000000000000000000000" (*print-base* 36)) (def-print-test print.integers.base.36.12 (- (expt 36 40)) "-10000000000000000000000000000000000000000" (*print-base* 36)) ;;; With *print-radix* (def-print-test print.integers.radix.0 0 "0." (*print-radix* t)) (def-print-test print.integers.radix.1 1 "1." (*print-radix* t)) (def-print-test print.integers.radix.2 123456 "123456." (*print-radix* t)) (def-print-test print.integers.radix.3 123456789 "123456789." (*print-radix* t)) (def-print-test print.integers.radix.4 -5 "-5." (*print-radix* t)) (def-print-test print.integers.radix.5 -249213 "-249213." (*print-radix* t)) (def-print-test print.integers.radix.6 -917512001 "-917512001." (*print-radix* t)) (def-print-test print.integers.radix.base.2.0 0 "#b0" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.1 1 "#b1" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.2 2 "#b10" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.3 3 "#b11" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.4 -1 "#b-1" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.5 -2 "#b-10" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.6 -3 "#b-11" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.7 256 "#b100000000" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.8 -256 "#b-100000000" (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.9 (expt 2 100) (concatenate 'string "#b1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.2.10 (- (expt 2 200)) (concatenate 'string "#b-1" (make-string 200 :initial-element #\0)) (*print-radix* t) (*print-base* 2)) (def-print-test print.integers.radix.base.3.0 0 "#3r0" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.1 1 "#3r1" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.2 2 "#3r2" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.3 4 "#3r11" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.4 -1 "#3r-1" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.5 -2 "#3r-2" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.6 -4 "#3r-11" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.7 6561 "#3r100000000" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.8 -81 "#3r-10000" (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.9 (expt 3 100) (concatenate 'string "#3r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.3.10 (- 1 (expt 3 200)) (concatenate 'string "#3r-" (make-string 200 :initial-element #\2)) (*print-radix* t) (*print-base* 3)) (def-print-test print.integers.radix.base.5.0 0 "#5r0" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.1 1 "#5r1" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.2 2 "#5r2" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.3 6 "#5r11" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.4 -1 "#5r-1" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.5 -2 "#5r-2" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.6 -8 "#5r-13" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.7 390625 "#5r100000000" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.8 -625 "#5r-10000" (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.9 (expt 5 100) (concatenate 'string "#5r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.5.10 (- 1 (expt 5 200)) (concatenate 'string "#5r-" (make-string 200 :initial-element #\4)) (*print-radix* t) (*print-base* 5)) (def-print-test print.integers.radix.base.8.0 0 "#o0" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.1 1 "#o1" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.2 2 "#o2" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.3 9 "#o11" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.4 -1 "#o-1" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.5 -2 "#o-2" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.6 -11 "#o-13" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.7 16777216 "#o100000000" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.8 -4096 "#o-10000" (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.9 (expt 8 100) (concatenate 'string "#o1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.8.10 (- 1 (expt 8 200)) (concatenate 'string "#o-" (make-string 200 :initial-element #\7)) (*print-radix* t) (*print-base* 8)) (def-print-test print.integers.radix.base.12.0 0 "#12r0" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.1 1 "#12r1" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.2 2 "#12r2" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.3 13 "#12r11" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.4 -1 "#12r-1" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.5 -2 "#12r-2" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.6 -15 "#12r-13" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.7 (expt 12 8) "#12r100000000" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.8 (- (* 12 12 12 12)) "#12r-10000" (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.9 (expt 12 100) (concatenate 'string "#12r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.12.10 (- 1 (expt 12 200)) (concatenate 'string "#12r-" (make-string 200 :initial-element #\B)) (*print-radix* t) (*print-base* 12)) (def-print-test print.integers.radix.base.16.0 0 "#x0" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.1 1 "#x1" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.2 2 "#x2" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.3 17 "#x11" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.4 -1 "#x-1" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.5 -2 "#x-2" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.6 -19 "#x-13" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.7 (expt 16 8) "#x100000000" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.8 (- (* 16 16 16 16)) "#x-10000" (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.9 (expt 16 100) (concatenate 'string "#x1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.16.10 (- 1 (expt 16 200)) (concatenate 'string "#x-" (make-string 200 :initial-element #\F)) (*print-radix* t) (*print-base* 16)) (def-print-test print.integers.radix.base.36.0 0 "#36r0" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.1 1 "#36r1" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.2 2 "#36r2" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.3 37 "#36r11" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.4 -1 "#36r-1" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.5 -2 "#36r-2" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.6 -39 "#36r-13" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.7 (expt 36 8) "#36r100000000" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.8 (- (* 36 36 36 36)) "#36r-10000" (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.9 (expt 36 100) (concatenate 'string "#36r1" (make-string 100 :initial-element #\0)) (*print-radix* t) (*print-base* 36)) (def-print-test print.integers.radix.base.36.10 (- 1 (expt 36 200)) (concatenate 'string "#36r-" (make-string 200 :initial-element #\Z)) (*print-radix* t) (*print-base* 36)) (deftest print.integers.base.various.1 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b)) (loop for i from 1 to 100 for n = (expt b i) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.base.various.2 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b)) (loop for i from 1 to 100 for n = (- (expt b i)) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.base.various.3 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b) (*print-radix* t)) (loop for i from 1 to 100 for n = (expt b i) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.base.various.4 (with-standard-io-syntax (loop for b from 2 to 36 nconc (let ((*print-base* b) (*read-base* b) (*print-radix* t)) (loop for i from 1 to 100 for n = (- (expt b i)) for str = (with-output-to-string (s) (prin1 n s)) for result = (read-from-string str) unless (= n result) collect (list b i n str result))))) nil) (deftest print.integers.random.1 (loop for numbits = (random 40) for bound = (ash 1 numbits) for r = (- (random (+ bound bound)) bound) repeat 10000 nconc (randomly-check-readability r)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/keyword.lsp0000644000000000000000000000013114542551762015654 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.649789874 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/keyword.lsp0000644000175000017500000000746014542551762015262 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:53:55 2004 ;;;; Contains: Tests of the KEYWORD package (in-package :cl-test) ;; Check that each keyword satisfies keywordp (deftest keyword.1 (do-symbols (s "KEYWORD" t) (unless (keywordp s) (return (list s nil)))) t) ;; Check that symbols that are interned in the KEYWORD ;; package, but do not have KEYWORD as their home package, ;; are in fact keywords. ;; ;; This came up on the #lisp irc channel ;;; ;;; The following two tests are improper, since (see the page for SYMBOL) ;;; "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." ;;; ;;; They could be rewritten to search for a name that is not interned in KEYWORD. ;;; #| (deftest keyword.4 (let ((name "SYMBOL-NAME-FOR-KEYWORD.4") (kwp (find-package "KEYWORD"))) (let ((s (find-symbol name kwp))) (when s (unintern s kwp)) ;; Now, create a symbol with this name ;; and import it into the keyword package (setq s (make-symbol name)) (import s kwp) ;; Check that it's a keyword (values (eqlt (symbol-package s) kwp) (eqlt (find-symbol name kwp) s) (nth-value 1 (find-symbol name kwp)) (notnot (typep s 'keyword)) (if (boundp s) (eqlt s (symbol-value s)) :not-bound) (notnot (constantp s))))) t t :external t t t) (deftest keyword.5 (let* ((name "SYMBOL-NAME-FOR-KEYWORD.5") (pkg-name "PACKAGE-FOR-KEYWORD.5") (kwp (find-package "KEYWORD"))) (safely-delete-package pkg-name) (let* ((pkg (make-package pkg-name :use nil)) (s (find-symbol name kwp))) (when s (unintern s kwp)) ;; Now, create a symbol with this name ;; and import it into the keyword package (setq s (intern name pkg)) (import s kwp) ;; Check that it's a keyword (values (eqlt (symbol-package s) pkg) (eqlt (find-symbol name kwp) s) (nth-value 1 (find-symbol name kwp)) (notnot (typep s 'keyword)) (if (boundp s) (eqlt s (symbol-value s)) :not-bound) (notnot (constantp s))))) t t :external t t t) (deftest keyword.6 (let* ((name "SYMBOL-NAME-FOR-KEYWORD.6") (pkg-name "PACKAGE-FOR-KEYWORD.6") (kwp (find-package "KEYWORD"))) (safely-delete-package pkg-name) (let* ((pkg (make-package pkg-name :use nil)) (s (find-symbol name kwp)) s2) (when s (unintern s kwp)) ;; Recreate a symbol with this name in the keyword package ;; shadowing-import will displace this symbol (setq s2 (intern name kwp)) ;; Now, create a symbol with this name ;; and shadowing-import it into the keyword package (setq s (intern name pkg)) (shadowing-import s kwp) ;; Check that it's a keyword (values (eqt s s2) (symbol-package s2) (eqlt (symbol-package s) pkg) (eqlt (find-symbol name kwp) s) (nth-value 1 (find-symbol name kwp)) (notnot (typep s 'keyword)) (if (boundp s) (eqlt s (symbol-value s)) :not-bound) (notnot (constantp s))))) nil nil t t :external t t t) |# ;;; Note that the case of a symbol inherited into KEYWORD cannot arise ;;; standardly from user actions, since USE-PACKAGE disallows KEYWORD ;;; as the package designated by its second argument. ;; 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) (cond ((not (boundp s)) (return (list s "NOT-BOUND"))) ((not (eqt s (eval s))) (return (list s (eval s)))))) t) gcl-2.7.1/ansi-tests/PaxHeaders/real.lsp0000644000000000000000000000013114542551763015114 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.649789874 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/real.lsp0000644000175000017500000000257014542551763014517 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 31 21:41:49 2004 ;;;; Contains: Additional tests of the REAL type specifier (in-package :cl-test) (deftest real.1 (loop for i = 1 then (ash i 1) for tp = `(real 0 ,i) repeat 200 unless (and (not (typep -1 tp)) (not (typep -0.0001 tp)) (typep 0 tp) (typep 0.0001 tp) (typep 1 tp) (typep i tp) (not (typep (1+ i) tp))) collect (list i tp)) nil) (deftest real.2 (loop for i = 1 then (ash i 1) for tp = `(real ,(- i) 0) repeat 200 unless (and (not (typep (- -1 i) tp)) (typep (- i) tp) (typep -1 tp) (typep 0 tp) (not (typep 1 tp)) (not (typep i tp)) (not (typep (1+ i) tp))) collect (list i tp)) nil) (deftest real.3 (loop for i = 4 then (ash i 1) for tp = `(real 0 ,(/ i 3)) repeat 200 unless (and (not (typep -1 tp)) (not (typep -0.0001 tp)) (typep 0 tp) (typep 0.0001 tp) (typep 1 tp) (typep (/ i 3) tp) (not (typep (/ (1+ i) 3) tp))) collect (list i tp)) nil) (deftest real.4 (loop for i = 4 then (ash i 1) for tp = `(real ,(- (/ i 3)) 0) repeat 200 unless (and (not (typep (- -1 (/ i 3)) tp)) (typep (- (/ i 3)) tp) (typep -1 tp) (typep 0 tp) (not (typep 1 tp)) (not (typep (/ i 3) tp)) (not (typep (1+ (/ i 3)) tp))) collect (list i tp)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/compute-applicable-methods.lsp0000644000000000000000000000013014542551762021376 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.653789891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compute-applicable-methods.lsp0000644000175000017500000000665614542551762021013 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 2 06:40:41 2003 ;;;; Contains: Tests for COMPUTE-APPLICABLE-METHODS (in-package :cl-test) (defgeneric cam-gf-01 (x y)) (defparameter *cam-gf-01-method1* (defmethod cam-gf-01 ((x integer) (y integer)) 1)) (defparameter *cam-gf-01-method2* (defmethod cam-gf-01 ((x integer) (y t)) 2)) (defparameter *cam-gf-01-method3* (defmethod cam-gf-01 ((x t) (y integer)) 3)) (defparameter *cam-gf-01-method4* (defmethod cam-gf-01 ((x t) (y t)) 4)) (deftest compute-applicable-methods.1 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 2)))) (equalt methods (list *cam-gf-01-method1* *cam-gf-01-method2* *cam-gf-01-method3* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.2 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 'x)))) (equalt methods (list *cam-gf-01-method2* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.3 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 'x 10)))) (equalt methods (list *cam-gf-01-method3* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.4 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 'x 'y)))) (equalt methods (list *cam-gf-01-method4*))) t) (defgeneric cam-gf-02 (x)) (deftest compute-applicable-methods.5 (compute-applicable-methods #'cam-gf-02 '(1)) nil) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric cam-gf-03 (x) (:method-combination + :most-specific-first)) (defparameter *cam-gf-03-method1* (defmethod cam-gf-03 + ((x integer)) 1)) (defparameter *cam-gf-03-method2* (defmethod cam-gf-03 + ((x rational)) 2)) (defparameter *cam-gf-03-method3* (defmethod cam-gf-03 + ((x real)) 4)) (defparameter *cam-gf-03-method4* (defmethod cam-gf-03 + ((x number)) 8)) (defparameter *cam-gf-03-method5* (defmethod cam-gf-03 + ((x t)) 16)))) (deftest compute-applicable-methods.6 (equalt (compute-applicable-methods #'cam-gf-03 (list 0)) (list *cam-gf-03-method1* *cam-gf-03-method2* *cam-gf-03-method3* *cam-gf-03-method4* *cam-gf-03-method5*)) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric cam-gf-04 (x) (:method-combination + :most-specific-last)) (defparameter *cam-gf-04-method1* (defmethod cam-gf-04 + ((x integer)) 1)) (defparameter *cam-gf-04-method2* (defmethod cam-gf-04 + ((x rational)) 2)) (defparameter *cam-gf-04-method3* (defmethod cam-gf-04 + ((x real)) 4)) (defparameter *cam-gf-04-method4* (defmethod cam-gf-04 + ((x number)) 8)) (defparameter *cam-gf-04-method5* (defmethod cam-gf-04 + ((x t)) 16)) )) (deftest compute-applicable-methods.7 (equalt (compute-applicable-methods #'cam-gf-04 (list 0)) (list *cam-gf-04-method1* *cam-gf-04-method2* *cam-gf-04-method3* *cam-gf-04-method4* *cam-gf-04-method5*)) t) ;;; Need tests with :around, :before, :after methods ;;; Error tests (deftest compute-applicable-methods.error.1 (signals-error (compute-applicable-methods) program-error) t) (deftest compute-applicable-methods.error.2 (signals-error (compute-applicable-methods #'cam-gf-01) program-error) t) (deftest compute-applicable-methods.error.3 (signals-error (compute-applicable-methods #'cam-gf-01 '(1 2) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/modules8b.lsp0000644000000000000000000000013114542551763016073 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.653789891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/modules8b.lsp0000644000175000017500000000007214542551763015471 0ustar00cammcamm(in-package :cl-test) (defun modules8b-fun () :also-good) gcl-2.7.1/ansi-tests/PaxHeaders/acosh.lsp0000644000000000000000000000013214542551762015266 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.653789891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/acosh.lsp0000644000175000017500000000411414542551762014664 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:20:53 2004 ;;;; Contains: Tests of ACOSH (in-package :cl-test) (deftest acosh.1 (let ((result (acosh 1))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest acosh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (equal (multiple-value-list (acosh one)) (list zero)) collect type) nil) (deftest acosh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) for one = (coerce 1 `(complex ,type)) unless (equal (multiple-value-list (acosh one)) (list zero)) collect type) nil) (deftest acosh.4 (loop for den = (1+ (random 10000)) for num = (random (* 10 den)) for x = (/ num den) for rlist = (multiple-value-list (acosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest acosh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (1+ (random (coerce 1000 type))) for rlist = (multiple-value-list (acosh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest acosh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 20 type)) 10) for x2 = (- (random (coerce 20 type)) 10) for rlist = (multiple-value-list (acosh (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) nil) (deftest acosh.7 (macrolet ((%m (z) z)) (not (not (complexp (acosh (expand-in-current-env (%m 0))))))) t) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest acosh.error.1 (signals-error (acosh) program-error) t) (deftest acosh.error.2 (signals-error (acosh 1.0 1.0) program-error) t) (deftest acosh.error.3 (check-type-error #'acosh #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/compile-and-load.lsp0000644000000000000000000000013014542551762017274 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.653789891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-and-load.lsp0000644000175000017500000000324014542551762016673 0ustar00cammcamm#-(and gcl (not ansi-cl)) (in-package :common-lisp-user) #+(and gcl (not ansi-cl)) (in-package "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-toplevel :compile-toplevel :execute) ;; (intern "==>" "CL-USER") (unless (fboundp 'compile-file-pathname) (defun compile-file-pathname (pathname) (make-pathname :defaults pathname :type "o")))) ;;; On-demand compile and load (defvar *compiled-and-loaded-files* nil "List containing pathname, creation times for files that have already been loaded.") (defun compile-and-load (pathspec &key force) "Find the file indicated by PATHSPEC, compiling it first if the associated compiled file is out of date." (let* ((pathname (pathname pathspec)) (pathname (if *load-pathname* (merge-pathnames pathname *load-pathname*) pathname)) (former-data (assoc pathname *compiled-and-loaded-files* :test #'equalp)) (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)))) (unless (and (not force) former-data (>= (cadr former-data) source-write-time)) (when (or (not target-write-time) (<= target-write-time source-write-time)) (handler-bind #-sbcl () #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) (compile-file pathname))) (if former-data (setf (cadr former-data) source-write-time) (push (list pathname source-write-time) *compiled-and-loaded-files*)) (load compile-pathname)))) gcl-2.7.1/ansi-tests/PaxHeaders/package-error.lsp0000644000000000000000000000013114542551763016713 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.653789891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-error.lsp0000644000175000017500000000116614542551763016316 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:52:21 2004 ;;;; Contains: Tests of the condition PACKAGE-ERROR (in-package :cl-test) (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) gcl-2.7.1/ansi-tests/PaxHeaders/packages-17.lsp0000644000000000000000000000013114542551763016174 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.653789891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-17.lsp0000644000175000017500000000621314542551763015575 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/realp.lsp0000644000000000000000000000013114542551763015274 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.653789891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/realp.lsp0000644000175000017500000000122714542551763014675 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:22:06 2003 ;;;; Contains: Tests of REALP (in-package :cl-test) (deftest realp.error.1 (signals-error (realp) program-error) t) (deftest realp.error.2 (signals-error (realp 0 nil) program-error) t) (deftest realp.error.3 (signals-error (realp nil nil) program-error) t) (deftest realp.1 (notnot-mv (realp 0)) t) (deftest realp.2 (notnot-mv (realp 0.0)) t) (deftest realp.3 (realp #c(1 2)) nil) (deftest realp.4 (notnot-mv (realp 17/13)) t) (deftest realp.5 (realp 'a) nil) (deftest realp.6 (check-type-predicate #'realp 'real) nil) gcl-2.7.1/ansi-tests/PaxHeaders/compiled-function-p.lsp0000644000000000000000000000013014542551762020043 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.653789891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compiled-function-p.lsp0000644000175000017500000000145414542551762017447 0ustar00cammcamm;-*- 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 (check-type-predicate #'compiled-function-p 'compiled-function) 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 (signals-error (compiled-function-p) program-error) t) (deftest compiled-function-p.error.2 (signals-error (compiled-function-p nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/define-method-combination.lsp0000644000000000000000000000013214542551762021201 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.653789891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-method-combination.lsp0000644000175000017500000001205614542551762020603 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 10:49:39 2003 ;;;; Contains: Tests of DEFINE-METHOD-COMBINATION (in-package :cl-test) (defclass dmc-class-01a () ()) (defclass dmc-class-01b (dmc-class-01a) ()) (defclass dmc-class-01c (dmc-class-01a) ()) (defclass dmc-class-01d (dmc-class-01b dmc-class-01c) ()) (defclass dmc-class-01e (dmc-class-01c dmc-class-01b) ()) (defclass dmc-class-01f (dmc-class-01d) ()) (defclass dmc-class-01g (dmc-class-01a) ()) (defclass dmc-class-01h (dmc-class-01f dmc-class-01g) ()) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defvar *dmc-times* (define-method-combination times :documentation "Multiplicative method combination, version 1" :operator *)) (defgeneric dmc-gf-01 (x) (:method-combination times)) (defmethod dmc-gf-01 times ((x integer)) 2) (defmethod dmc-gf-01 times ((x rational)) 3) (defmethod dmc-gf-01 times ((x real)) 5) (defmethod dmc-gf-01 times ((x number)) 7) (defmethod dmc-gf-01 times ((x complex)) 11) )) (deftest define-method-combination-01.1 (values (dmc-gf-01 1) (dmc-gf-01 1/2) (dmc-gf-01 1.0) (dmc-gf-01 #c(1 2))) 210 105 35 77) (deftest define-method-combination-01.2 (handler-case (eval '(locally (declare (optimize (safety 3))) (dmc-gf-01 'x))) (error () :good)) :good) (deftest define-method-combination-01.3 *dmc-times* times) (deftest define-method-combination-01.4 (let ((doc (documentation *dmc-times* 'method-combination))) (or (null doc) (equalt doc "Multiplicative method combination, version 1"))) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric dmc-gf-02 (x) (:method-combination times)) (defmethod dmc-gf-02 times ((x integer)) 2) (defmethod dmc-gf-02 :around ((x rational)) (1- (call-next-method))) (defmethod dmc-gf-02 times ((x real)) 3) (defmethod dmc-gf-02 times ((x number)) 5) (defmethod dmc-gf-02 :around ((x (eql 1.0s0))) 1) )) (deftest define-method-combination-02.1 (values (dmc-gf-02 1) (dmc-gf-02 1/3) (dmc-gf-02 1.0s0) (dmc-gf-02 13.0) (dmc-gf-02 #c(1 2))) 29 14 1 15 5) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric dmc-gf-03 (x) (:method-combination times)))) (deftest define-method-combination-03.1 (prog1 (handler-case (progn (eval '(defmethod dmc-gf-03 ((x integer)) t)) (eval '(dmc-gf-03 1)) :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 1))) (remove-method #'dmc-gf-03 meth))) :good) (deftest define-method-combination-03.2 (prog1 (handler-case (progn (eval '(defmethod dmc-gf-03 :before ((x cons)) t)) (eval '(dmc-gf-03 (cons 'a 'b))) :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list '(a)))) (remove-method #'dmc-gf-03 meth))) :good) (deftest define-method-combination-03.3 (prog1 (handler-case (progn (eval '(defmethod dmc-gf-03 :after ((x symbol)) t)) (eval '(dmc-gf-03 'a)) :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 'a))) (remove-method #'dmc-gf-03 meth))) :good) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (define-method-combination times2 :operator * :identity-with-one-argument t) (defgeneric dmc-gf-04 (x) (:method-combination times2)) (defmethod dmc-gf-04 times2 ((x dmc-class-01b)) 2) (defmethod dmc-gf-04 times2 ((x dmc-class-01c)) 3) (defmethod dmc-gf-04 times2 ((x dmc-class-01d)) 5) (defmethod dmc-gf-04 times2 ((x symbol)) nil) )) (deftest define-method-combination-04.1 (dmc-gf-04 (make-instance 'dmc-class-01h)) 30) (deftest define-method-combination-04.2 (dmc-gf-04 (make-instance 'dmc-class-01e)) 6) (deftest define-method-combination-04.3 (dmc-gf-04 'a) nil) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defvar *dmc-times-5* (define-method-combination times-5 :operator *)))) (deftest define-method-combination-05.1 (let* ((doc1 (setf (documentation *dmc-times-5* 'method-combination) "foo")) (doc2 (documentation *dmc-times-5* 'method-combination))) (values doc1 (or (null doc2) (equalt doc2 "foo")))) "foo" t) ;; Operator name defaults to the method combination name. (eval-when (:load-toplevel :compile-toplevel :execute) (defun times-7 (&rest args) (apply #'* args)) (report-and-ignore-errors (defvar *dmc-times-7* (define-method-combination times-7)) (defgeneric dmc-gf-07 (x) (:method-combination times)) (defmethod dmc-gf-07 times ((x integer)) 2) (defmethod dmc-gf-07 times ((x rational)) 3) (defmethod dmc-gf-07 times ((x real)) 5) (defmethod dmc-gf-07 times ((x number)) 7) (defmethod dmc-gf-07 times ((x complex)) 11) )) (deftest define-method-combination-07.1 (values (dmc-gf-07 1) (dmc-gf-07 1/2) (dmc-gf-07 1.0) (dmc-gf-07 #c(1 2))) 210 105 35 77) gcl-2.7.1/ansi-tests/PaxHeaders/defconstant.lsp0000644000000000000000000000013214542551762016501 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.653789891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defconstant.lsp0000644000175000017500000000276314542551762016107 0ustar00cammcamm;-*- 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 ;;; (signals-error (defconstant) program-error) ;;; t) ;;; ;;; (deftest defconstant.error.2 ;;; (signals-error (defconstant +ignorable-constant-name+) program-error) ;;; t) ;;; ;;; (deftest defconstant.error.3 ;;; (signals-error (defconstant +ignorable-constant-name2+ nil ;;; "This is a docstring" ;;; "This is an unnecessary extra argument.") ;;; program-error) ;;; t) (deftest defconstant.error.1 (signals-error (funcall (macro-function 'defconstant)) program-error) t) (deftest defconstant.error.2 (signals-error (funcall (macro-function 'defconstant) '(defconstant +nonexistent-constant+ 0)) program-error) t) (deftest defconstant.error.3 (signals-error (funcall (macro-function 'defconstant) '(defconstant +nonexistent-constant+ 0) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-progn.lsp0000644000000000000000000000013214542551762023165 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.653789891 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-progn.lsp0000644000175000017500000002030314542551762022561 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination OR (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.progn.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.progn.1 (x) (:method-combination progn) (:method progn ((x integer)) (push 4 *x*) nil) (:method progn ((x rational)) (push 3 *x*) nil) (:method progn ((x number)) (push 2 *x*) nil) (:method progn ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (1 2 3 4)) (a (1 2 3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.progn.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.progn.2 (x) (:method-combination progn :most-specific-first) (:method progn ((x integer)) (push 4 *x*) 'a) (:method progn ((x rational)) (push 3 *x*) 'b) (:method progn ((x number)) (push 2 *x*) 'c) (:method progn ((x t)) (push 1 *x*) 'd))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (d (1 2 3 4)) (d (1 2 3)) (d (1 2)) (d (1))) (deftest defgeneric-method-combination.progn.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.progn.3 (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) (push 4 *x*) 'a) (:method progn ((x rational)) (push 3 *x*) 'b) (:method progn ((x number)) (push 2 *x*) 'c) (:method progn ((x t)) (push 1 *x*) 'd))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (4 3 2 1)) (b (3 2 1)) (c (2 1)) (d (1))) (deftest defgeneric-method-combination.progn.4 (let ((fn (eval '(defgeneric dg-mc.progn.4 (x) (:method-combination progn) (:method progn ((x integer)) 'd) (:method :around ((x rational)) 'foo) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo a a a) (deftest defgeneric-method-combination.progn.4a (let ((fn (eval '(defgeneric dg-mc.progn.4a (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) 'd) (:method :around ((x rational)) 'foo) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo b c a) (deftest defgeneric-method-combination.progn.5 (let ((fn (eval '(defgeneric dg-mc.progn.5 (x) (:method-combination progn) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method progn ((x number)) nil) (:method progn ((x symbol)) 'b) (:method progn ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo c) (foo c) c c c) (deftest defgeneric-method-combination.progn.5a (let ((fn (eval '(defgeneric dg-mc.progn.5a (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method progn ((x number)) 'e) (:method progn ((x symbol)) 'b) (:method progn ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo a) (foo e) e b c) (deftest defgeneric-method-combination.progn.6 (let ((fn (eval '(defgeneric dg-mc.progn.6 (x) (:method-combination progn) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar d)) (foo (bar d)) (bar d) d d d) (deftest defgeneric-method-combination.progn.6a (let ((fn (eval '(defgeneric dg-mc.progn.6a (x) (:method-combination progn :most-specific-last) (:method progn ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method progn ((x number)) 'b) (:method progn ((x symbol)) 'c) (:method progn ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar a)) (foo (bar b)) (bar b) b c d) (deftest defgeneric-method-combination.progn.7 (let ((fn (eval '(defgeneric dg-mc.progn.7 (x) (:method-combination progn) (:method progn ((x dgmc-class-04)) 'a) (:method progn ((x dgmc-class-03)) 'b) (:method progn ((x dgmc-class-02)) 'c) (:method progn ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) d d d d) (deftest defgeneric-method-combination.progn.7a (let ((fn (eval '(defgeneric dg-mc.progn.7a (x) (:method-combination progn :most-specific-last) (:method progn ((x dgmc-class-04)) 'a) (:method progn ((x dgmc-class-03)) 'b) (:method progn ((x dgmc-class-02)) 'c) (:method progn ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) d c b a) (deftest defgeneric-method-combination.progn.8 (let ((fn (eval '(defgeneric dg-mc.progn.8 (x) (:method-combination progn) (:method progn ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method progn ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (b)) (deftest defgeneric-method-combination.progn.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.progn.9 (x) (:method-combination progn))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.progn.10 (progn (eval '(defgeneric dg-mc.progn.10 (x) (:method-combination progn) (:method ((x t)) 0))) (handler-case (dg-mc.progn.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.progn.11 (progn (eval '(defgeneric dg-mc.progn.11 (x) (:method-combination progn) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.progn.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.progn.12 (let ((fn (eval '(defgeneric dg-mc.progn.12 (x) (:method-combination progn) (:method :around ((x t)) 'a) (:method progn ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'b) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/nsubst-if.lsp0000644000000000000000000000013114542551763016103 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.653789891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nsubst-if.lsp0000644000175000017500000000544314542551763015510 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:51:41 2003 ;;;; Contains: Tests of NSUBST-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (deftest nsubst-if.1 (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (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.4 (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (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.6 (check-nsubst-if 'a #'(lambda (x) (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.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) ;;; 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) ;;; error cases (deftest nsubst-if.error.1 (signals-error (nsubst-if) program-error) t) (deftest nsubst-if.error.2 (signals-error (nsubst-if 'a) program-error) t) (deftest nsubst-if.error.3 (signals-error (nsubst-if 'a #'null) program-error) t) (deftest nsubst-if.error.4 (signals-error (nsubst-if 'a #'null nil :foo nil) program-error) t) (deftest nsubst-if.error.5 (signals-error (nsubst-if 'a #'null nil :test) program-error) t) (deftest nsubst-if.error.6 (signals-error (nsubst-if 'a #'null nil 1) program-error) t) (deftest nsubst-if.error.7 (signals-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest nsubst-if.error.8 (signals-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/search-aux.lsp0000644000000000000000000000013214542551763016232 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.653789891 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/search-aux.lsp0000644000175000017500000000575214542551763015641 0ustar00cammcamm;-*- 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)))) (setq test (coerce test 'function)) (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 (the function 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.7.1/ansi-tests/PaxHeaders/fround.lsp0000644000000000000000000000013214542551762015466 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.653789891 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fround.lsp0000644000175000017500000000702314542551762015066 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Aug 21 16:07:59 2003 ;;;; Contains: Tests of FROUND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "fround-aux.lsp") ;;; Error tests (deftest fround.error.1 (signals-error (fround) program-error) t) (deftest fround.error.2 (signals-error (fround 1.0 1 nil) program-error) t) ;;; Non-error tests (deftest fround.1 (fround.1-fn) nil) (deftest fround.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (fround x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fround.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (fround (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest fround.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'short-float)) (eql r (- rrad))) collect (list i x q r))) nil) (deftest fround.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'single-float)) (eql r (- rrad))) collect (list i x q r))) nil) (deftest fround.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'double-float)) (eql r (- rrad))) collect (list i x q r))) nil) (deftest fround.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'long-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest fround.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (fround x)) unless (and (eql q (coerce i 'long-float)) (eql r (- rrad))) collect (list i x q r))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/member.lsp0000644000000000000000000000013114542551763015440 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.653789891 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/member.lsp0000644000175000017500000001536714542551763015053 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:38:57 1998 ;;;; Contains: Tests of MEMBER (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (deftest member.20 (member 10 '(1 2 3 4 10 11 14 18) :test #'<) (11 14 18)) (deftest member.21 (member 10 '(1 2 3 4 10 11 14 18) :test-not #'>=) (11 14 18)) (defharmless member.test-and-test-not.1 (member 'b '(a b c) :test #'eql :test-not #'eql)) (defharmless member.test-and-test-not.2 (member 'b '(a b c) :test-not #'eql :test #'eql)) ;;; 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 (check-type-error #'(lambda (x) (member 'a x)) #'listp) nil) (deftest member.error.2 (signals-error (member 'a 1.3) type-error) t) (deftest member.error.3 (signals-error (member 'a 1) type-error) t) (deftest member.error.4 (signals-error (member 'a 0) type-error) t) (deftest member.error.5 (signals-error (member 'a "abcde") type-error) t) (deftest member.error.6 (signals-error (member 'a #\w) type-error) t) (deftest member.error.7 (signals-error (member 'a t) type-error) t) (deftest member.error.8 (signals-error (member) program-error) t) (deftest member.error.9 (signals-error (member nil) program-error) t) (deftest member.error.10 (signals-error (member nil nil :bad t) program-error) t) (deftest member.error.11 (signals-error (member nil nil :test) program-error) t) (deftest member.error.12 (signals-error (member nil nil :bad t :allow-other-keys nil) program-error) t) (deftest member.error.13 (signals-error (member nil nil nil) program-error) t) (deftest member.error.14 (signals-error (locally (member 'a t) t) type-error) t) (deftest member.error.15 (signals-error (member 'a '(a b c) :test #'identity) program-error) t) (deftest member.error.16 (signals-error (member 'a '(a b c) :test-not #'identity) program-error) t) (deftest member.error.17 (signals-error (member 'a '(a b c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/merge-pathnames.lsp0000644000000000000000000000013114542551763017246 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.657789909 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/merge-pathnames.lsp0000644000175000017500000001027414542551763016651 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/pprint-newline.lsp0000644000000000000000000000013114542551763017144 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.657789909 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-newline.lsp0000644000175000017500000002326014542551763016546 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 7 07:48:01 2004 ;;;; Contains: Tests of PPRINT-NEWLINE (in-package :cl-test) (compile-and-load "printer-aux.lsp") (defmacro def-pprint-newline-test (name form expected-value &rest key-args) `(def-pprint-test ,name (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) ,form)) ,expected-value ,@key-args)) ;;; NIL designates the standard output (def-pprint-test pprint-newline.1 (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i 8) (write-char #\A) (write-char #\Space) (pprint-newline :fill nil)))) "A A A A A A A A " :margin 10) ;;; T designates the stream *terminal-io* (def-pprint-test pprint-newline.2 (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-logical-block (*terminal-io* nil) (dotimes (i 8) (write "A " :stream t) (pprint-newline :fill t)))))) "A A A A A A A A " :margin 10) ;;; No stream is standard output (def-pprint-test pprint-newline.3 (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i 8) (write-char #\A) (write-char #\Space) (pprint-newline :fill)))) "A A A A A A A A " :margin 10) ;;; :linear (def-ppblock-test pprint-newline.linear.1 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) (write "B ") (pprint-newline :linear) (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B A A A " :margin 10) (def-ppblock-test pprint-newline.linear.2 (progn (dotimes (i 2) (write "A ") (pprint-newline :fill)) (write "B ") (pprint-newline :linear) (dotimes (i 2) (write "C ") (pprint-newline :fill)) (write "D ") (pprint-newline :linear) (dotimes (i 3) (write "A ") (pprint-newline :fill))) "A A B C C D A A A " :margin 10) (def-ppblock-test pprint-newline.linear.3 (dotimes (i 4) (write "A ") (pprint-newline :linear)) "A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.4 (dotimes (i 4) (write "A ") (pprint-newline :linear)) "A A A A " :margin 10 :miser 10) (def-ppblock-test pprint-newline.linear.5 (dotimes (i 10) (write "A ") (pprint-newline :linear)) "A A A A A A A A A A " :margin 10 :pretty nil) (def-ppblock-test pprint-newline.linear.6 (dotimes (i 4) (write "A ") (pprint-newline :linear)) "A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.7 (progn (dotimes (i 4) (write "A ") (pprint-newline :linear)) (terpri) (dotimes (i 4) (write "A ") (pprint-newline :linear))) "A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.8 (progn (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :linear))) (pprint-newline :linear) (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :linear)))) "A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.linear.9 (dotimes (i 10) (write "A ") (let ((*print-pretty* nil)) (pprint-newline :linear))) "A A A A A A A A A A " :margin 10) (deftest pprint-newline.linear.10 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :linear))))) "A A A A A ") ;;; :miser (def-ppblock-test pprint-newline.miser.1 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.miser.2 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 0) (def-ppblock-test pprint-newline.miser.3 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test pprint-newline.miser.4 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test pprint-newline.miser.5 (dotimes (i 10) (write "A ") (pprint-newline :miser)) "A A A A A A A A A A " :margin 10 :miser 10 :pretty nil) (def-ppblock-test pprint-newline.miser.6 (progn (terpri) (write "A") (pprint-newline :miser)) " A " :margin 20 :miser 20) (def-ppblock-test pprint-newline.miser.7 (progn (pprint-newline :miser) (write "A") (terpri)) " A " :margin 20 :miser 20) (def-ppblock-test pprint-newline.miser.8 (progn (write "AAAA ") (pprint-newline :linear) (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :miser)))) "AAAA A A A A " :margin 10 :miser 8) (def-ppblock-test pprint-newline.miser.9 (progn (write "AAAA ") (pprint-newline :fill) (pprint-logical-block (*standard-output* nil) (dotimes (i 4) (write "A ") (pprint-newline :miser)))) "AAAA A A A A " :margin 10 :miser 8) (def-ppblock-test pprint-newline.miser.10 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") (write "A") (pprint-newline :miser) (pprint-newline :mandatory)) "(A )" :margin 20 :miser 20) (def-ppblock-test pprint-newline.miser.11 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") (write "A") (pprint-newline :miser) (pprint-newline :mandatory)) "(A )" :margin 20 :miser 19) (def-ppblock-test pprint-newline.miser.12 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") (write "A") (pprint-newline :miser) (pprint-newline :mandatory)) "(A )" :margin 20 :miser 18) (deftest pprint-newline.miser.13 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* 4)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :miser))))) "A A A A A ") ;;; :fill (def-ppblock-test pprint-newline.fill.1 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 10) (def-ppblock-test pprint-newline.fill.2 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 6) (def-ppblock-test pprint-newline.fill.3 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 7) (def-ppblock-test pprint-newline.fill.4 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 10 :miser 9) (def-ppblock-test pprint-newline.fill.5 (dotimes (i 10) (write "A ") (pprint-newline :fill)) "A A A A A A A A A A " :margin 10 :miser 10) (def-ppblock-test pprint-newline.fill.6 (dotimes (i 5) (write '(A B)) (write #\Space) (pprint-newline :fill)) "(A B) (A B) (A B) (A B) (A B) " :margin 12) (def-ppblock-test pprint-newline.fill.7 (dolist (x '(A (A B) (A A A A A A A A) X (C D) (E F))) (pprint-fill nil x) (write #\Space) (pprint-newline :fill)) "A (A B) (A A A A A A A A) X (C D) (E F) " :margin 12) (def-ppblock-test pprint-newline.fill.8 (dotimes (i 5) (write '(A B) :pretty nil) (write #\Space) (let ((*print-pretty* nil)) (pprint-newline :fill))) "(A B) (A B) (A B) (A B) (A B) " :margin 12) (deftest pprint-newline.fill.9 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :fill))))) "A A A A A ") (deftest pprint-newline.fill.10 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-right-margin* 4) (*print-pretty* t) (*print-miser-width* 4)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :fill))))) "A A A A A ") ;;; :mandatory (def-ppblock-test pprint-newline.mandatory.1 (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) "A A A A ") (def-ppblock-test pprint-newline.mandatory.2 (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) "A A A A " :margin 10) (def-ppblock-test pprint-newline.mandatory.3 (progn (write "A ") (pprint-newline :mandatory) (write "A ")) "A A " :margin 1) (def-ppblock-test pprint-newline.mandatory.4 (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) "A A A A " :pretty nil) (def-ppblock-test pprint-newline.mandatory.5 (pprint-logical-block (*standard-output* nil :prefix "<<<" :suffix ">>>") (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) (write "A")) "<<>>") (deftest pprint-newline.mandatory.6 (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil) (*print-pretty* t) (*print-right-margin* 4) (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :mandatory))))) "A A A A A ") ;;; Error cases (deftest pprint-newline.error.1 (check-type-error #'pprint-newline (typef '(member :linear :miser :fill :mandatory))) nil) (deftest pprint-newline.error.1-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-newline x)) (typef '(member :linear :miser :fill :mandatory))) nil) (deftest pprint-newline.error.2 (signals-error (pprint-newline) program-error) t) (deftest pprint-newline.error.3 (signals-error (pprint-newline :fill nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/string-upcase.lsp0000644000000000000000000000013214542551763016756 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.657789909 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-upcase.lsp0000644000175000017500000001056314542551763016361 0ustar00cammcamm;-*- 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.11 :notes (:nil-vectors-are-strings) (string-upcase (make-array '(0) :element-type nil)) "") (deftest string-upcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) (deftest string-upcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) (deftest string-upcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) ;;; Order of evaluation tests (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) ;;; Const fold tests (def-fold-test string-upcase.fold.1 (string-upcase "abcde")) ;;; Error tests (deftest string-upcase.error.1 (signals-error (string-upcase) program-error) t) (deftest string-upcase.error.2 (signals-error (string-upcase (copy-seq "abc") :bad t) program-error) t) (deftest string-upcase.error.3 (signals-error (string-upcase (copy-seq "abc") :start) program-error) t) (deftest string-upcase.error.4 (signals-error (string-upcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest string-upcase.error.5 (signals-error (string-upcase (copy-seq "abc") :end) program-error) t) (deftest string-upcase.error.6 (signals-error (string-upcase (copy-seq "abc") 1 2) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/get-internal-time.lsp0000644000000000000000000000013114542551762017515 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.657789909 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/get-internal-time.lsp0000644000175000017500000000321414542551762017114 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 20:28:21 2005 ;;;; Contains: Tests of GET-INTERNAL-REAL-TIME, GET-INTERNAL-RUN-TIME (in-package :cl-test) (deftest get-internal-real-time.1 (notnot-mv (typep (multiple-value-list (get-internal-real-time)) '(cons unsigned-byte null))) t) (deftest get-internal-real-time.2 (funcall (compile nil '(lambda () (let ((prev (get-internal-real-time))) (loop for next = (get-internal-real-time) repeat 100000 do (assert (>= next prev)) do (setf prev next)))))) nil) (deftest get-internal-real-time.error.1 (signals-error (get-internal-real-time nil) program-error) t) (deftest get-internal-real-time.error.2 (signals-error (get-internal-real-time :allow-other-keys t) program-error) t) ;;;;; (deftest get-internal-run-time.1 (notnot-mv (typep (multiple-value-list (get-internal-run-time)) '(cons unsigned-byte null))) t) (deftest get-internal-run-time.2 (funcall (compile nil '(lambda () (let ((prev (get-internal-run-time))) (loop for next = (get-internal-run-time) repeat 100000 do (assert (>= next prev)) do (setf prev next)))))) nil) (deftest get-internal-run-time.error.1 (signals-error (get-internal-run-time nil) program-error) t) (deftest get-internal-run-time.error.2 (signals-error (get-internal-run-time :allow-other-keys t) program-error) t) ;;; (deftest internal-time-units-per-second.1 (notnot-mv (constantp 'internal-time-units-per-second)) t) (deftest internal-time-units-per-second.2 (notnot-mv (typep internal-time-units-per-second '(integer 1))) t) gcl-2.7.1/ansi-tests/PaxHeaders/nintersection.lsp0000644000000000000000000000013114542551763017055 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.661789926 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nintersection.lsp0000644000175000017500000002225014542551763016455 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:40:02 2003 ;;;; Contains: Tests of NINTERSECTION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless nintersection.test-and-test-not.1 (nintersection (list 'a 'b 'c) (list 'a 'c 'e) :test #'eql :test-not #'eql)) (defharmless nintersection.test-and-test-not.2 (nintersection (list 'a 'b 'c) (list 'a 'c 'e) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (nintersection) program-error) t) (deftest nintersection.error.2 (signals-error (nintersection nil) program-error) t) (deftest nintersection.error.3 (signals-error (nintersection nil nil :bad t) program-error) t) (deftest nintersection.error.4 (signals-error (nintersection nil nil :key) program-error) t) (deftest nintersection.error.5 (signals-error (nintersection nil nil 1 2) program-error) t) (deftest nintersection.error.6 (signals-error (nintersection nil nil :bad t :allow-other-keys nil) program-error) t) (deftest nintersection.error.7 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity) program-error) t) (deftest nintersection.error.8 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity) program-error) t) (deftest nintersection.error.9 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons) program-error) t) (deftest nintersection.error.10 (signals-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car) type-error) t) (deftest nintersection.error.11 (signals-error (nintersection (list 1 2 3) (list* 4 5 6 7)) type-error) t) (deftest nintersection.error.12 (signals-error (nintersection (list* 1 2 3) (list 4 5 6)) type-error) t) (deftest nintersection.error.13 (check-type-error #'(lambda (x) (nintersection x (copy-seq '(a b c)))) #'listp) nil) (deftest nintersection.error.14 (check-type-error #'(lambda (x) (nintersection (copy-seq '(a b c)) x)) #'listp) nil)gcl-2.7.1/ansi-tests/PaxHeaders/compile-file-test-file-2a.lsp0000644000000000000000000000013014542551762020726 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.665789944 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-file-test-file-2a.lsp0000644000175000017500000000043314542551762020326 0ustar00cammcamm(in-package "CL-TEST") (defun compile-file-test-fun.2a () nil) (eval-when (:compile-toplevel) (unless (find-class 'compile-file-test-condition.2a nil) (define-condition compile-file-test-condition.2a (warning) nil)) (warn (make-condition 'compile-file-test-condition.2a))) gcl-2.7.1/ansi-tests/PaxHeaders/macroexpand-1.lsp0000644000000000000000000000013214542551763016631 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.665789944 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/macroexpand-1.lsp0000644000175000017500000000322714542551763016233 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 13:47:32 2005 ;;;; Contains: Tests of MACROEXPAND-1 (in-package :cl-test) (deftest macroexpand-1.error.1 (signals-error (macroexpand-1) program-error) t) (deftest macroexpand-1.error.2 (signals-error (macroexpand-1 'x nil nil) program-error) t) ;;; Non-error tests (deftest macroexpand-1.1 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand-1 x)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand-1.2 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand-1 x nil)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals))))))) nil) (deftest macroexpand-1.3 (macrolet ((%m (&environment env) `(quote ,(check-predicate #'(lambda (x) (or (symbolp x) (consp x) (let ((vals (multiple-value-list (macroexpand-1 x env)))) (and (= (length vals) 2) (eql (car vals) x) (null (cadr vals)))))))))) (%m)) nil) (deftest macroexpand-1.4 (macrolet ((%m () ''foo)) (macrolet ((%m2 (&environment env) (macroexpand-1 '(%m) env))) (%m2))) foo) (deftest macroexpand-1.5 (let ((form (list (gensym))) (i 0)) (values (equalt (macroexpand-1 (progn (incf i) form)) form) i)) t 1) (deftest macroexpand-1.6 (let ((form (list (gensym))) (i 0) a b) (values (equalt (macroexpand-1 (progn (setf a (incf i)) form) (progn (setf b (incf i)) nil)) form) i a b)) t 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/load-conditions.lsp0000644000000000000000000000013214772071547017262 xustar0030 mtime=1743287143.706899951 30 atime=1744294960.669789962 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-conditions.lsp0000644000175000017500000000126514772071547016664 0ustar00cammcamm;;; Tests of conditions (compile-and-load "types-aux.lsp") (compile-and-load "define-condition-aux.lsp") (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") (load "handler-case.lsp") (load "ignore-errors.lsp") (load "define-condition.lsp") (load "compute-restarts.lsp") (load "restart-bind.lsp") (load "restart-case.lsp") (load "with-condition-restarts.lsp") (load "with-simple-restart.lsp") (load "abort.lsp") (load "muffle-warning.lsp") (load "continue.lsp") (load "store-value.lsp") (load "use-value.lsp") (load "make-condition.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/ffloor.lsp0000644000000000000000000000013214542551762015460 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.669789962 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ffloor.lsp0000644000175000017500000000714514542551762015065 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 12 06:59:54 2003 ;;;; Contains: Tests of FFLOOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "ffloor-aux.lsp") (deftest ffloor.error.1 (signals-error (ffloor) program-error) t) (deftest ffloor.error.2 (signals-error (ffloor 1.0 1 nil) program-error) t) ;;; (deftest ffloor.1 (ffloor.1-fn) nil) (deftest ffloor.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (ffloor x x)) unless (and (floatp q) (if (floatp x) (eql q (float 1 x)) (= q 1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ffloor.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) for (q r) = (multiple-value-list (ffloor (- x) x)) unless (and (floatp q) (if (floatp x) (eql q (float -1 x)) (= q -1)) (zerop r) (if (floatp x) (eql r (float 0 x)) (= r 0))) collect x) nil) (deftest ffloor.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'short-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'single-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'double-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce i 'long-float)) (eql r rrad)) collect (list i x q r))) nil) (deftest ffloor.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (ffloor x)) unless (and (eql q (coerce (1- i) 'long-float)) (eql r rrad)) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl-2.7.1/ansi-tests/PaxHeaders/evenp.lsp0000644000000000000000000000013214542551762015306 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.673789979 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/evenp.lsp0000644000175000017500000000265214542551762014711 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 31 10:39:01 2003 ;;;; Contains: Tests of EVENP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest evenp.error.1 (signals-error (evenp) program-error) t) (deftest evenp.error.2 (signals-error (evenp 0 nil) program-error) t) (deftest evenp.error.3 (check-type-error #'evenp #'integerp) nil) (deftest evenp.1 (loop for x in *numbers* when (integerp x) do (evenp x)) nil) (deftest evenp.3 (loop for x = (random-fixnum) repeat 10000 when (or (not (evenp (+ x x))) (evenp (+ x x 1)) (if (evenp x) (or (evenp (1+ x)) (evenp (1- x)) (/= (mod x 2) 0)) (or (not (evenp (1+ x))) (not (evenp (1- x))) (= (mod x 2) 0)))) collect x) nil) (deftest evenp.4 (let ((upper-bound 1000000000000000) (lower-bound -1000000000000000)) (loop for x = (random-from-interval upper-bound lower-bound) repeat 10000 when (or (not (evenp (+ x x))) (evenp (+ x x 1)) (if (evenp x) (or (evenp (1+ x)) (evenp (1- x)) (/= (mod x 2) 0)) (or (not (evenp (1+ x))) (not (evenp (1- x))) (= (mod x 2) 0)))) collect x)) nil) (deftest evenp.5 (notnot-mv (evenp 0)) t) (deftest evenp.6 (evenp 1) nil) (deftest evenp.7 (notnot-mv (evenp 100000000000000000000000000000000)) t) (deftest evenp.8 (evenp 100000000000000000000000000000001) nil) gcl-2.7.1/ansi-tests/PaxHeaders/format-x.lsp0000644000000000000000000000013214542551762015726 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.673789979 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-x.lsp0000644000175000017500000003764514542551762015343 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 1 06:51:34 2004 ;;;; Contains: Tests of ~X format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.x.1 (let ((fn (formatter "~x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~X" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 16)) (read-from-string s1)) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) (find #\+ s1) (loop for c across s1 thereis (and (not (eql c #\-)) (not (digit-char-p c 16))))) collect (list i s1 j s2)))) nil) (deftest format.x.2 (let ((fn (formatter "~@X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@x" i) for s2 = (formatter-call-to-string fn i) for j = (let ((*read-base* 16)) (read-from-string s1)) repeat 1000 when (or (/= i j) (not (string= s1 s2)) (find #\. s1) ;; (find #\+ s1) (loop for c across s1 thereis (and (not (find c "-+")) (not (digit-char-p c 16))))) collect (list i s1 j s2)))) nil) (deftest format.x.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.x.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@X" i) for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@X" i) for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.x.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) for s2 = (format nil fmt i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.x.6 (let ((fn (formatter "~V,vx"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~x" i) for s2 = (format nil "~v,vX" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.x.7 (let ((fn (formatter "~v,V@X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@x" i) for s2 = (format nil "~v,v@x" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests (deftest format.x.8 (let ((fn (formatter "~:X"))) (loop for i from -999 to 999 for s1 = (format nil "~x" i) for s2 = (format nil "~:x" i) for s3 = (formatter-call-to-string fn i) unless (and (string= s1 s2) (string= s2 s3)) collect (list i s1 s2 s3))) nil) (deftest format.x.9 (let ((fn (formatter "~:x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~x" i) for s2 = (format nil "~:X" i) for s3 = (formatter-call-to-string fn i) repeat 1000 unless (and (string= s1 (remove commachar s2)) (string= s2 s3) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "0123456789ABCDEF" :test #'char-equal))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.10 (let ((fn (formatter "~,,V:x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~x" i) for s2 = (format nil "~,,v:X" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~x" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) for s2 = (format nil fmt i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.x.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~x" i) for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.x.12 (let ((fn (formatter "~,,v,v:X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~x" i) for s2 = (format nil "~,,v,v:X" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (string= s2 s3) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.13 (let ((fn (formatter "~,,v,V:@x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@x" i) for s2 = (format nil "~,,v,v:@x" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (string= s2 s3) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.x.14 "~vx" (nil #x100) "100") (def-format-test format.x.15 "~6,vX" (nil #x100) " 100") (def-format-test format.x.16 "~,,v:x" (nil #x12345) "12,345") (def-format-test format.x.17 "~,,'*,v:x" (nil #x12345) "12*345") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.x.18 (let ((fn (formatter "~x"))) (loop for x in *mini-universe* for s1 = (format nil "~x" x) for s2 = (let ((*print-base* 16)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.x.19 (let ((fn (formatter "~:x"))) (loop for x in *mini-universe* for s1 = (format nil "~:x" x) for s2 = (let ((*print-base* 16)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.x.20 (let ((fn (formatter "~@x"))) (loop for x in *mini-universe* for s1 = (format nil "~@x" x) for s2 = (let ((*print-base* 16)) (format nil "~A" x)) for s3 = (formatter-call-to-string fn x) unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) (deftest format.x.21 (let ((fn (formatter "~:@x"))) (loop for x in *mini-universe* for s1 = (let ((*print-base* 16)) (format nil "~A" x)) for s2 = (format nil "~@:x" x) for s3 = (formatter-call-to-string fn x) for s4 = (let ((*print-base* 16)) (format nil "~A" x)) unless (or (string/= s1 s4) (integerp x) (and (string= s1 s2) (string= s2 s3))) collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.x.22 (apply #'values (let ((fn (formatter "~#X")) (n #x1b3fe)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#x" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect (string-upcase s)))) "1B3FE" "1B3FE" "1B3FE" "1B3FE" "1B3FE" " 1B3FE" " 1B3FE" " 1B3FE" " 1B3FE" " 1B3FE" " 1B3FE") (deftest format.x.23 (apply #'values (let ((fn (formatter "~,,,#:X")) (n #x1234567890)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:x" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "1,2,3,4,5,6,7,8,9,0" "12,34,56,78,90" "1,234,567,890" "12,3456,7890" "12345,67890" "1234,567890" "123,4567890" "12,34567890" "1,234567890" "1234567890" "1234567890") (deftest format.x.24 (apply #'values (let ((fn (formatter "~,,,#@:X")) (n #x1234567890)) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:X" n args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream n args) args))) do (assert (string= s s2)) collect s))) "+1,2,3,4,5,6,7,8,9,0" "+12,34,56,78,90" "+1,234,567,890" "+12,3456,7890" "+12345,67890" "+1234,567890" "+123,4567890" "+12,34567890" "+1,234567890" "+1234567890" "+1234567890") (def-format-test format.x.25 "~+10x" (#x1234) " 1234") (def-format-test format.x.26 "~+10@X" (#x1234) " +1234") (def-format-test format.x.27 "~-1X" (#x1234) "1234") (def-format-test format.x.28 "~-1000000000000000000x" (#x1234) "1234") (def-format-test format.x.29 "~vx" ((1- most-negative-fixnum) #x1234) "1234") ;;; Randomized test (deftest format.x.30 (let ((fn (formatter "~v,v,v,vx"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~dx" commaint) "x")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vx" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) nil)gcl-2.7.1/ansi-tests/PaxHeaders/rotatef.lsp0000644000000000000000000000013214542551763015636 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.673789979 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rotatef.lsp0000644000175000017500000001715214542551763015242 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:44:38 2003 ;;;; Contains: Tests for ROTATEF (in-package :cl-test) (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 rotatef.1 (let ((x (vector 0 1 2))) (values (rotatef (aref x (aref x 0)) (aref x (aref x 1)) (aref x (aref x 2))) x)) nil #(1 2 0)) (deftest rotatef.2 (let ((x (vector 0 1 2 3 4 5 6 7 8 9))) (values (rotatef (aref x (aref x 0)) (aref x (aref x 1)) (aref x (aref x 2)) (aref x (aref x 3)) (aref x (aref x 4)) (aref x (aref x 5)) (aref x (aref x 6)) (aref x (aref x 7)) (aref x (aref x 8)) (aref x (aref x 9))) x)) nil #(1 2 3 4 5 6 7 8 9 0)) (deftest rotatef.3 (rotatef) nil) (deftest rotatef.4 (let ((x 10)) (values x (rotatef x) x)) 10 nil 10) (deftest rotatef.5 (let ((x 'a) (y 'b)) (values x y (rotatef x y) x y)) a b nil b a) ;;; ROTATEF is a good testbed for finding conflicts in setf expansions ;;; These tests apply rotatef to various accessors (deftest rotatef.6 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (car x) (car y) z) (values x y z)) (c b) (e d) a) (deftest rotatef.7 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (first x) (first y) z) (values x y z)) (c b) (e d) a) (deftest rotatef.8 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z '(e))) (rotatef (cdr x) (cdr y) z) (values x y z)) (a d) (c e) (b)) (deftest rotatef.9 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z '(e))) (rotatef (rest x) (rest y) z) (values x y z)) (a d) (c e) (b)) (deftest rotatef.10 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (cadr x) (cadr y) z) (values x y z)) (a d) (c e) b) (deftest rotatef.11 (let* ((x (list 'a 'b)) (y (list 'c 'd)) (z 'e)) (rotatef (second x) (second y) z) (values x y z)) (a d) (c e) b) (deftest rotatef.12 (let* ((x (list 'a 'b 'c)) (y (list 'd 'e 'f)) (z (list 'g))) (rotatef (cddr x) (cddr y) z) (values x y z)) (a b f) (d e g) (c)) (deftest rotatef.13 (let* ((x (list (list 'a))) (y (list (list 'c))) (z 'e)) (rotatef (caar x) (caar y) z) (values x y z)) ((c)) ((e)) a) (deftest rotatef.14 (let* ((x (list (list 'a 'b))) (y (list (list 'c 'd))) (z (list 'e))) (rotatef (cdar x) (cdar y) z) (values x y z)) ((a d)) ((c e)) (b)) ;;; TODO: c*r accessors with > 2 a/d ;;; TODO: third,...,tenth (deftest rotatef.15 (let* ((x (vector 'a 'b)) (y (vector 'c 'd)) (z 'e)) (rotatef (aref x 0) (aref y 0) z) (values x y z)) #(c b) #(e d) a) (deftest rotatef.16 (let* ((x (vector 'a 'b)) (y (vector 'c 'd)) (z 'e)) (rotatef (svref x 0) (svref y 0) z) (values x y z)) #(c b) #(e d) a) (deftest rotatef.17 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100)) (z 1)) (rotatef (bit x 1) (bit y 3) z) (values x y z)) #*10000 #*11110 1) (deftest rotatef.18 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij")) (z #\X)) (rotatef (char x 1) (char y 2) z) (values x y z)) "ahcde" "fgXij" #\b) (deftest rotatef.21 (let* ((x (copy-seq #*11000)) (y (copy-seq #*11100)) (z 1)) (rotatef (bit x 1) (bit y 3) z) (values x y z)) #*10000 #*11110 1) (deftest rotatef.22 (let* ((x (copy-seq "abcde")) (y (copy-seq "fghij")) (z #\X)) (rotatef (char x 1) (char y 2) z) (values x y z)) "ahcde" "fgXij" #\b) (deftest rotatef.23 (let* ((x (copy-seq '(a b c d e))) (y (copy-seq '(f g h i j))) (z 'k)) (rotatef (elt x 1) (elt y 2) z) (values x y z)) (a h c d e) (f g k i j) b) (deftest rotatef.24 (let ((x #b01010101) (y #b1111) (z 0)) (rotatef (ldb (byte 4 2) x) (ldb (byte 4 1) y) z) (values x y z)) #b01011101 1 #b0101) (deftest rotatef.25 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar)) (fn3 (constantly :zzz))) (setf (fdefinition f1) fn1 (fdefinition f2) fn2) (rotatef (fdefinition f1) (fdefinition f2) fn3) (values (funcall f1) (funcall f2) (funcall fn3))) :bar :zzz :foo) (deftest rotatef.26 (let* ((a1 (make-array '(10) :fill-pointer 5)) (a2 (make-array '(20) :fill-pointer 7)) (z 3)) (rotatef (fill-pointer a1) (fill-pointer a2) z) (values (fill-pointer a1) (fill-pointer a2) z)) 7 3 5) (deftest rotatef.27 (let* ((x (list 'a 'b 'c 'd)) (y (list 'd 'e 'f 'g)) (n1 1) (n2 2) (z 'h)) (rotatef (nth n1 x) (nth n2 y) z) (values x y z)) (a f c d) (d e h g) b) (deftest rotatef.28 (let* ((f1 (gensym)) (f2 (gensym)) (fn1 (constantly :foo)) (fn2 (constantly :bar)) (fn3 (constantly :zzz))) (setf (symbol-function f1) fn1 (symbol-function f2) fn2) (rotatef (symbol-function f1) (symbol-function f2) fn3) (values (funcall f1) (funcall f2) (funcall fn3))) :bar :zzz :foo) (deftest rotatef.29 (let* ((s1 (gensym)) (s2 (gensym)) (z 1)) (setf (symbol-value s1) :foo (symbol-value s2) :bar) (rotatef (symbol-value s1) (symbol-value s2) z) (values (symbol-value s1) (symbol-value s2) z)) :bar 1 :foo) (deftest rotatef.30 (let* ((s1 (gensym)) (s2 (gensym)) (v1 (list :foo 1)) (v2 (list :bar 2)) (z nil)) (setf (symbol-plist s1) v1 (symbol-plist s2) v2) (rotatef (symbol-plist s1) (symbol-plist s2) z) (values (symbol-plist s1) (symbol-plist s2) z)) (:bar 2) nil (:foo 1)) (deftest rotatef.31 (let* ((x (list 'a 'b 'c 'd 'e)) (y (list 'f 'g 'h 'i 'j)) (p1 1) (p2 2) (len 3) (z '(10 11 12))) (rotatef (subseq x p1 (+ p1 len)) (subseq y p2 (+ p2 len)) z) (values x y z)) (a h i j e) (f g 10 11 12) (b c d)) (deftest rotatef.32 (let* ((x (gensym)) (y (gensym)) (k1 :foo) (k2 :bar) (v1 1) (v2 2) (z 17)) (setf (get x k1) v1 (get y k2) v2) (rotatef (get x k1) (get y k2) z) (values (symbol-plist x) (symbol-plist y) z)) (:foo 2) (:bar 17) 1) (deftest rotatef.33 (let* ((x nil) (y nil) (k1 :foo) (k2 :bar) (v1 1) (v2 2) (z 21)) (setf (getf x k1) v1 (getf y k2) v2) (rotatef (getf x k1) (getf y k2) z) (values x y z)) (:foo 2) (:bar 21) 1) (deftest rotatef.34 (let* ((ht1 (make-hash-table)) (ht2 (make-hash-table)) (k1 :foo) (v1 1) (k2 :bar) (v2 2) (z 3)) (setf (gethash k1 ht1) v1 (gethash k2 ht2) v2) (rotatef z (gethash k1 ht1) (gethash k2 ht2)) (values z (gethash k1 ht1) (gethash k2 ht2))) 1 2 3) (deftest rotatef.35 (let ((n1 (gensym)) (n2 (gensym)) (n3 (gensym)) (n4 (gensym))) (eval `(defclass ,n1 () ())) (eval `(defclass ,n2 () ())) (setf (find-class n3) (find-class n1) (find-class n4) (find-class n2)) (rotatef (find-class n3) (find-class n4)) (values (eqlt (find-class n1) (find-class n4)) (eqlt (find-class n2) (find-class n3)))) t t) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest rotatef.36 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (rotatef (expand-in-current-env (%m x)) y) (values x y))) 2 1) (deftest rotatef.37 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (rotatef x (expand-in-current-env (%m y))) (values x y))) 2 1) ;;; TODO: macro-function, mask-field, row-major-aref, ;;; logical-pathname-translations, readtable-case gcl-2.7.1/ansi-tests/PaxHeaders/pathname-directory.lsp0000644000000000000000000000013114542551763017770 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.677789997 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname-directory.lsp0000644000175000017500000000504314542551763017371 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/random-intern.lsp0000644000000000000000000000013114542551763016746 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.681790014 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-intern.lsp0000644000175000017500000000324514542551763016351 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-list.lsp0000644000000000000000000000013214542551762023013 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.685790032 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-list.lsp0000644000175000017500000001411514542551762022413 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination LIST (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.list.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.list.1 (x) (:method-combination list) (:method list ((x integer)) (car (push 'd *x*))) (:method list ((x rational)) (car (push 'c *x*))) (:method list ((x number)) (car (push 'b *x*))) (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) (a b c d)) ((c b a) (a b c)) ((b a) (a b)) ((a) (a))) (deftest defgeneric-method-combination.list.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.list.2 (x) (:method-combination list :most-specific-first) (:method list ((x integer)) (car (push 'd *x*))) (:method list ((x rational)) (car (push 'c *x*))) (:method list ((x number)) (car (push 'b *x*))) (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) (a b c d)) ((c b a) (a b c)) ((b a) (a b)) ((a) (a))) (deftest defgeneric-method-combination.list.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.list.3 (x) (:method-combination list :most-specific-last) (:method list ((x integer)) (car (push 'd *x*))) (:method list ((x rational)) (car (push 'c *x*))) (:method list ((x number)) (car (push 'b *x*))) (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) (d c b a)) ((a b c) (c b a)) ((a b) (b a)) ((a) (a))) (deftest defgeneric-method-combination.list.4 (let ((fn (eval '(defgeneric dg-mc.fun.list.4 (x) (:method-combination list) (:method list ((x integer)) '(a b)) (:method :around ((x rational)) 'foo) (:method list ((x number)) '(c d)) (:method list ((x symbol)) '(e f)) (:method list ((x t)) '(g h)))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo ((c d) (g h)) ((e f) (g h)) ((g h))) (deftest defgeneric-method-combination.list.5 (let ((fn (eval '(defgeneric dg-mc.fun.list.5 (x) (:method-combination list) (:method list ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method list ((x number)) 'b) (:method list ((x symbol)) 'c) (:method list ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo (a b d)) (foo (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.list.6 (let ((fn (eval '(defgeneric dg-mc.fun.list.6 (x) (:method-combination list) (:method list ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method list ((x number)) 'b) (:method list ((x symbol)) 'c) (:method list ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) (deftest defgeneric-method-combination.list.7 (let ((fn (eval '(defgeneric dg-mc.fun.list.7 (x) (:method-combination list) (:method list ((x dgmc-class-04)) 'a) (:method list ((x dgmc-class-03)) 'b) (:method list ((x dgmc-class-02)) 'c) (:method list ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) (d) (c d) (b d) (a c b d)) (deftest defgeneric-method-combination.list.8 (let ((fn (eval '(defgeneric dg-mc.list.8 (x) (:method-combination list) (:method list ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method list ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) ((b))) (deftest defgeneric-method-combination.list.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.list.9 (x) (:method-combination list))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.list.10 (progn (eval '(defgeneric dg-mc.list.10 (x) (:method-combination list) (:method ((x t)) (list 'a)))) (handler-case (dg-mc.list.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.list.11 (progn (eval '(defgeneric dg-mc.list.11 (x) (:method-combination list) (:method nonsense ((x t)) (list 'a)))) (handler-case (dg-mc.list.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.list.12 (let ((fn (eval '(defgeneric dg-mc.list.12 (x) (:method-combination list) (:method :around ((x t)) (list 'a)) (:method list ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn (list 'b)) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/arithmetic-error.lsp0000644000000000000000000000013214542551762017451 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.685790032 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/arithmetic-error.lsp0000644000175000017500000000371314542551762017053 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of ARITHMETIC-ERROR condition and associated accessors (in-package :cl-test) (deftest arithmethic-error.1 (let ((a (make-condition 'arithmetic-error :operation '/ :operands '(0 0)))) (values (notnot (typep a 'arithmetic-error)) (notnot (typep a (find-class 'arithmetic-error))) (multiple-value-list (arithmetic-error-operation a)) (multiple-value-list (arithmetic-error-operands a)))) t t (/) ((0 0))) (deftest arithmethic-error.2 (let ((a (make-condition 'arithmetic-error :operation #'/ :operands '(0 0)))) (values (notnot (typep a 'arithmetic-error)) (notnot (typep a 'error)) (notnot (typep a 'serious-condition)) (notnot (typep a 'condition)) (notnot (typep a (find-class 'arithmetic-error))) (notnot (typep (arithmetic-error-operation a) 'function)) (funcall (arithmetic-error-operation a) 1 2) (multiple-value-list (arithmetic-error-operands a)))) t t t t t t 1/2 ((0 0))) (deftest arithmetic-error.3 (let ((a (make-condition 'arithmetic-error :operation '/ :operands '(0 0)))) (macrolet ((%m (z) z)) (values (arithmetic-error-operation (expand-in-current-env (%m a))) (arithmetic-error-operands (expand-in-current-env (%m a)))))) / (0 0)) ;;; Error tests (deftest arithmetic-error-operation.error.1 (signals-error (arithmetic-error-operation) program-error) t) (deftest arithmetic-error-operation.error.2 (signals-error (arithmetic-error-operation (make-condition 'arithmetic-error :operation '/ :operands '(1 0)) nil) program-error) t) (deftest arithmetic-error-operands.error.1 (signals-error (arithmetic-error-operands) program-error) t) (deftest arithmetic-error-operands.error.2 (signals-error (arithmetic-error-operands (make-condition 'arithmetic-error :operation '/ :operands '(1 0)) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/deftype.lsp0000644000000000000000000000013214542551762015631 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.685790032 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/deftype.lsp0000644000175000017500000001627114542551762015236 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:56:56 2003 ;;;; Contains: Tests of DEFTYPE (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; deftype (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) (deftest deftype.7 (let ((sym (gensym))) (assert (eq (eval `(deftype ,sym () '(integer 0 10))) sym)) (documentation sym 'type)) nil) (deftest deftype.8 (let ((sym (gensym))) (assert (eq (eval `(deftype ,sym () "FOO" '(integer 0 10))) sym)) (or (documentation sym 'type) "FOO")) "FOO") (deftest deftype.9 (let* ((sym (gensym)) (form `(deftype ,sym (&optional x) `(integer 0 ,x)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) 'unsigned-byte)) (multiple-value-list (subtypep* 'unsigned-byte `(,sym))) (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) (loop for x in '(a -1 0 1 2 3 4 5 b) collect (notnot (typep x sym))) (loop for x in '(a -1 0 1 2 3 4 5 b) collect (notnot (typep x `(,sym 4)))) )) t (t t) (t t) (t t) (t t) (nil nil t t t t t t nil) (nil nil t t t t t nil nil)) (deftest deftype.10 (let* ((sym (gensym)) (form `(deftype ,sym (&optional (x 14)) `(integer 0 ,x)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) '(integer 0 14))) (multiple-value-list (subtypep* '(integer 0 14) `(,sym))) (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) collect (notnot (typep x sym))) (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) collect (notnot (typep x `(,sym 4)))) )) t (t t) (t t) (t t) (t t) (nil nil t t t t t t t nil nil) (nil nil t t t t t nil nil nil nil)) (deftest deftype.11 (let* ((sym (gensym)) (form `(deftype ,sym (&key foo bar) `(integer ,foo ,bar)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym))) (multiple-value-list (subtypep* `(,sym :allow-other-keys nil) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil))) (multiple-value-list (subtypep* `(,sym :xyz 17 :allow-other-keys t) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys t abc nil))) (multiple-value-list (subtypep* `(,sym :foo 3) '(integer 3))) (multiple-value-list (subtypep* '(integer 3) `(,sym :foo 3))) (multiple-value-list (subtypep* `(,sym :bar 10) '(integer * 10))) (multiple-value-list (subtypep* '(integer * 10) `(,sym :bar 10))) (multiple-value-list (subtypep* `(,sym :foo 3 :foo 4 :bar 6) '(integer 3 6))) (multiple-value-list (subtypep* '(integer 3 6) `(,sym :foo 3 :foo 4 :bar 6))) (multiple-value-list (subtypep* `(,sym :bar * :foo (1)) '(integer 2))) (multiple-value-list (subtypep* '(integer 2) `(,sym :bar * :foo (1)))) )) 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) ) (deftest deftype.12 (let* ((sym (gensym)) (form `(deftype ,sym (&key foo bar &allow-other-keys) `(integer ,foo ,bar)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym :xyz t) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :xyz t))) (multiple-value-list (subtypep* `(,sym :allow-other-keys nil abc t) 'integer)) (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil abc t))) (multiple-value-list (subtypep* `(,sym :foo -10 :bar 20) '(integer -10 20))) (multiple-value-list (subtypep* '(integer -10 20) `(,sym :foo -10 :bar 20))) )) t (t t) (t t) (t t) (t t) (t t) (t t) ) (deftest deftype.13 (let* ((sym (gensym)) (form `(deftype ,sym (&rest args) (if args `(member ,@args) nil)))) (values (eqlt (eval form) sym) ;; (multiple-value-list (subtypep* sym nil)) ;; (multiple-value-list (subtypep* nil sym)) (multiple-value-list (subtypep* `(,sym) nil)) (multiple-value-list (subtypep* nil `(,sym))) (notnot (typep 'a `(,sym a))) (notnot (typep 'b `(,sym a))) (notnot (typep '* `(,sym a))) (notnot (typep 'a `(,sym a b))) (notnot (typep 'b `(,sym a b))) (notnot (typep 'c `(,sym a b))))) t (t t) (t t) t nil nil t t nil) ;;; I've removed this test, because EVAL can cause implicit compilation, ;;; and the semantic constraints on compilation forbid redefinition of ;;; of the types produced by DEFTYPE at runtime. #| (deftest deftype.14 (let* ((sym (gensym)) (*f* nil) (form `(let ((x 1)) (declare (special *f*)) (setf *f* #'(lambda (y) (setf x y))) (deftype ,sym () `(integer 0 ,x))))) (declare (special *f*)) (values (eqlt (eval form) sym) (loop for i from -1 to 3 collect (typep* i sym)) (funcall *f* 2) (loop for i from -1 to 3 collect (typep* i sym)))) t (nil t t nil nil) 2 (nil t t t nil)) |# (deftest deftype.15 (let* ((sym (gensym)) (form `(let ((a 1)) (deftype ,sym (&optional (x a)) (declare (special a)) `(integer 0 ,x))))) (values (eqlt (eval form) sym) (let ((a 2)) (declare (special a)) (loop for i from -1 to 3 collect (typep* i `(,sym 1)))) (let ((a 2)) (declare (special a)) (loop for i from -1 to 3 collect (typep* i sym))))) t (nil t t nil nil) (nil t t nil nil)) (deftest deftype.16 (let* ((sym (gensym)) (form `(deftype ,sym () (return-from ,sym 'integer)))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) (subtypep* 'integer sym))) t t t) (deftest deftype.17 (let* ((sym (gensym)) (form `(deftype ,sym () (values 'integer t)))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) (subtypep* 'integer sym))) t t t) (deftest deftype.18 (let* ((sym (gensym)) (form `(deftype ,sym ()))) (values (eqlt (eval form) sym) (subtypep* sym nil) (subtypep* nil sym))) t t t) (deftest deftype.19 (let* ((sym (gensym)) (form `(deftype ,sym () (declare (optimize speed safety debug compilation-speed space)) 'integer))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) (subtypep* 'integer sym))) t t t) ;;; Error tests (deftest deftype.error.1 (signals-error (funcall (macro-function 'deftype)) program-error) t) (deftest deftype.error.2 (signals-error (funcall (macro-function 'deftype) '(deftype nonexistent-type () nil)) program-error) t) (deftest deftype.error.3 (signals-error (funcall (macro-function 'deftype) '(deftype nonexistent-type () nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/assert.lsp0000644000000000000000000000013114542551762015471 xustar0030 mtime=1703597042.916022294 29 atime=1744294960.68979005 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/assert.lsp0000644000175000017500000000363714542551762015101 0ustar00cammcamm;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest assert.10 (macrolet ((%m (z) z)) (assert (expand-in-current-env (%m t)))) nil) (deftest assert.11 (macrolet ((%m (z) z)) (assert (expand-in-current-env (%m t)) () "Foo!")) nil) gcl-2.7.1/ansi-tests/PaxHeaders/nsubstitute-if-not.lsp0000644000000000000000000000013014542551763017753 xustar0030 mtime=1703597043.008022439 29 atime=1744294960.68979005 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nsubstitute-if-not.lsp0000644000175000017500000006204214542551763017357 0ustar00cammcamm;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-not-list.8 (nsubstitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x)) #()) (deftest nsubstitute-if-not-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-not-vector.8 (let ((x #())) (nsubstitute-if-not 'b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest nsubstitute-if-not-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1)) #(d a b x d a b c)) (deftest nsubstitute-if-not-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t)) #(d a b c d a b x)) ;;; Tests on strings (deftest nsubstitute-if-not-string.1 (let ((x "")) (nsubstitute-if-not #\b (is-not-eql-p #\a) x)) "") (deftest nsubstitute-if-not-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x)) "bbbc") (deftest nsubstitute-if-not-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-not-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-not-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-not-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-not-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-not-string.8 (let ((x "")) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :from-end t)) "") (deftest nsubstitute-if-not-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-not-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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") (deftest nsubstitute-if-not-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s) "xyz!bcxyz!bc"))) nil) (deftest nsubstitute-if-not-string.33 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s :count 1) "xyz!bcxyzabc"))) nil) (deftest nsubstitute-if-not-string.34 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc"))) nil) ;;; Tests on bit-vectors (deftest nsubstitute-if-not-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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 (signals-error (nsubstitute-if-not) program-error) t) (deftest nsubstitute-if-not.error.2 (signals-error (nsubstitute-if-not 'a) program-error) t) (deftest nsubstitute-if-not.error.3 (signals-error (nsubstitute-if-not 'a #'null) program-error) t) (deftest nsubstitute-if-not.error.4 (signals-error (nsubstitute-if-not 'a #'null nil 'bad t) program-error) t) (deftest nsubstitute-if-not.error.5 (signals-error (nsubstitute-if-not 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest nsubstitute-if-not.error.6 (signals-error (nsubstitute-if-not 'a #'null nil :key) program-error) t) (deftest nsubstitute-if-not.error.7 (signals-error (nsubstitute-if-not 'a #'null nil 1 2) program-error) t) (deftest nsubstitute-if-not.error.8 (signals-error (nsubstitute-if-not 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest nsubstitute-if-not.error.9 (signals-error (nsubstitute-if-not 'a #'car (list 'a 'b 'c)) type-error) t) (deftest nsubstitute-if-not.error.10 (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest nsubstitute-if-not.error.11 (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest nsubstitute-if-not.error.12 (check-type-error #'(lambda (x) (nsubstitute-if-not 1 #'null x)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/call-next-method.lsp0000644000000000000000000000013014542551762017334 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.693790067 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/call-next-method.lsp0000644000175000017500000001313414542551762016736 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 31 11:18:15 2003 ;;;; Contains: Tests of CALL-NEXT-METHOD (in-package :cl-test) ;;; Tests where there is no next method are in no-next-method.lsp (defgeneric cnm-gf-01 (x) (:method ((x integer)) (cons 'a (call-next-method))) (:method ((x rational)) (cons 'b (call-next-method))) (:method ((x real)) (cons 'c (call-next-method))) (:method ((x number)) (cons 'd (call-next-method))) (:method ((x t)) nil)) (deftest call-next-method.1 (mapcar #'cnm-gf-01 '(0 2/3 1.3 #c(1 1) a)) ((a b c d) (b c d) (c d) (d) nil)) ;; Check that call-next-method passes along multiple values correctly (defgeneric cnm-gf-02 (x) (:method ((x integer)) (call-next-method)) (:method ((x number)) (values)) (:method ((x (eql 'a))) (call-next-method)) (:method ((x symbol)) (values 1 2 3 4 5 6))) (deftest call-next-method.2 (cnm-gf-02 0)) (deftest call-next-method.3 (cnm-gf-02 'a) 1 2 3 4 5 6) ;;; Call next method has indefinite extent (defgeneric cnm-gf-03 (x) (:method ((x integer)) #'call-next-method) (:method ((x t)) t)) (deftest call-next-method.4 (funcall (cnm-gf-03 0)) t) ;;; The arguments to c-n-m can be changed (defgeneric cnm-gf-04 (x) (:method ((x integer)) (call-next-method (+ x 10))) (:method ((x number)) (1+ x))) (deftest call-next-method.5 (mapcar #'cnm-gf-04 '(0 1 2 5/3 9/2 1.0 #c(1 1))) (11 12 13 8/3 11/2 2.0 #c(2 1))) ;;; call-next-method goes up the list of applicable methods ;;; which may be to a method with specializers incomparable to ;;; the current method (defgeneric cnm-gf-05 (x y) (:method ((x integer) (y integer)) (cons 'a (call-next-method))) (:method ((x integer) (y t)) (cons 'b (call-next-method))) (:method ((x t) (y integer)) (cons 'c (call-next-method))) (:method ((x t) (y t)) (list 'd))) (deftest call-next-method.6 (mapcar #'cnm-gf-05 '(0 0 t t) '(0 t 0 t)) ((a b c d) (b d) (c d) (d))) (defclass cnm-class-01a () ()) (defclass cnm-class-01b (cnm-class-01a) ()) (defclass cnm-class-01c (cnm-class-01a) ()) (defclass cnm-class-01d (cnm-class-01c cnm-class-01b) ()) (defgeneric cnm-gf-06 (x) (:method ((x cnm-class-01d)) (cons 1 (call-next-method))) (:method ((x cnm-class-01c)) (cons 2 (call-next-method))) (:method ((x cnm-class-01b)) (cons 3 (call-next-method))) (:method ((x cnm-class-01a)) (cons 4 (call-next-method))) (:method ((x t)) nil)) (deftest call-next-method.7 (values (cnm-gf-06 (make-instance 'cnm-class-01d)) (cnm-gf-06 (make-instance 'cnm-class-01c)) (cnm-gf-06 (make-instance 'cnm-class-01b)) (cnm-gf-06 (make-instance 'cnm-class-01a)) (cnm-gf-06 nil)) (1 2 3 4) (2 4) (3 4) (4) nil) ;;; Neither rebinding nor setq affects the arguments passed by ;;; (call-next-method) (defgeneric cnm-gf-07 (x) (:method ((x integer)) (list (incf x) (call-next-method))) (:method ((x symbol)) (list (setq x 'a) x (call-next-method))) (:method ((x cons)) (list x (let ((x :bad)) (declare (ignorable x)) (call-next-method)))) (:method ((x t)) x)) (deftest call-next-method.8 (mapcar #'cnm-gf-07 '(0 z (x) #\a)) ((1 0) (a a z) ((x) (x)) #\a)) ;; Nor does argument defaulting (defgeneric cnm-gf-08 (x &optional y) (:method ((x integer) &optional y) (list* x y (call-next-method))) (:method ((x t) &optional y) (list x y))) (deftest call-next-method.9 (values (cnm-gf-08 0) (cnm-gf-08 0 t) (cnm-gf-08 'a) (cnm-gf-08 'a 'b)) (0 nil 0 nil) (0 t 0 t) (a nil) (a b)) ;;; When c-n-m is called with arguments but omits optionals, those ;;; optionals are defaulted (defgeneric cnm-gf-09 (x &optional y) (:method ((x integer) &optional y) (list* x y (call-next-method (1+ x)))) (:method ((x t) &optional y) (list x y))) (deftest call-next-method.10 (values (cnm-gf-09 5) (cnm-gf-09 8 'a) (cnm-gf-09 'x) (cnm-gf-09 'x 'y)) (5 nil 6 nil) (8 a 9 nil) (x nil) (x y)) (defgeneric cnm-gf-10 (x &optional y z) (:method ((x integer) &optional (y 'a y-p) (z 'b z-p)) (list* x y (notnot y-p) z (notnot z-p) (call-next-method (1+ x)))) (:method ((x t) &optional (y 'c y-p) (z 'd z-p)) (list x y (notnot y-p) z (notnot z-p)))) (deftest call-next-method.11 (values (cnm-gf-10 5) (cnm-gf-10 8 'p) (cnm-gf-10 8 'p 'q) (cnm-gf-10 'x) (cnm-gf-10 'x 'u) (cnm-gf-10 'x 'u 'v)) (5 a nil b nil 6 c nil d nil) (8 p t b nil 9 c nil d nil) (8 p t q t 9 c nil d nil) (x c nil d nil) (x u t d nil) (x u t v t)) ;;; "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." (defgeneric cnm-order-error-gf-01 (x) (declare (optimize (safety 3))) (:method ((x (eql 0))) (declare (optimize (safety 3))) (call-next-method 1)) ;; no longer EQL to 0 (:method ((x t)) nil)) (deftest call-next-method.error.1 (locally (declare (optimize (safety 3))) (handler-case (eval '(locally (declare (optimize (safety 3))) (cnm-order-error-gf-01 0))) (error () :error))) :error) (defgeneric cnm-order-error-gf-02 (x) (declare (optimize (safety 3))) (:method ((x integer)) (declare (optimize (safety 3))) (call-next-method :bad)) (:method ((x t)) x)) (deftest call-next-method.error.2 (locally (declare (optimize (safety 3))) (handler-case (eval '(locally (declare (optimize (safety 3))) (cnm-order-error-gf-02 0))) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/pop.lsp0000644000000000000000000000013114542551763014767 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.697790084 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pop.lsp0000644000175000017500000000177314542551763014376 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:27:18 2003 ;;;; Contains: Tests of POP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest pop.3 (macrolet ((%m (z) z)) (let ((x (list 'a 'b 'c))) (values (pop (expand-in-current-env (%m x))) x))) a (b c)) ;;; 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) (def-macro-test pop.error.1 (pop x)) ;;; Need to add tests of POP vs. various accessors gcl-2.7.1/ansi-tests/PaxHeaders/pprint-fill.lsp0000644000000000000000000000013114542551763016431 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.697790084 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-fill.lsp0000644000175000017500000001160014542551763016026 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 25 22:03:01 2004 ;;;; Contains: Tests of PPRINT-FILL (in-package :cl-test) ;;; When printing a non-list, the result is the same as calling WRITE." (deftest pprint-fill.1 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-fill s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (deftest pprint-fill.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil)) (loop for obj in *mini-universe* nconc (and (not (listp obj)) (let ((s1 (write-to-string obj)) (s2 (with-output-to-string (s) (pprint-fill s obj)))) (unless (equal s1 s2) (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-fill-test (name args expected-value &key (margin 100) (circle nil) (len nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* ,margin) (*package* (find-package "CL-TEST")) (*print-length* ,len) (*print-circle* ,circle)) (with-output-to-string (s) (pprint-fill s ,@args)))) ,expected-value)) (def-pprint-fill-test pprint-fill.3 ('(|A|)) "(A)") (def-pprint-fill-test pprint-fill.4 ('(|A|) t) "(A)") (def-pprint-fill-test pprint-fill.5 ('(|A|) nil) "A") (def-pprint-fill-test pprint-fill.6 ('(1 2 3 4 5)) "(1 2 3 4 5)") (def-pprint-fill-test pprint-fill.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5") ;;; The fourth argument is ignored (def-pprint-fill-test pprint-fill.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)") (def-pprint-fill-test pprint-fill.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5") ;;; Takes T, NIL as stream designators (deftest pprint-fill.10 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-fill t '(1 2 3))))))) "(1 2 3)") (deftest pprint-fill.11 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-fill nil '(1 2 3))))) "(1 2 3)") ;;; Now tests for cases that should be wrapped ;;; It's not entirely clear what they should be doing ;;; but check for some obvious properties (deftest pprint-fill.12 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-fill os obj)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string s) obj)) (list :bad2 s)) ((not (find #\Newline s :start 1)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) (deftest pprint-fill.13 (my-with-standard-io-syntax (let ((*print-pretty* t) (*print-readably* nil) (*package* (find-package :cl-test)) (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 for result = (let* ((*print-right-margin* i) (s (with-output-to-string (os) (terpri os) (pprint-fill os obj nil)))) (cond ((not (eql (elt s 0) #\Newline)) (list :bad1 s)) ((not (equal (read-from-string (concatenate 'string "(" s ")")) obj)) (list :bad2 s)) ((not (find #\Newline s :start 1)) (list :bad3 s)) (t t))) unless (eql result t) collect (list i result)))) nil) ;;; (def-pprint-fill-test pprint-fill.14 ((let ((x (list '|A|))) (list x x))) "(#1=(A) #1#)" :circle t) (def-pprint-fill-test pprint-fill.15 ((let ((x (list '|A|))) (setf (cdr x) x) x)) "#1=(A . #1#)" :circle t :len 500) ;;; Test that pprint-fill returns NIL (deftest pprint-fill.return-values.1 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package "CL-TEST"))) (with-open-stream (s (make-broadcast-stream)) (pprint-fill s '(a b))))) nil) (deftest pprint-fill.return-values.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) (pprint-fill s 10 nil t)))) nil) ;;; Error tests (deftest pprint-fill.error.1 (signals-error (pprint-fill) program-error) t) (deftest pprint-fill.error.2 (signals-error (pprint-fill *standard-output*) program-error) t) (deftest pprint-fill.error.3 (signals-error (pprint-fill *standard-output* nil t t t) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/tailp.lsp0000644000000000000000000000013114542551763015302 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.697790084 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/tailp.lsp0000644000175000017500000000406314542551763014704 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:47:26 2003 ;;;; Contains: Tests of TAILP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (tailp) program-error) t) (deftest tailp.error.6 (signals-error (tailp nil) program-error) t) (deftest tailp.error.7 (signals-error (tailp nil nil nil) program-error) t) ;; 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.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-max.lsp0000644000000000000000000000013214542551762022625 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.701790102 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-max.lsp0000644000175000017500000001340214542551762022223 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination MAX (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.max.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.max.1 (x) (:method-combination max) (:method max ((x integer)) (car (push 8 *x*))) (:method max ((x rational)) (car (push 4 *x*))) (:method max ((x number)) (car (push 2 *x*))) (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) (deftest defgeneric-method-combination.max.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.max.2 (x) (:method-combination max :most-specific-first) (:method max ((x integer)) (car (push 8 *x*))) (:method max ((x rational)) (car (push 4 *x*))) (:method max ((x number)) (car (push 2 *x*))) (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) (deftest defgeneric-method-combination.max.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.max.3 (x) (:method-combination max :most-specific-last) (:method max ((x integer)) (car (push 8 *x*))) (:method max ((x rational)) (car (push 4 *x*))) (:method max ((x number)) (car (push 2 *x*))) (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (8 4 2 1)) (4 (4 2 1)) (2 (2 1)) (1 (1))) (deftest defgeneric-method-combination.max.4 (let ((fn (eval '(defgeneric dg-mc.max.4 (x) (:method-combination max) (:method max ((x integer)) 4) (:method :around ((x rational)) 'foo) (:method max ((x number)) 3) (:method max ((x symbol)) 5) (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo 3 5 1) (deftest defgeneric-method-combination.max.5 (let ((fn (eval '(defgeneric dg-mc.max.5 (x) (:method-combination max) (:method max ((x integer)) 5) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method max ((x number)) 5/2) (:method max ((x symbol)) 4) (:method max ((x t)) 1.0))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo 5) (foo 5/2) 5/2 4 1.0) (deftest defgeneric-method-combination.max.6 (let ((fn (eval '(defgeneric dg-mc.max.6 (x) (:method-combination max) (:method max ((x integer)) 9) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method max ((x number)) 4) (:method max ((x symbol)) 6) (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar 9)) (foo (bar 4)) (bar 4) 4 6 1) (deftest defgeneric-method-combination.max.7 (let ((fn (eval '(defgeneric dg-mc.max.7 (x) (:method-combination max) (:method max ((x dgmc-class-04)) 4) (:method max ((x dgmc-class-03)) 3) (:method max ((x dgmc-class-02)) 5) (:method max ((x dgmc-class-01)) 1))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) 1 5 3 5) (deftest defgeneric-method-combination.max.8 (let ((fn (eval '(defgeneric dg-mc.max.8 (x) (:method-combination max) (:method max ((x (eql 1000))) 4) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (1)) (deftest defgeneric-method-combination.max.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.max.9 (x) (:method-combination max))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.max.10 (progn (eval '(defgeneric dg-mc.max.10 (x) (:method-combination max) (:method ((x t)) 0))) (handler-case (dg-mc.max.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.max.11 (progn (eval '(defgeneric dg-mc.max.11 (x) (:method-combination max) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.max.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.max.12 (let ((fn (eval '(defgeneric dg-mc.max.12 (x) (:method-combination max) (:method :around ((x t)) 1) (:method max ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/packages-05.lsp0000644000000000000000000000013114542551763016171 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.701790102 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-05.lsp0000644000175000017500000000503314542551763015571 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/etypecase.lsp0000644000000000000000000000013114542551762016152 xustar0030 mtime=1703597042.988022407 29 atime=1744294960.70579012 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/etypecase.lsp0000644000175000017500000000631014542551762015551 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:02:23 2002 ;;;; Contains: Tests of ETYPECASE (in-package :cl-test) (compile-and-load "types-aux.lsp") (deftest etypecase.1 (etypecase 1 (integer 'a) (t 'b)) a) (deftest etypecase.2 (signals-type-error x 1 (etypecase x (symbol 'a))) t) (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) (deftest etypecase.13 (block nil (tagbody (let ((x 'a)) (etypecase x (symbol (go 10) 10 (return 'bad)))) 10 (return 'good))) good) (deftest etypecase.14 (loop for x in '(1 a 1.3 "") collect (etypecase x (t :good) (integer :bad) (symbol :bad) (float :bad) (string :bad))) (:good :good :good :good)) (deftest etypecase.15 (let* ((u (coerce *universe* 'vector)) (len1 (length u)) (types (coerce *cl-all-type-symbols* 'vector)) (len2 (length types))) (loop for n = (random 10) for my-types = (loop repeat n collect (elt types (random len2))) for val = (elt u (random len1)) for i = (position val my-types :test #'typep) for form = `(function (lambda (x) (handler-case (etypecase x ,@(loop for i from 0 for type in my-types collect `(,type ,i))) (type-error (c) (assert (eql x (type-error-datum c))) (let* ((expected (type-error-expected-type c))) (let ((equiv (check-equivalence expected ',(cons 'or my-types)))) (assert (null equiv) () "EQUIV = ~A" EQUIV))) nil)))) for j = (funcall (eval form) val) repeat 200 unless (eql i j) collect (list n my-types val i form j))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest etypecase.16 (macrolet ((%m (z) z)) (etypecase (expand-in-current-env (%m :foo)) (integer :bad1) (keyword :good) (symbol :bad2))) :good) (deftest etypecase.17 (macrolet ((%m (z) z)) (etypecase :foo (integer (expand-in-current-env (%m :bad1))) (keyword (expand-in-current-env (%m :good))) (symbol (expand-in-current-env (%m :bad2))))) :good) ;;; Error cases (deftest etypecase.error.1 (signals-error (funcall (macro-function 'etypecase)) program-error) t) (deftest etypecase.error.2 (signals-error (funcall (macro-function 'etypecase) '(etypecase t)) program-error) t) (deftest etypecase.error.3 (signals-error (funcall (macro-function 'etypecase) '(etypecase t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/gentemp.lsp0000644000000000000000000000013014542551762015626 xustar0029 mtime=1703597042.99602242 29 atime=1744294960.70579012 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/gentemp.lsp0000644000175000017500000000741514542551762015235 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 22 09:32:09 2003 ;;;; Contains: Tests of GENTEMP (in-package :cl-test) (deftest gentemp.1 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (let ((*package* pkg)) (gentemp))) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\T) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.2 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (let ((*package* pkg)) (gentemp "X"))) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\X) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.3 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (gentemp "X" package-name)) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\X) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.4 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (gentemp "" (make-symbol package-name))) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (notnot (every #'digit-char-p sym-name)) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t) (deftest gentemp.5 (let* ((package-name "Z")) (safely-delete-package package-name) (unwind-protect (let* ((pkg (make-package package-name :use nil)) (gcounter *gensym-counter*) (sym (gentemp "Y" #\Z)) (sym-name (symbol-name sym))) (values (=t gcounter *gensym-counter*) ;; wasn't changed (eqlt (aref sym-name 0) #\Y) (notnot (every #'digit-char-p (subseq sym-name 1))) (eql (symbol-package sym) pkg) ;; Not external (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) )) (delete-package package-name))) t t t t t) (deftest gentemp.6 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect (let* ((*package* (make-package package-name :use nil)) (syms (loop repeat 100 collect (gentemp)))) (=t (length syms) (length (remove-duplicates syms)))) (delete-package package-name))) t) ;;; Error tests (deftest gentemp.error.1 (loop for x in *mini-universe* unless (or (stringp x) (eql (eval `(signals-type-error x ',x (gentemp x))) t)) collect x) nil) (deftest gentemp.error.2 (loop for x in *mini-universe* unless (or (typep x 'package) (string-designator-p x) (eql (eval `(signals-type-error x ',x (gentemp "T" x))) t)) collect x) nil) (deftest gentemp.error.3 (signals-error (gentemp "" *package* nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/string-left-trim.lsp0000644000000000000000000000013114542551763017400 xustar0030 mtime=1703597043.024022464 29 atime=1744294960.70579012 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-left-trim.lsp0000644000175000017500000001256014542551763017003 0ustar00cammcamm;-*- 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.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :fill-pointer 7)) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.10b (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :adjustable t :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.20 :notes (:nil-vectors-are-strings) (string-left-trim "abcd" (make-array '(0) :element-type nil)) "") (deftest string-left-trim.21 :notes (:nil-vectors-are-strings) (string-left-trim (make-array '(0) :element-type nil) "abcd") "abcd") (deftest string-left-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'base-char :adjustable t))) (values (string-left-trim "ab" s) s)) "caeb" "abcaeb") (deftest string-left-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'character :adjustable t))) (values (string-left-trim "ab" s) s)) "caeb" "abcaeb") (deftest string-left-trim.24 (let* ((etype 'base-char) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-left-trim "ab" s) s s0)) "ca" "bca" "abcaeb") (deftest string-left-trim.25 (let* ((etype 'character) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-left-trim "ab" s) s s0)) "ca" "bca" "abcaeb") (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) (def-fold-test string-left-trim.fold.1 (string-left-trim " " " abcd")) ;;; Error cases (deftest string-left-trim.error.1 (signals-error (string-left-trim) program-error) t) (deftest string-left-trim.error.2 (signals-error (string-left-trim "abc") program-error) t) (deftest string-left-trim.error.3 (signals-error (string-left-trim "abc" "abcdddabc" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ed.lsp0000644000000000000000000000013214542551762014561 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.709790138 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ed.lsp0000644000175000017500000000061414542551762014160 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 15 13:07:39 2005 ;;;; Contains: Tests of ED (in-package :cl-test) ;;; Since the normal behavior of ED is implementation dependent, ;;; test only the error behavior (deftest ed.error.1 (signals-error (ed "ed.lsp" nil) program-error) t) ;;; Since the editor may not even be included, no other tests ;;; are possible. gcl-2.7.1/ansi-tests/PaxHeaders/numerator-denominator.lsp0000644000000000000000000000013114542551763020522 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.709790138 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/numerator-denominator.lsp0000644000175000017500000000466514542551763020134 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:24:57 2003 ;;;; Contains: Tests of NUMERATOR, DENOMINATOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest numerator.error.1 (signals-error (numerator) program-error) t) (deftest numerator.error.2 (signals-error (numerator 1/2 nil) program-error) t) (deftest denominator.error.1 (signals-error (denominator) program-error) t) (deftest denominator.error.2 (signals-error (denominator 1/2 nil) program-error) t) (deftest numerator-denominator.1 (loop for n = (abs (random-fixnum)) for d = (1+ (abs (random-fixnum))) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n d) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 n2) (eql d1 d2)) collect (list n1 d1 r n2 d2)) nil) (deftest numerator-denominator.2 (let ((bound (expt 10 20))) (loop for n = (random-from-interval bound 0) for d = (random-from-interval bound 1) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n d) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 n2) (eql d1 d2)) collect (list n1 d1 r n2 d2))) nil) (deftest numerator-denominator.3 (loop for n = (abs (random-fixnum)) for d = (1+ (abs (random-fixnum))) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n (- d)) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 (- n2)) (eql d1 d2)) collect (list n1 d1 r n2 d2)) nil) (deftest numerator-denominator.4 (let ((bound (expt 10 20))) (loop for n = (random-from-interval bound 0) for d = (random-from-interval bound 1) for g = (gcd n d) for n1 = (/ n g) for d1 = (/ d g) for r = (/ n (- d)) for n2 = (numerator r) for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) (>= n1 0) (>= d1 1) (eql n1 (- n2)) (eql d1 d2)) collect (list n1 d1 r n2 d2))) nil) (deftest numerator-denominator.5 (loop for r in *rationals* for n = (numerator r) for d = (denominator r) unless (and (integerp n) (integerp d) (eql (gcd n d) 1) (>= d 1) (eql (/ n d) r)) collect (list r n d)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/package-aux.lsp0000644000000000000000000000013114542551763016357 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.709790138 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-aux.lsp0000644000175000017500000001074514542551763015765 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 21 20:59:17 2004 ;;;; Contains: Aux. functions for package tests (in-package :cl-test) (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 ~S ~S ~S ~S~%" sym p sym2 access (quote ,(copy-list symbol-types))) (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 num-external-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-external-symbols (s p num) (declare (ignorable s)) (incf num)))) (defun external-symbols-in-package (p) (let ((symbols nil)) (do-external-symbols (s p) (push s symbols)) (sort symbols #'(lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2)))))) (defun num-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-symbols (s p num) (declare (ignorable s)) (incf num)))) (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 sort-package-list (x) (sort (copy-list x) #'string< :key #'package-name)) gcl-2.7.1/ansi-tests/PaxHeaders/structure-00.lsp0000644000000000000000000000013214542551763016447 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.709790138 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/structure-00.lsp0000644000175000017500000004204414542551763016051 0ustar00cammcamm;-*- 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))))) ) (declare (ignorable initial-offset)) ;; Build the tests in an eval-when form `(eval-when (:load-toplevel :compile-toplevel :execute) (report-and-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") (signals-error (,p-fn) program-error) t) (deftest ,(make-struct-test-name name "ERROR.2") (signals-error (,p-fn (,make-fn) nil) program-error) t) )) ;; 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) initval inits)) (push `(and (eqlt (quote ,initval) (,field-fn ,var)) (eqlt (quote ,initval) (funcall #',field-fn ,var))) tests)) ; `(let ((,var (,make-fn . ,inits))) `(let ((,var (apply ',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 `(multiple-value-bind (x val) (signals-error (,field-fn) program-error) (unless x (list ',slot-name ',field-fn val)))))) 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 `(multiple-value-bind (x val) (signals-error (,field-fn (,make-fn) nil) program-error) (unless x (list ',slot-name ',field-fn val)))))) 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") (signals-error (,copy-fn) program-error) t) (deftest ,(make-struct-test-name name "ERROR.6") (signals-error (,copy-fn (,make-fn) nil) program-error) t) )) ;; 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 (apply ',make-fn '(,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") 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 (apply ',make-fn '(,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") 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.7.1/ansi-tests/PaxHeaders/find-symbol.lsp0000644000000000000000000000013214542551762016414 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.709790138 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find-symbol.lsp0000644000175000017500000000773414542551762016025 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:49:34 1998 ;;;; Contains: Tests for FIND-SYMBOL (in-package :cl-test) (compile-and-load "packages-00.lsp") ;;(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 (progn (set-up-packages) (let ((vals (multiple-value-list (find-symbol "FOO" #\A)))) (values (length vals) (package-name (symbol-package (first vals))) (symbol-name (first vals)) (second vals)))) 2 "A" "FOO" :external) (deftest find-symbol.13 (progn (set-up-packages) (intern "X" (find-package "A")) (let ((vals (multiple-value-list (find-symbol "X" #\A)))) (values (length vals) (package-name (symbol-package (first vals))) (symbol-name (first vals)) (second vals)))) 2 "A" "X" :internal) (deftest find-symbol.14 (progn (set-up-packages) (let ((vals (multiple-value-list (find-symbol "FOO" #\B)))) (values (length vals) (package-name (symbol-package (first vals))) (symbol-name (first vals)) (second vals)))) 2 "A" "FOO" :inherited) (deftest find-symbol.15 (find-symbol "FOO" "FS-B") FS-A::FOO :inherited) (deftest find-symbol.16 (find-symbol "FOO" (find-package "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.17 (let ((name (make-array '(3) :initial-contents "FOO" :element-type 'base-char))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.18 (let ((name (make-array '(4) :initial-contents "FOOD" :element-type 'character :fill-pointer 3))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.19 (let ((name (make-array '(4) :initial-contents "FOOD" :element-type 'base-char :fill-pointer 3))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.20 (let* ((name0 (make-array '(5) :initial-contents "XFOOY" :element-type 'character)) (name (make-array '(3) :element-type 'character :displaced-to name0 :displaced-index-offset 1))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.21 (let* ((name0 (make-array '(5) :initial-contents "XFOOY" :element-type 'base-char)) (name (make-array '(3) :element-type 'base-char :displaced-to name0 :displaced-index-offset 1))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.22 (find-symbol "FOO" (make-array '(4) :initial-contents "FS-B" :element-type 'base-char)) FS-A::FOO :inherited) (deftest find-symbol.23 (find-symbol "FOO" (make-array '(5) :initial-contents "FS-BX" :fill-pointer 4 :element-type 'base-char)) FS-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 (signals-error (find-symbol) program-error) t) (deftest find-symbol.error.2 (signals-error (find-symbol "CAR" "CL" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/wild-pathname-p.lsp0000644000000000000000000000013214542551763017161 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.709790138 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/wild-pathname-p.lsp0000644000175000017500000001265014542551763016563 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/substitute-if.lsp0000644000000000000000000000013114542551763017000 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.709790138 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/substitute-if.lsp0000644000175000017500000006273314542551763016412 0ustar00cammcamm;-*- 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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x) x)) #() #()) (deftest substitute-if-vector.2 (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p 'a) x :from-end t) x)) #() #()) (deftest substitute-if-vector.9 (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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)) (deftest substitute-if-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if 'x (is-eql-p 'c) v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b c d a b c d a b c d)) (deftest substitute-if-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b c d a b c d)) ;;; Tests on strings (deftest substitute-if-string.1 (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x) x)) "" "") (deftest substitute-if-string.2 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-string.3 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.4 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-string.5 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-string.6 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-string.7 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-string.8 (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-string.9 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.10 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.11 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.12 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-if-string.13 (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-if-string.14 (let ((x "abac")) (values (substitute-if #\b (is-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-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-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-string.26 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (substitute-if #\! (is-eql-p #\a) s) "xyz!bcxyz!bc")) (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1) "xyz!bcxyzabc")) (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyzabc"))) nil) ;;; More bit vector tests (deftest substitute-if-bit-vector.22 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eql-p 1) x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-if-bit-vector.23 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-if-bit-vector.24 (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.25 (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.26 (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.27 (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) ;;; Order of evaluation tests (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)) ;;; Constant folding tests (def-fold-test substitute-if.fold.1 (substitute-if 'z 'null '(a nil b))) (def-fold-test substitute-if.fold.2 (substitute-if 'z 'null #(a nil b))) (def-fold-test substitute-if.fold.3 (substitute-if 0 'plusp #*100110)) (def-fold-test substitute-if.fold.4 (substitute-if #\x 'digit-char-p "asdf8234n123f")) ;;; Error cases (deftest substitute-if.error.1 (signals-error (substitute-if) program-error) t) (deftest substitute-if.error.2 (signals-error (substitute-if 'a) program-error) t) (deftest substitute-if.error.3 (signals-error (substitute-if 'a #'null) program-error) t) (deftest substitute-if.error.4 (signals-error (substitute-if 'a #'null nil 'bad t) program-error) t) (deftest substitute-if.error.5 (signals-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest substitute-if.error.6 (signals-error (substitute-if 'a #'null nil :key) program-error) t) (deftest substitute-if.error.7 (signals-error (substitute-if 'a #'null nil 1 2) program-error) t) (deftest substitute-if.error.8 (signals-error (substitute-if 'a #'cons (list 'a 'b 'c)) program-error) t) (deftest substitute-if.error.9 (signals-error (substitute-if 'a #'car (list 'a 'b 'c)) type-error) t) (deftest substitute-if.error.10 (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'car) type-error) t) (deftest substitute-if.error.11 (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'cons) program-error) t) (deftest substitute-if.error.12 (check-type-error #'(lambda (x) (substitute-if 'a #'not x)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/cons-aux.lsp0000644000000000000000000000013214542551762015726 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.713790155 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-aux.lsp0000644000175000017500000004517014542551762015333 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Mar 6 17:45:42 2003 ;;;; Contains: Auxiliary functions for cons-related tests (in-package :cl-test) ;;; ;;; 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))))) (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 my-set-exclusive-or (set1 set2 &key key test test-not) (assert (not (and test test-not))) (cond (test-not (when (symbolp test-not) (setq test-not (symbol-function test-not))) (setq test (complement test-not))) ((not test) (setq test #'eql))) ;;; (when (symbolp test) (setq test (symbol-function test))) (etypecase test (symbol (setq test (symbol-function test))) (function nil)) (etypecase key (null nil) (symbol (setq key (symbol-function key))) (function nil)) (let* ((keys1 (if key (mapcar (the function key) set1) set1)) (keys2 (if key (mapcar (the function key) set2) set2)) (mask1 (make-array (length set1) :element-type 'bit :initial-element 0)) (mask2 (make-array (length set2) :element-type 'bit :initial-element 0))) (loop for i1 from 0 for k1 in keys1 do (loop for i2 from 0 for k2 in keys2 when (funcall (the function test) k1 k2) do (setf (sbit mask1 i1) 1 (sbit mask2 i2) 1))) (nconc (loop for e in set1 for i across mask1 when (= i 0) collect e) (loop for e in set2 for i across mask2 when (= i 0) collect e)))) (defun make-random-set-exclusive-or-input (n) (let* ((set1 (loop for i from 1 to n collect (random n))) (set2 (loop for i from 1 to n collect (random n))) (test-args (random-case nil nil nil (list :test 'eql) (list :test #'eql) (list :test (complement #'eql)))) (test-not-args (and (not test-args) (random-case nil nil (list :test-not 'eql) (list :test-not #'eql) (list :test-not (complement #'eql))))) (key-args (random-case nil nil nil nil (list :key nil) (list :key 'identity) (list :key 'not)))) (list* set1 set2 (reduce #'append (random-permute (list test-args test-not-args key-args)))))) (defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) (let ((actual-fn (etypecase fn (symbol (symbol-function fn)) (function fn)))) (declare (type function actual-fn)) (loop for i below reps for args = (make-random-set-exclusive-or-input n) for set1 = (car args) for set2 = (cadr args) for result1 = (apply #'remove-duplicates (sort (copy-list (apply #'my-set-exclusive-or args)) #'<) (cddr args)) for result2 = (apply #'remove-duplicates (sort (copy-list (apply actual-fn (copy-list set1) (copy-list set2) (cddr args))) #'<) (cddr args)) unless (equal result1 result2) return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") "actual: " result2 "should be: " result1)))) (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)))))) (defvar *mapc.6-var* nil) (defun mapc.6-fun (x) (push x *mapc.6-var*) x) gcl-2.7.1/ansi-tests/PaxHeaders/directory.lsp0000644000000000000000000000013214542551762016175 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.713790155 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/directory.lsp0000644000175000017500000000311114542551762015567 0ustar00cammcamm;-*- 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 500) 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.7.1/ansi-tests/PaxHeaders/write-sequence.lsp0000644000000000000000000000013214542551763017132 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.713790155 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/write-sequence.lsp0000644000175000017500000001677314542551763016546 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/muffle-warning.lsp0000644000000000000000000000013114542551763017112 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.713790155 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/muffle-warning.lsp0000644000175000017500000000236714542551763016521 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 08:46:05 2003 ;;;; Contains: Tests of the MUFFLE-WARNING restart and function (in-package :cl-test) (deftest muffle-warning.1 (restart-case (progn (muffle-warning) 'bad) (muffle-warning () 'good)) good) (deftest muffle-warning.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (muffle-warning c2)) (muffle-warning () 'bad) (muffle-warning () 'good))) good) (deftest muffle-warning.3 (restart-case (progn (muffle-warning nil) 'bad) (muffle-warning () 'good)) good) (deftest muffle-warning.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (muffle-warning nil)) (muffle-warning () 'good) (muffle-warning () 'bad))) good) (deftest muffle-warning.5 (signals-error (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (muffle-warning c2))) control-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/block.lsp0000644000000000000000000000013014542551762015261 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.713790155 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/block.lsp0000644000175000017500000000272114542551762014663 0ustar00cammcamm;-*- 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) ;;; Block has no tagbody (deftest block.11 (block done (tagbody (block nil (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest block.12 (macrolet ((%m (z) z)) (block foo (expand-in-current-env (%m :good)))) :good) #| (deftest return.error.1 (signals-error (block nil (return 'a 'b)) program-error) t) |# gcl-2.7.1/ansi-tests/PaxHeaders/truename.lsp0000644000000000000000000000013114542551763016011 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.713790155 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/truename.lsp0000644000175000017500000000524614542551763015417 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/no-applicable-method.lsp0000644000000000000000000000013114542551763020155 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.713790155 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/no-applicable-method.lsp0000644000175000017500000000074614542551763017563 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 13:46:44 2003 ;;;; Contains: Tests of NO-APPLICABLE-METHOD (in-package :cl-test) (defgeneric no-app-meth-gf-01 (x)) (deftest no-applicable-method.1 (handler-case (progn (no-app-meth-gf-01 'x) :bad) (error () :good)) :good) ;;; I can't conformantly define useful methods for no-applicable-method ;;; without defining new generic function classes, and there's ;;; no standard way to do that. Grrr.gcl-2.7.1/ansi-tests/PaxHeaders/multiple-value-bind.lsp0000644000000000000000000000013114542551763020050 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.713790155 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/multiple-value-bind.lsp0000644000175000017500000000510514542551763017450 0ustar00cammcamm;-*- 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) ;;; No implicit tagbody (deftest multiple-value-bind.8 (block nil (tagbody (multiple-value-bind (x) nil (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Works with single values (deftest multiple-value-bind.9 (multiple-value-bind (x y z) :foo (list x y z)) (:foo nil nil)) (deftest multiple-value-bind.10 (multiple-value-bind (x) :foo x) :foo) (deftest multiple-value-bind.11 (multiple-value-bind () :foo) nil) (deftest multiple-value-bind.12 (multiple-value-bind () (values)) nil) (deftest multiple-value-bind.13 (multiple-value-bind () (values 1 2 3 4 5)) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest multiple-value-bind.14 (macrolet ((%m (z) z)) (multiple-value-bind (x y z) (expand-in-current-env (%m (values 1 2 3))) (list x y z))) (1 2 3)) ;;; Error cases (deftest multiple-value-bind.error.1 (signals-error (funcall (macro-function 'multiple-value-bind)) program-error) t) (deftest multiple-value-bind.error.2 (signals-error (funcall (macro-function 'multiple-value-bind) '(multiple-value-bind nil nil)) program-error) t) (deftest multiple-value-bind.error.3 (signals-error (funcall (macro-function 'multiple-value-bind) '(multiple-value-bind nil nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/princ-to-string.lsp0000644000000000000000000000013114542551763017230 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.713790155 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/princ-to-string.lsp0000644000175000017500000000104614542551763016630 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 26 12:19:32 2004 ;;;; Contains: Tests of PRINC-TO-STRING (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest princ-to-string.1 (random-princ-to-string-test 1000) nil) (deftest princ-to-string.2 (with-standard-io-syntax (princ-to-string 2)) "2") ;;; Error tests (deftest princ-to-string.error.1 (signals-error (princ-to-string) program-error) t) (deftest princ-to-string.error.2 (signals-error (princ-to-string nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/logand.lsp0000644000000000000000000000013214542551763015436 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.713790155 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logand.lsp0000644000175000017500000000410514542551763015034 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 8 21:23:22 2003 ;;;; Contains: Tests of LOGAND (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logand.error.1 (check-type-error #'logand #'integerp) nil) (deftest logand.error.2 (check-type-error #'(lambda (x) (logand 0 x)) #'integerp) nil) (deftest logand.error.3 (check-type-error #'(lambda (x) (logand x 1)) #'integerp) nil) ;;; Non-error tests (deftest logand.1 (logand) -1) (deftest logand.2 (logand 1231) 1231) (deftest logand.3 (logand -198) -198) (deftest logand.4 (loop for x in *integers* always (eql x (logand x))) t) (deftest logand.5 (loop for x in *integers* always (eql 0 (logand x (lognot x)))) t) (deftest logand.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql 0 (logand x xc)) collect x) nil) (deftest logand.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logand x y) repeat 1000 unless (and (if (and (< x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (and (logbitp i x) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logand.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element -1) (list 183)) always (eql (apply #'logand args) 183)) t) (deftest logand.9 (loop for i from -1 to 0 always (loop for j from -1 to 0 always (locally (declare (type (integer -1 0) i j)) (eql (logand i j) (if (or (zerop i) (zerop j)) 0 -1))))) t) (deftest logand.order.1 (let ((i 0) a b) (values (logand (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110)) i a b)) #b10010 2 1 2) (deftest logand.order.2 (let ((i 0) a b c) (values (logand (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b10000 3 1 2 3) gcl-2.7.1/ansi-tests/PaxHeaders/rational.lsp0000644000000000000000000000013114542551763016002 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.717790172 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rational.lsp0000644000175000017500000000251014542551763015377 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 13:49:18 2003 ;;;; Contains: Tests of RATIONAL (in-package :cl-test) (deftest rational.error.1 (signals-error (rational) program-error) t) (deftest rational.error.2 (signals-error (rational 0 nil) program-error) t) (deftest rational.error.3 (signals-error (rational 0 0) program-error) t) (deftest rational.error.4 (check-type-error #'rational #'realp) nil) (deftest rational.1 (loop for x in (loop for r in *reals* when (or (not (floatp r)) (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) collect r) for r = (rational x) unless (and (rationalp r) (if (floatp x) (= (float r x) x) (eql x r))) collect (list x r)) nil) (deftest rational.2 (loop for type in '(short-float single-float double-float long-float) collect (loop for i from -10000 to 10000 for x = (coerce i type) for r = (rational x) count (not (eql r i)))) (0 0 0 0)) (deftest rational.3 (loop for type in '(short-float single-float double-float long-float) for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) nconc (loop for x = (random-from-interval bound) for r = (rational x) for x2 = (float r x) repeat 1000 unless (and (rationalp r) (= x x2)) collect (list x r x2))) nil)gcl-2.7.1/ansi-tests/PaxHeaders/packages-12.lsp0000644000000000000000000000013114542551763016167 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.717790172 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-12.lsp0000644000175000017500000001473214542551763015575 0ustar00cammcamm();-*- 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.7.1/ansi-tests/PaxHeaders/subtypep-rational.lsp0000644000000000000000000000013114542551763017653 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.717790172 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-rational.lsp0000644000175000017500000001033514542551763017254 0ustar00cammcamm;-*- 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) (compile-and-load "types-aux.lsp") ;;; 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.7.1/ansi-tests/PaxHeaders/ceiling-aux.lsp0000644000000000000000000000013014542551762016374 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.717790172 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ceiling-aux.lsp0000644000175000017500000000505214542551762015776 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 19 06:52:02 2003 ;;;; Contains: Aux. functions for CEILING (in-package :cl-test) (defun ceiling.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (< (- d) r 1)) collect (list n d q r n2))) (defun ceiling.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= r 0) (< (- d) r) (= n n2)) collect (list n d q r n2))) (defun ceiling.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (ceiling n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (<= 0 (- r)) (< (- r) 1) ) collect (list n q r n2))) (defun ceiling.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (ceiling n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (<= 0 (- r)) (< (- r) 1) ) collect (list n q r n2))) (defun ceiling.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= 0 r) (< r (- d)) (= n n2)) collect (list n q d r n2))) (defun ceiling.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (ceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (<= 0 r) (< r (- d)) (= n n2)) collect (list n q d r n2))) gcl-2.7.1/ansi-tests/PaxHeaders/nbutlast.lsp0000644000000000000000000000013114542551763016025 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.717790172 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nbutlast.lsp0000644000175000017500000000453214542551763015430 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:41:54 2003 ;;;; Contains: Tests of NBUTLAST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.7 (nbutlast (list 'a 'b 'c 'd) (1+ most-positive-fixnum)) nil) (deftest nbutlast.8 (nbutlast (list 'a 'b 'c 'd) most-positive-fixnum) nil) (deftest nbutlast.9 (nbutlast (list 'a 'b 'c 'd) (1- most-positive-fixnum)) 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) ;;; Error tests (deftest nbutlast.error.1 (signals-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a)) type-error) t) (deftest nbutlast.error.2 (signals-error (nbutlast 'a 10) type-error) t) (deftest nbutlast.error.3 (signals-error (nbutlast 2 10) type-error) t) (deftest nbutlast.error.4 (signals-error (nbutlast #\w 10) type-error) t) (deftest nbutlast.error.5 (signals-error (nbutlast (list 'a 'b 'c 'd) -3) type-error) t) (deftest nbutlast.error.6 (signals-error (nbutlast (list 'a) 20.0) type-error) t) (deftest nbutlast.error.7 (signals-error (nbutlast (list 'a) -100.0) type-error) t) (deftest nbutlast.error.8 (signals-error (nbutlast) program-error) t) (deftest nbutlast.error.9 (signals-error (nbutlast (list 'a 'b 'c) 3 3) program-error) t) (deftest nbutlast.error.10 (signals-error (locally (nbutlast 'a 10) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-03.lsp0000644000000000000000000000013114542551763020766 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.717790172 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-03.lsp0000644000175000017500000002000014542551763020355 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 20:39:10 2005 ;;;; Contains: Tests that invoke the random type prop infrastructure, part 3 (in-package :cl-test) ;;; trig, hyperbolic functions here ;;; WARNING -- these tests may cause floating point overflow/underflow ;;; Ignore those failures (def-type-prop-test *.1 '* '(integer integer) 2) (def-type-prop-test *.2 '* nil 1 :rest-type 'integer :maxargs 4) (def-type-prop-test *.3 '* nil 2 :rest-type 'integer :maxargs 10) (def-type-prop-test *.4 '* '(real real) 2 :test #'approx=) (def-type-prop-test *.5 '* '(number number) 2 :test #'approx=) (def-type-prop-test \+.1 '+ '(integer integer) 2) (def-type-prop-test \+.2 '+ nil 1 :rest-type 'integer :maxargs 4) (def-type-prop-test \+.3 '+ nil 2 :rest-type 'integer :maxargs 10) (def-type-prop-test \+.4 '+ '(real real) 2 :test #'approx=) (def-type-prop-test \+.5 '+ '(number number) 2 :test #'approx=) (def-type-prop-test \-.1 '- '(integer integer) 2) (def-type-prop-test \-.2 '- nil 1 :rest-type 'integer :maxargs 4) (def-type-prop-test \-.3 '- nil 2 :rest-type 'integer :maxargs 10) (def-type-prop-test \-.4 '- '(real real) 2 :test #'approx=) (def-type-prop-test \-.5 '- '(number number) 2 :test #'approx=) (def-type-prop-test \-.6 '- '(number) 1) ;;; WARNING -- these tests may cause floating point overflow/underflow ;;; Ignore those failures (def-type-prop-test /.1 '/ '((and integer (not (satisfies zerop)))) 1) (def-type-prop-test /.2 '/ '((and rational (not (satisfies zerop)))) 1) (def-type-prop-test /.3 '/ '((and real (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) (def-type-prop-test /.4 '/ '((and complex (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) (def-type-prop-test /.5 '/ '(integer) 2 :maxargs 6 :rest-type '(and integer (not (satisfies zerop)))) (def-type-prop-test /.6 '/ '(rational) 2 :maxargs 6 :rest-type '(and rational (not (satisfies zerop)))) (def-type-prop-test /.7 '/ '(real) 2 :maxargs 6 :rest-type '(and real (not (satisfies zerop))) :test #'approx= :ignore 'arithmetic-error) (def-type-prop-test /.8 '/ '(number) 2 :maxargs 6 :rest-type '(and number (not (satisfies zerop))) :test #'approx= :ignore 'arithmetic-error) (def-type-prop-test 1+.1 '1+ '(integer) 1) (def-type-prop-test 1+.2 '1+ '(rational) 1) (def-type-prop-test 1+.3 '1+ '(real) 1) (def-type-prop-test 1+.4 '1+ '(number) 1) (def-type-prop-test 1-.1 '1- '(integer) 1) (def-type-prop-test 1-.2 '1- '(rational) 1) (def-type-prop-test 1-.3 '1- '(real) 1) (def-type-prop-test 1-.4 '1- '(number) 1) (def-type-prop-test abs.1 'abs '(integer) 1) (def-type-prop-test abs.2 'abs '(rational) 1) (def-type-prop-test abs.3 'abs '(real) 1) (def-type-prop-test abs.4 'abs '(number) 1) (def-type-prop-test evenp 'evenp '(integer) 1) (def-type-prop-test oddp 'oddp '(integer) 1) ;;; exp, expt here (def-type-prop-test gcd 'gcd nil 1 :maxargs 6 :rest-type 'integer) (def-type-prop-test lcm 'lcm nil 1 :maxargs 6 :rest-type 'integer) (def-type-prop-test log.1 'log '((and real (not (satisfies zerop)))) 1 :test #'approx=) (def-type-prop-test log.2 'log '((and number (not (satisfies zerop)))) 1 :test #'approx=) (def-type-prop-test mod.1 'mod '(integer (and integer (not (satisfies zerop)))) 2) (def-type-prop-test mod.2 'mod '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) (def-type-prop-test rem.1 'rem '(integer (and integer (not (satisfies zerop)))) 2) (def-type-prop-test rem.2 'rem '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) (def-type-prop-test signum.1 'signum '(integer) 1) (def-type-prop-test signum.2 'signum '(rational) 1) (def-type-prop-test signum.3 'signum '(real) 1) (def-type-prop-test signum.4 'signum '(number) 1) (def-type-prop-test sqrt.1 'sqrt '(integer) 1 :test #'approx=) (def-type-prop-test sqrt.2 'sqrt '(rational) 1 :test #'approx=) (def-type-prop-test sqrt.3 'sqrt '(real) 1 :test #'approx=) (def-type-prop-test sqrt.4 'sqrt '(number) 1 :test #'approx=) (def-type-prop-test isqrt 'isqrt '((integer 0)) 1) (def-type-prop-test numberp 'numberp '(t) 1) (def-type-prop-test complex.1 'complex '(integer) 1) (def-type-prop-test complex.2 'complex '(rational) 1) (def-type-prop-test complex.3 'complex '(real) 1) (def-type-prop-test complex.4 'complex '(rational rational) 2) (def-type-prop-test complex.5 'complex '(real real) 2) (def-type-prop-test complexp 'complexp '(t) 1) (def-type-prop-test conjugate 'conjugate '(number) 1) (def-type-prop-test phase.1 'phase '(real) 1) (def-type-prop-test phase.2 'phase '(number) 1 :test #'approx=) (def-type-prop-test realpart.1 'realpart '(real) 1) (def-type-prop-test realpart.2 'realpart '(number) 1) (def-type-prop-test imagpart.1 'imagpart '(real) 1) (def-type-prop-test imagpart.2 'imagpart '(number) 1) (def-type-prop-test realp 'realp '(t) 1) (def-type-prop-test numerator 'numerator '(rational) 1) (def-type-prop-test denominator 'denominator '(rational) 1) (def-type-prop-test rational 'rational '(real) 1) (def-type-prop-test rationalize 'rationalize '(real) 1) (def-type-prop-test rationalp 'rationalp '(t) 1) (def-type-prop-test ash.1 'ash '(integer (integer -32 32)) 2) (def-type-prop-test ash.2 'ash '(integer (integer -100 100)) 2) (def-type-prop-test integer-length 'integer-length '(integer) 1) (def-type-prop-test integerp 'integerp '(t) 1) (def-type-prop-test logand.1 'logand '(integer integer) 2) (def-type-prop-test logand.2 'logand nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logandc1 'logandc1 '(integer integer) 2) (def-type-prop-test logandc2 'logandc2 '(integer integer) 2) (def-type-prop-test lognand 'lognand '(integer integer) 2) (def-type-prop-test lognor 'lognor '(integer integer) 2) (def-type-prop-test logeqv.1 'logeqv '(integer integer) 2) (def-type-prop-test logeqv.2 'logeqv nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logior.1 'logior '(integer integer) 2) (def-type-prop-test logior.2 'logior nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logxor.1 'logxor '(integer integer) 2) (def-type-prop-test logxor.2 'logxor nil 2 :rest-type 'integer :maxargs 6) (def-type-prop-test logorc1 'logorc1 '(integer integer) 2) (def-type-prop-test logorc2 'logorc2 '(integer integer) 2) (def-type-prop-test lognot 'lognot '(integer) 1) (def-type-prop-test logbitp.1 'logbitp '((integer 0 32) integer) 2) (def-type-prop-test logbitp.2 'logbitp '((integer 0 100) integer) 2) ; (def-type-prop-test logbitp.3 'logbitp '((integer 0) integer) 2) (def-type-prop-test logcount 'logcount '(integer) 1) (def-type-prop-test logtest 'logtest '(integer integer) 2) (def-type-prop-test decode-float.1 'decode-float '(float) 1) (def-type-prop-test decode-float.2 '(lambda (x) (nth-value 1 (decode-float x))) '(float) 1) (def-type-prop-test decode-float.3 '(lambda (x) (nth-value 2 (decode-float x))) '(float) 1) (def-type-prop-test float-radix 'float-radix '(float) 1) (def-type-prop-test scale-float 'scale-float '(float (integer -30 30)) 2 :ignore 'arithmetic-error :test #'approx=) (def-type-prop-test float-sign.1 'float-sign '(float) 1) (def-type-prop-test float-sign.2 'float-sign '(float float) 2) (def-type-prop-test float-digits 'float-digits '(float) 1) (def-type-prop-test float-precision 'float-precision '(float) 1) (def-type-prop-test integer-decode-float.1 'integer-decode-float '(float) 1) (def-type-prop-test integer-decode-float.2 '(lambda (x) (nth-value 1 (integer-decode-float x))) '(float) 1) (def-type-prop-test integer-decode-float.3 '(lambda (x) (nth-value 2 (integer-decode-float x))) '(float) 1) (def-type-prop-test float.1 'float '(real) 1) (def-type-prop-test float.2 'float '(real float) 2) (def-type-prop-test floatp 'floatp '(t) 1) (defun has-nonzero-length (x) (> (length x) 0)) (def-type-prop-test parse-integer.1 'parse-integer '((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (satisfies has-nonzero-length))) 1) (def-type-prop-test parse-integer.2 'parse-integer `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (satisfies has-nonzero-length)) (eql :start) ,#'(lambda (x &rest rest) (declare (ignore rest)) `(integer 0 (,(length x))))) 3) (def-type-prop-test sxhash 'sxhash '(t) 1) gcl-2.7.1/ansi-tests/PaxHeaders/format-conditional.lsp0000644000000000000000000000013214542551762017762 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.717790172 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-conditional.lsp0000644000175000017500000001066414542551762017367 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 25 19:27:25 2004 ;;;; Contains: Tests of the ~[ ~] forms (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.cond.1 "~[~]" (0) "") (def-format-test format.cond.2 "~[a~]" (0) "a") (def-format-test format.cond.3 "~[a~]" (-1) "") (def-format-test format.cond.4 "~[a~]" ((1- most-negative-fixnum)) "") (def-format-test format.cond.5 "~[a~]" (1) "") (def-format-test format.cond.6 "~[a~]" ((1+ most-positive-fixnum)) "") (deftest format.cond.7 (loop for i from -1 to 10 collect (format nil "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.7 (let ((fn (formatter "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (def-format-test format.cond.8 "~0[a~;b~;c~;d~]" (3) "a" 1) (def-format-test format.cond.9 "~-1[a~;b~;c~;d~]" (3) "" 1) (def-format-test format.cond.10 "~1[a~;b~;c~;d~]" (3) "b" 1) (def-format-test format.cond.11 "~4[a~;b~;c~;d~]" (3) "" 1) (def-format-test format.cond.12 "~100000000000000000000000000000000[a~;b~;c~;d~]" (3) "" 1) (deftest format.cond.13 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i nil)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.13 (let ((fn (formatter "~V[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest format.cond.14 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" nil i)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.14 (let ((fn (formatter "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn nil i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (def-format-test format.cond.15 "~#[A~;B~]" nil "A") (def-format-test format.cond.16 "~#[A~;B~]" (nil) "B" 1) ;;; ~[ .~:; ~] (deftest format.cond\:.1 (loop for i from -100 to 100 for s = (format nil "~[~:;a~]" i) unless (or (zerop i) (string= s "a")) collect (list i s)) nil) (deftest formatter.cond\:.1 (let ((fn (formatter "~[~:;a~]"))) (loop for i from -100 to 100 for s = (formatter-call-to-string fn i) unless (or (zerop i) (string= s "a")) collect (list i s))) nil) (def-format-test format.cond\:.2 "~[a~:;b~]" (0) "a") (def-format-test format.cond\:.3 "~[a~:;b~]" ((1- most-negative-fixnum)) "b") (def-format-test format.cond\:.4 "~[a~:;b~]" ((1+ most-positive-fixnum)) "b") (deftest format.cond\:.5 (loop for i from -1 to 10 collect (format nil "~[a~;b~;c~;d~:;e~]" i)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.5 (let ((fn (formatter "~[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest format.cond\:.6 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~:;e~]" i nil)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.6 (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest format.cond\:.7 (loop for i from -1 to 10 collect (format nil "~v[a~;b~;c~;d~:;e~]" nil i)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.7 (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 collect (formatter-call-to-string fn nil i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (def-format-test format.cond\:.8 "~#[A~:;B~]" nil "A") (def-format-test format.cond\:.9 "~#[A~:;B~]" (nil nil) "B" 2) ;;; ~:[...~] (def-format-test format.\:cond.1 "~:[a~;b~]" (nil) "a") (deftest format.\:cond.2 (loop for x in *mini-universe* for s = (format nil "~:[a~;b~]" x) when (and x (not (string= s "b"))) collect (list x s)) nil) (deftest formatter.\:cond.2 (let ((fn (formatter "~:[a~;b~]"))) (loop for x in *mini-universe* for s = (formatter-call-to-string fn x) when (and x (not (string= s "b"))) collect (list x s))) nil) ;;; ~@[ ... ~] (def-format-test format.@cond.1 "~@[X~]Y~A" (1) "XY1") (def-format-test format.@cond.2 "~@[X~]Y~A" (nil 2) "Y2") gcl-2.7.1/ansi-tests/PaxHeaders/bit-ior.lsp0000644000000000000000000000013014542551762015534 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.717790172 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-ior.lsp0000644000175000017500000001532014542551762015135 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:13:34 2003 ;;;; Contains: Tests of BIT-IOR (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-ior (expand-in-current-env (%m #*0011)) #*0101)) #*0111) (deftest bit-ior.21 (macrolet ((%m (z) z)) (bit-ior #*1010 (expand-in-current-env (%m #*1100)))) #*1110) (deftest bit-ior.22 (macrolet ((%m (z) z)) (bit-ior #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*11101011) (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) (def-fold-test bit-ior.fold.1 (bit-ior #*00101 #*10100)) ;;; Random tests (deftest bit-ior.random.1 (bit-random-test-fn #'bit-ior #'logior) nil) ;;; Error tests (deftest bit-ior.error.1 (signals-error (bit-ior) program-error) t) (deftest bit-ior.error.2 (signals-error (bit-ior #*000) program-error) t) (deftest bit-ior.error.3 (signals-error (bit-ior #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ISSUES0000644000000000000000000000013214542551762014407 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.717790172 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ISSUES0000644000175000017500000000220214542551762014001 0ustar00cammcammThis file contains notes on problems in the ANSI CL spec found during the construction of the tests. 1. When building a composite stream, what happens when the component streams have different element types? 2. Should there be an UPGRADED-STREAM-ELEMENT-TYPE function. 3. The spec requires that arrays specialized to type NIL exist. Was this intended? 4. If NIL specialized arrays exist, then NIL vectors are also strings. Was this intended? 5. The spec requires that (UPGRADED-COMPLEX-PART-TYPE NIL) be (type equivalent to) NIL. 6. The definition of UPGRADED-COMPLEX-PART-TYPE appears to require that it work on arbitrary typespecs, including SATISFIES, which is not possible. 7. Was it intended that values of 'smaller' float types be coercible to values of larger float types? In CLISP, short-float has a larger range of exponents than single-float, so some shorts cannot be coerced to singles without over/underflow. 8. IMAGPART is defined as returning (* 0 number) on reals. If the implementation supports negative zero and number is a negative float, this will be -0.0 (of the appropriate type). Was this intended? gcl-2.7.1/ansi-tests/PaxHeaders/simple-base-string.lsp0000644000000000000000000000013214542551763017677 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.717790172 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-base-string.lsp0000644000175000017500000000243614542551763017302 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:30:40 2004 ;;;; Contains: Tests associated with SIMPLE-BASE-STRING (in-package :cl-test) (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) (deftest simple-base-string.9 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(simple-array nil (*)) 'simple-base-string) nil t) (deftest simple-base-string.10 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(0) :element-type nil) 'simple-base-string) nil) (deftest simple-base-string.11 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(12) :element-type nil) 'simple-base-string) nil) gcl-2.7.1/ansi-tests/PaxHeaders/copy-pprint-dispatch.lsp0000644000000000000000000000013214542551762020252 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.717790172 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/copy-pprint-dispatch.lsp0000644000175000017500000000615714542551762017661 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 04:41:29 2004 ;;;; Contains: Tests of COPY-PPRINT-DISPATCH (in-package :cl-test) (deftest copy-pprint-dispatch.1 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2)))) (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.2 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch *print-pprint-dispatch*))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2)))) (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.3 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2)))) (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.4 (with-standard-io-syntax (let ((obj '(foo bar)) (*package* (find-package :cl-test)) (*print-readably* nil) (*print-pretty* t)) (values (prin1-to-string obj) (let ((table (copy-pprint-dispatch))) (set-pprint-dispatch `(eql ,obj) #'(lambda (s obj2) (let ((*print-pretty* nil)) (format s "#.'~S" obj2))) 0 table) (let ((*print-pprint-dispatch* (copy-pprint-dispatch table))) (prin1-to-string obj))) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" "(FOO BAR)") (deftest copy-pprint-dispatch.5 (let ((new-table (copy-pprint-dispatch))) (values (eql new-table *print-pprint-dispatch*) (member new-table *universe*))) nil nil) (deftest copy-pprint-dispatch.6 (let ((new-table (copy-pprint-dispatch *print-pprint-dispatch*))) (values (eql new-table *print-pprint-dispatch*) (member new-table *universe*))) nil nil) (deftest copy-pprint-dispatch.7 (let ((new-table (copy-pprint-dispatch nil))) (values (eql new-table *print-pprint-dispatch*) (member new-table *universe*))) nil nil) (deftest copy-pprint-dispatch.8 (let* ((table1 (copy-pprint-dispatch)) (table2 (copy-pprint-dispatch table1))) (eql table1 table2)) nil) ;;; Error tests (deftest copy-pprint-dispatch.error.1 (signals-error (copy-pprint-dispatch nil nil) program-error) t) (deftest copy-pprint-dispatch.error.2 (check-type-error #'copy-pprint-dispatch #'null) nil) gcl-2.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-and.lsp0000644000000000000000000000013114542551762022601 xustar0030 mtime=1703597042.976022388 29 atime=1744294960.72179019 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-and.lsp0000644000175000017500000001340214542551762022200 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination AND (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.and.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.and.1 (x) (:method-combination and) (:method and ((x integer)) (push 4 *x*) t) (:method and ((x rational)) (push 3 *x*) nil) (:method and ((x number)) (push 2 *x*) t) (:method and ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 4)) (nil (3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.and.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.and.2 (x) (:method-combination and :most-specific-first) (:method and ((x integer)) (push 4 *x*) t) (:method and ((x rational)) (push 3 *x*) nil) (:method and ((x number)) (push 2 *x*) t) (:method and ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 4)) (nil (3)) (a (1 2)) (a (1))) (deftest defgeneric-method-combination.and.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.and.3 (x) (:method-combination and :most-specific-last) (:method and ((x integer)) (push 4 *x*) t) (:method and ((x rational)) (push 3 *x*) nil) (:method and ((x number)) (push 2 *x*) 'a) (:method and ((x t)) (push 1 *x*) t))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 2 1)) (nil (3 2 1)) (a (2 1)) (t (1))) (deftest defgeneric-method-combination.and.4 (let ((fn (eval '(defgeneric dg-mc.and.4 (x) (:method-combination and) (:method and ((x integer)) t) (:method :around ((x rational)) 'foo) (:method and ((x number)) nil) (:method and ((x symbol)) t) (:method and ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo nil a a) (deftest defgeneric-method-combination.and.5 (let ((fn (eval '(defgeneric dg-mc.and.5 (x) (:method-combination and) (:method and ((x integer)) nil) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method and ((x number)) 'a) (:method and ((x symbol)) 'b) (:method and ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo nil) (foo c) c c c) (deftest defgeneric-method-combination.and.6 (let ((fn (eval '(defgeneric dg-mc.and.6 (x) (:method-combination and) (:method and ((x integer)) 'a) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method and ((x number)) nil) (:method and ((x symbol)) 'c) (:method and ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar nil)) (foo (bar nil)) (bar nil) nil d d) (deftest defgeneric-method-combination.and.7 (let ((fn (eval '(defgeneric dg-mc.and.7 (x) (:method-combination and) (:method and ((x dgmc-class-04)) 'c) (:method and ((x dgmc-class-03)) 'b) (:method and ((x dgmc-class-02)) nil) (:method and ((x dgmc-class-01)) 'a))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) a nil a nil) (deftest defgeneric-method-combination.and.8 (let ((fn (eval '(defgeneric dg-mc.and.8 (x) (:method-combination and) (:method and ((x (eql 1000))) 'a) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method and ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (b)) (deftest defgeneric-method-combination.and.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.and.9 (x) (:method-combination and))))) (declare (type generic-function fn)) (funcall fn 'x)) (error () :error)) :error) (deftest defgeneric-method-combination.and.10 (progn (eval '(defgeneric dg-mc.and.10 (x) (:method-combination and) (:method ((x t)) t))) (handler-case (dg-mc.and.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.and.11 (progn (eval '(defgeneric dg-mc.and.11 (x) (:method-combination and) (:method nonsense ((x t)) t))) (handler-case (dg-mc.and.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.and.12 (let ((fn (eval '(defgeneric dg-mc.and.12 (x) (:method-combination and) (:method :around ((x t)) t) (:method and ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'x) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/pathnamep.lsp0000644000000000000000000000013014542551763016145 xustar0030 mtime=1703597043.012022445 29 atime=1744294960.72179019 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathnamep.lsp0000644000175000017500000000130314542551763015542 0ustar00cammcamm;-*- 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) nil) (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.7.1/ansi-tests/PaxHeaders/cons-test-01.lsp0000644000000000000000000000013114542551762016325 xustar0030 mtime=1703597042.924022307 29 atime=1744294960.72179019 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-01.lsp0000644000175000017500000000670314542551762015732 0ustar00cammcamm;-*- 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))) (compile-and-load "cons-aux.lsp") ;; ;; 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) nil) #+gcl(defvar *cons-fns* '(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)) #-gcl(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) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-19.lsp0000644000000000000000000000013114542551762016336 xustar0030 mtime=1703597042.924022307 29 atime=1744294960.72179019 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-19.lsp0000644000175000017500000004237114542551762015744 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/bit-not.lsp0000644000000000000000000000012714542551762015551 xustar0028 mtime=1703597042.9200223 29 atime=1744294960.72179019 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-not.lsp0000644000175000017500000000703414542551762015147 0ustar00cammcamm;-*- 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))) ;;; Macro env tests (deftest bit-not.16 (macrolet ((%m (z) z)) (bit-not (expand-in-current-env (%m #*10010011)))) #*01101100) (deftest bit-not.17 (macrolet ((%m (z) z)) (bit-not #*1101011010 (expand-in-current-env (%m nil)))) #*0010100101) ;;; (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) (def-fold-test bit-not.fold.1 (bit-not #*00101)) ;;; Error tests (deftest bit-not.error.1 (signals-error (bit-not) program-error) t) (deftest bit-not.error.2 (signals-error (bit-not #*000 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/define-method-combination-long-form.lsp0000644000000000000000000000013114542551762023076 xustar0030 mtime=1703597042.976022388 29 atime=1744294960.72179019 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-method-combination-long-form.lsp0000644000175000017500000002414414542551762022502 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 13 08:26:41 2003 ;;;; Contains: Tests of DEFINE-METHOD-COMBINATION (long form) (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-01* (define-method-combination mc-long-01 nil nil))) (report-and-ignore-errors (defgeneric dmc-long-gf-01 (x y) (:method-combination mc-long-01))) ) (deftest define-method-combination-long.01.1 (eqt *dmc-long-01* 'mc-long-01) t) ;;; The list of method groups specifiers for this method combination ;;; is empty, so no methods are valid. (deftest define-method-combination-long.01.2 (progn (eval '(defmethod dmc-long-gf-01 ((x t) (y t)) :foo)) (handler-case (eval '(dmc-long-gf-01 'a 'b)) (error () :caught))) :caught) ;;; A single method group with the * method group specifier (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-02* (define-method-combination mc-long-02 nil ((method-list *)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-02 (x y) (:method-combination mc-long-02))) ) (deftest define-method-combination-long.02.1 (eqt *dmc-long-02* 'mc-long-02) t) (deftest define-method-combination-long.02.2 (progn (eval '(defmethod dmc-long-gf-02 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-02 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-02 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-02 0 0) (dmc-long-gf-02 1 0) (dmc-long-gf-02 0 2) (dmc-long-gf-02 1 2))) #(z) #(a z) #(b z) #(a b z)) (deftest define-method-combination-long.02.3 (signals-error (dmc-long-gf-02 nil nil) error) t) ;;; Same, but with :order parameter. ;;; Also, :description with a format string (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-03* (define-method-combination mc-long-03 nil ((method-list * :order :most-specific-first :description "This method has qualifiers ~A" )) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-03 (x y) (:method-combination mc-long-03))) ) (deftest define-method-combination-long.03.1 (eqt *dmc-long-03* 'mc-long-03) t) (deftest define-method-combination-long.03.2 (progn (eval '(defmethod dmc-long-gf-03 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-03 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-03 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-03 0 0) (dmc-long-gf-03 1 0) (dmc-long-gf-03 0 2) (dmc-long-gf-03 1 2))) #(z) #(a z) #(b z) #(a b z)) (deftest define-method-combination-long.03.3 (signals-error (dmc-long-gf-03 nil nil) error) t) ;;; Same, but with :order parameter :most-specific-last ;;; (and testing that the :order parameter is evaluated) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-04* (let ((order :most-specific-last)) (define-method-combination mc-long-04 nil ((method-list * :order order)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list)))))) (report-and-ignore-errors (defgeneric dmc-long-gf-04 (x y) (:method-combination mc-long-04))) ) (deftest define-method-combination-long.04.1 (eqt *dmc-long-04* 'mc-long-04) t) (deftest define-method-combination-long.04.2 (progn (eval '(defmethod dmc-long-gf-04 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-04 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-04 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-04 0 0) (dmc-long-gf-04 1 0) (dmc-long-gf-04 0 2) (dmc-long-gf-04 1 2))) #(z) #(z a) #(z b) #(z b a)) (deftest define-method-combination-long.04.3 (signals-error (dmc-long-gf-04 nil nil) error) t) ;;; Empty qualifier list (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-05* (define-method-combination mc-long-05 nil ((method-list nil) (ignored-methods *)) (declare (ignorable ignored-methods)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-05 (x y) (:method-combination mc-long-05))) ) (deftest define-method-combination-long.05.1 (eqt *dmc-long-05* 'mc-long-05) t) (deftest define-method-combination-long.05.2 (progn (eval '(defmethod dmc-long-gf-05 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-05 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-05 ((x integer) (y integer)) 'z)) (eval '(defmethod dmc-long-gf-05 foo ((x t) (y t)) 'bad)) (values (dmc-long-gf-05 nil nil) (dmc-long-gf-05 0 0) (dmc-long-gf-05 1 0) (dmc-long-gf-05 0 2) (dmc-long-gf-05 1 2))) #() #(z) #(a z) #(b z) #(a b z)) ;;; :required (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-06* (define-method-combination mc-long-06 nil ((method-list nil :required t) (ignored-methods *)) (declare (ignorable ignored-methods)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-06 (x y) (:method-combination mc-long-06))) ) (deftest define-method-combination-long.06.1 (eqt *dmc-long-06* 'mc-long-06) t) (deftest define-method-combination-long.06.2 (progn (eval '(defmethod dmc-long-gf-06 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-06 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-06 ((x integer) (y integer)) 'z)) (eval '(defmethod dmc-long-gf-06 foo ((x t) (y t)) 'bad)) (values (dmc-long-gf-06 0 0) (dmc-long-gf-06 1 0) (dmc-long-gf-06 0 2) (dmc-long-gf-06 1 2))) #(z) #(a z) #(b z) #(a b z)) (deftest define-method-combination-long.06.3 (signals-error-always (dmc-long-gf-06 nil nil) error) t t) ;;; Non-empty lambda lists (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-07* (define-method-combination mc-long-07 (p1 p2) ((method-list *)) `(vector ',p1 ',p2 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-07 (x y) (:method-combination mc-long-07 1 2))) ) (deftest define-method-combination-long.07.1 (eqt *dmc-long-07* 'mc-long-07) t) (deftest define-method-combination-long.07.2 (progn (eval '(defmethod dmc-long-gf-07 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-07 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-07 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-07 0 0) (dmc-long-gf-07 1 0) (dmc-long-gf-07 0 2) (dmc-long-gf-07 1 2))) #(1 2 z) #(1 2 a z) #(1 2 b z) #(1 2 a b z)) (deftest define-method-combination-long.07.3 (signals-error (dmc-long-gf-07 nil) error) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-08* (define-method-combination mc-long-08 (p1 &optional p2 p3) ((method-list *)) `(vector ',p1 ',p2 ',p3 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-08 (x y) (:method-combination mc-long-08 1 2))) ) (deftest define-method-combination-long.08.1 (eqt *dmc-long-08* 'mc-long-08) t) (deftest define-method-combination-long.08.2 (progn (eval '(defmethod dmc-long-gf-08 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-08 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-08 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-08 0 0) (dmc-long-gf-08 1 0) (dmc-long-gf-08 0 2) (dmc-long-gf-08 1 2))) #(1 2 nil z) #(1 2 nil a z) #(1 2 nil b z) #(1 2 nil a b z)) (deftest define-method-combination-long.08.3 (signals-error (dmc-long-gf-08 nil) error) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-09* (define-method-combination mc-long-09 (p1 &key p2 p3) ((method-list *)) `(vector ',p1 ',p2 ',p3 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-09 (x y) (:method-combination mc-long-09 1 :p3 3))) ) (deftest define-method-combination-long.09.1 (eqt *dmc-long-09* 'mc-long-09) t) (deftest define-method-combination-long.09.2 (progn (eval '(defmethod dmc-long-gf-09 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-09 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-09 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-09 0 0) (dmc-long-gf-09 1 0) (dmc-long-gf-09 0 2) (dmc-long-gf-09 1 2))) #(1 nil 3 z) #(1 nil 3 a z) #(1 nil 3 b z) #(1 nil 3 a b z)) (deftest define-method-combination-long.09.3 (signals-error (dmc-long-gf-09 nil) error) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-10* (define-method-combination mc-long-10 (p1 &rest p2) ((method-list *)) `(vector ',p1 ',p2 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-10 (x y) (:method-combination mc-long-10 1 2 3 4))) ) (deftest define-method-combination-long.10.1 (eqt *dmc-long-10* 'mc-long-10) t) (deftest define-method-combination-long.10.2 (progn (eval '(defmethod dmc-long-gf-10 ((x (eql 1)) (y integer)) 'a)) (eval '(defmethod dmc-long-gf-10 ((x integer) (y (eql 2))) 'b)) (eval '(defmethod dmc-long-gf-10 ((x integer) (y integer)) 'z)) (values (dmc-long-gf-10 0 0) (dmc-long-gf-10 1 0) (dmc-long-gf-10 0 2) (dmc-long-gf-10 1 2))) #(1 (2 3 4) z) #(1 (2 3 4) a z) #(1 (2 3 4) b z) #(1 (2 3 4) a b z)) (deftest define-method-combination-long.10.3 (signals-error (dmc-long-gf-10 nil) error) t) gcl-2.7.1/ansi-tests/PaxHeaders/substitute.lsp0000644000000000000000000000013014542551763016403 xustar0029 mtime=1703597043.02802247 29 atime=1744294960.72179019 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/substitute.lsp0000644000175000017500000007620414542551763016014 0ustar00cammcamm;-*- 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)) (deftest substitute-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute 'x 'c v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b c d a b c d a b c d)) (deftest substitute-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (substitute 'x 'c v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b c d a b c d)) ;;; 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") (deftest substitute-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (substitute #\! #\a s) "xyz!bcxyz!bc")) (assert (string= (substitute #\! #\a s :count 1) "xyz!bcxyzabc")) (assert (string= (substitute #\! #\a s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyzabc"))) nil) ;;; 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) (defharmless substitute.test-and-test-not.1 (substitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.2 (substitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless substitute.test-and-test-not.3 (substitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.4 (substitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless substitute.test-and-test-not.5 (substitute #\b #\a (copy-seq "abcdab") :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.6 (substitute #\b #\a (copy-seq "abcdab") :test-not #'eql :test #'eql)) (defharmless substitute.test-and-test-not.7 (substitute 1 0 (copy-seq #*001101001) :test #'eql :test-not #'eql)) (defharmless substitute.test-and-test-not.8 (substitute 0 1 (copy-seq #*1100110101) :test-not #'eql :test #'eql)) (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)) ;;; Constant folding tests (def-fold-test substitute.fold.1 (substitute 'z 'b '(a b c))) (def-fold-test substitute.fold.2 (substitute 'z 'b #(a b c))) (def-fold-test substitute.fold.3 (substitute 0 1 #*001101)) (def-fold-test substitute.fold.4 (substitute #\a #\b "abcebadfke")) ;;; Error cases (deftest substitute.error.1 (signals-error (substitute) program-error) t) (deftest substitute.error.2 (signals-error (substitute 'a) program-error) t) (deftest substitute.error.3 (signals-error (substitute 'a 'b) program-error) t) (deftest substitute.error.4 (signals-error (substitute 'a 'b nil 'bad t) program-error) t) (deftest substitute.error.5 (signals-error (substitute 'a 'b nil 'bad t :allow-other-keys nil) program-error) t) (deftest substitute.error.6 (signals-error (substitute 'a 'b nil :key) program-error) t) (deftest substitute.error.7 (signals-error (substitute 'a 'b nil 1 2) program-error) t) (deftest substitute.error.8 (signals-error (substitute 'a 'b (list 'a 'b 'c) :test #'identity) program-error) t) (deftest substitute.error.9 (signals-error (substitute 'a 'b (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest substitute.error.10 (signals-error (substitute 'a 'b (list 'a 'b 'c) :key #'cons) program-error) t) (deftest substitute.error.11 (signals-error (substitute 'a 'b (list 'a 'b 'c) :key #'car) type-error) t) (deftest substitute.error.12 (check-type-error #'(lambda (x) (substitute 'a 'b x)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/do-symbols.lsp0000644000000000000000000000013114542551762016260 xustar0030 mtime=1703597042.980022395 29 atime=1744294960.72179019 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/do-symbols.lsp0000644000175000017500000001011414542551762015654 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 21 18:24:59 2004 ;;;; Contains: Tests of DO-SYMBOLS (in-package :cl-test) (compile-and-load "package-aux.lsp") (declaim (optimize (safety 3))) (deftest do-symbols.1 (progn (set-up-packages) (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)))))) (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)) ;; Test that do-symbols works 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) ;; Test that do-symbols works without a package being specified (deftest do-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (list (do-symbols (s) (push s x)) (sort-symbols x))) (nil (DS1:A DS1:B DS1::C DS1::D))) ;; 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))) ;;; Specialized sequences (defmacro def-do-symbols-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (assert (string= name "B")) (set-up-packages) (equalt (remove-duplicates (sort-symbols (let ((all nil)) (do-symbols (x name all) (push x all))))) (list (find-symbol "BAR" "B") (find-symbol "FOO" "A")))) t)) (def-do-symbols-test do-symbols.9 (make-array 1 :element-type 'base-char :initial-contents "B")) (def-do-symbols-test do-symbols.10 (make-array 5 :element-type 'character :fill-pointer 1 :initial-contents "BXXXX")) (def-do-symbols-test do-symbols.11 (make-array 5 :element-type 'base-char :fill-pointer 1 :initial-contents "BXXXX")) (def-do-symbols-test do-symbols.12 (make-array 1 :element-type 'base-char :adjustable t :initial-contents "B")) (def-do-symbols-test do-symbols.13 (make-array 1 :element-type 'character :adjustable t :initial-contents "B")) (def-do-symbols-test do-symbols.14 (let* ((etype 'base-char) (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-do-symbols-test do-symbols.15 (let* ((etype 'character) (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope tests (deftest do-symbols.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (do-symbols (s (return-from done x)) (declare (special x)))))) :good) (deftest do-symbols.17 (let ((x :good)) (declare (special x)) (let ((x :bad)) (do-symbols (s "CL-TEST" x) (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest do-symbols.18 (macrolet ((%m (z) z)) (do-symbols (s (expand-in-current-env (%m "CL-TEST")) :good))) :good) (deftest do-symbols.19 (macrolet ((%m (z) z)) (do-symbols (s "CL-TEST" (expand-in-current-env (%m :good))))) :good) (def-macro-test do-symbols.error.1 (do-symbols (x "CL"))) gcl-2.7.1/ansi-tests/PaxHeaders/remprop.lsp0000644000000000000000000000013114542551763015655 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.725790208 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remprop.lsp0000644000175000017500000000333714542551763015262 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 12 18:25:53 2004 ;;;; Contains: Tests for REMPROP (in-package :cl-test) (deftest remprop.1 (let ((sym (gensym))) (values (symbol-plist sym) (multiple-value-list (remprop sym :foo)) (symbol-plist sym))) nil (nil) nil) (deftest remprop.2 (let ((sym (gensym))) (values (symbol-plist sym) (copy-list (setf (symbol-plist sym) '(:foo 0))) (multiple-value-list (notnot-mv (remprop sym :foo))) (symbol-plist sym))) nil (:foo 0) (t) nil) (deftest remprop.3 (let ((sym (gensym))) (values (symbol-plist sym) (copy-list (setf (symbol-plist sym) (list :bar 1 :foo 0 :baz 2))) (multiple-value-list (notnot-mv (remprop sym :foo))) (copy-list (symbol-plist sym)) (multiple-value-list (notnot-mv (remprop sym :foo))) (symbol-plist sym))) nil (:bar 1 :foo 0 :baz 2) (t) (:bar 1 :baz 2) (nil) (:bar 1 :baz 2)) (deftest remprop.4 (let ((sym (gensym))) (values (symbol-plist sym) (copy-list (setf (symbol-plist sym) (list :bar 1 :foo 0 :baz 2 :foo 3))) (multiple-value-list (notnot-mv (remprop sym :foo))) (copy-list (symbol-plist sym)) (multiple-value-list (notnot-mv (remprop sym :foo))) (symbol-plist sym))) nil (:bar 1 :foo 0 :baz 2 :foo 3) (t) (:bar 1 :baz 2 :foo 3) (t) (:bar 1 :baz 2)) ;;; Error tests (deftest remprop.error.1 (signals-error (remprop) program-error) t) (deftest remprop.error.2 (signals-error (remprop (gensym)) program-error) t) (deftest remprop.error.3 (signals-error (remprop (gensym) nil nil) program-error) t) (deftest remprop.error.4 (check-type-error #'(lambda (x) (remprop x nil)) #'symbolp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/read-byte.lsp0000644000000000000000000000013114542551763016045 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.725790208 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-byte.lsp0000644000175000017500000001013614542551763015445 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/read-line.lsp0000644000000000000000000000013114542551763016031 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.725790208 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-line.lsp0000644000175000017500000000453114542551763015433 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/tagbody.lsp0000644000000000000000000000013114542551763015622 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.725790208 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/tagbody.lsp0000644000175000017500000000550614542551763015227 0ustar00cammcamm;-*- 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) ;;; Check that macros are not expanded before finding tags ;;; Test for issue TAGBODY-TAG-EXPANSION (deftest tagbody.17 (block done (tagbody (macrolet ((foo () 'tag)) (let (tag) (tagbody (go tag) (foo) (return-from done :bad)))) tag (return-from done :good))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest tagbody.18 (macrolet ((%m (z) z)) (tagbody (expand-in-current-env (%m :foo)))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/write-char.lsp0000644000000000000000000000013214542551763016237 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.725790208 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/write-char.lsp0000644000175000017500000000165214542551763015641 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/adjustable-array-p.lsp0000644000000000000000000000013214542551762017660 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.725790208 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/adjustable-array-p.lsp0000644000175000017500000000325314542551762017261 0ustar00cammcamm;-*- 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.6 (macrolet ((%m (z) z)) (let ((a (make-array '(5) :adjustable t))) (notnot (adjustable-array-p (expand-in-current-env (%m a)))))) 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 (signals-error (adjustable-array-p) program-error) t) (deftest adjustable-array-p.error.2 (signals-error (adjustable-array-p "aaa" nil) program-error) t) (deftest adjustable-array-p.error.3 (signals-type-error x 10 (adjustable-array-p x)) t) (deftest adjustable-array-p.error.4 (check-type-error #'adjustable-array-p #'arrayp) nil) (deftest adjustable-array-p.error.5 (signals-error (locally (adjustable-array-p 10)) type-error) t) (deftest adjustable-array-p.error.6 (signals-error (let ((x 10)) (locally (declare (optimize (safety 3))) (adjustable-array-p x))) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/with-slots.lsp0000644000000000000000000000013214542551763016307 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.725790208 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-slots.lsp0000644000175000017500000001045214542551763015707 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 17 18:04:10 2003 ;;;; Contains: Tests of WITH-SLOTS (in-package :cl-test) (deftest with-slots.1 (with-slots () nil) nil) (deftest with-slots.2 (with-slots () nil (values))) (deftest with-slots.3 (with-slots () nil (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest with-slots.4 (let ((x 0) (y 10) (z 20)) (values x y z (with-slots () (incf x) (incf y 3) (incf z 100)) x y z)) 0 10 20 120 1 13 120) ;;; with-slots is an implicit progn, not a tagbody (deftest with-slots.5 (block done (tagbody (with-slots () nil (go 10) 10 (return-from done :bad)) 10 (return-from done :good))) :good) ;;; with-slots has no implicit block (deftest with-slots.6 (block nil (with-slots () nil (return :good)) (return :bad)) :good) ;;; Tests on standard objects (defclass with-slots-class-01 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (deftest with-slots.7 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (values a b c))) x y z) (deftest with-slots.8 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (values (setf a 'p) (setf b 'q) (setf c 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.9 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (values (setq a 'p) (setq b 'q) (setq c 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.10 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots ((a2 a) (b2 b) (c2 c)) obj (values a2 b2 c2))) x y z) (deftest with-slots.11 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots ((a2 a) (b2 b) (c2 c)) obj (values (setf a2 'p) (setf b2 'q) (setf c2 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.12 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots ((a2 a) (b2 b) (c2 c)) obj (values (setq a2 'p) (setq b2 'q) (setq c2 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.13 (let ((obj (make-instance 'with-slots-class-01))) (with-slots (a b c) obj (values (setf a 'p) (setf b 'q) (setf c 'r) (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.14 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) (with-slots (a b c) obj (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad))) (values a b c)))) 1 2 3) (deftest with-slots.15 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) (with-slots (a b c) obj (with-slots ((a2 a) (b2 b) (c2 c)) (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad) (values a b c)))) 1 2 3) (deftest with-slots.16 (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad))) (with-slots (a b c) obj (with-slots (a b c) (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3) (values a b c)))) 1 2 3) (deftest with-slots.17 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad))) (with-slots (a b) obj (with-slots (c) (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3) (values a b c)))) 1 2 3) ;;; If slot is unbound, act as if slot-value had been called (defmethod slot-unbound ((class t) (instance with-slots-class-01) slot-name) 'missing) (deftest with-slots.18 (let ((obj (make-instance 'with-slots-class-01))) (with-slots (a b c) obj (values a b c))) missing missing missing) (deftest with-slots.19 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (declare (optimize (speed 3) (safety 3))) (values a b c))) x y z) (deftest with-slots.20 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj (declare (optimize (speed 3) (safety 3))) (declare (special *x*)) (values a b c))) x y z) ;;; Free declaration scope test (deftest with-slots.21 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-slots nil (return-from done x) (declare (special x)))))) :good)gcl-2.7.1/ansi-tests/PaxHeaders/unwind-protect.lsp0000644000000000000000000000013114542551763017153 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.725790208 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/unwind-protect.lsp0000644000175000017500000000463214542551763016557 0ustar00cammcamm;-*- 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)) ;;; No implicit tagbody (deftest unwind-protect.10 (block done (tagbody (unwind-protect 'foo (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Executes all forms of the implicit progn (deftest unwind-protect.11 (let ((x nil) (y nil)) (values (block nil (unwind-protect (return 'a) (setf y 'c) (setf x 'b))) x y)) a b c) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest unwind-protect.12 (macrolet ((%m (z) z)) (unwind-protect (expand-in-current-env (%m :good)) :bad)) :good) (deftest unwind-protect.13 (macrolet ((%m (z) z)) (unwind-protect :good (expand-in-current-env (%m :bad)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/room.lsp0000644000000000000000000000013214542551763015146 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.725790208 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/room.lsp0000644000175000017500000000145314542551763014547 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 09:20:47 2004 ;;;; Contains: Tests of ROOM (in-package :cl-test) (deftest room.1 (let ((s (with-output-to-string (*standard-output*) (room)))) (not (zerop (length s)))) t) (deftest room.2 (let ((s (with-output-to-string (*standard-output*) (room nil)))) (not (zerop (length s)))) t) (deftest room.3 (let ((s (with-output-to-string (*standard-output*) (room :default)))) (not (zerop (length s)))) t) (deftest room.4 (let ((s (with-output-to-string (*standard-output*) (room t)))) (not (zerop (length s)))) t) ;;; Error tests (deftest room.errpr.1 (signals-error (with-output-to-string (*standard-output*) (room nil nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/mapcar.lsp0000644000000000000000000000013114542551763015434 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.729790225 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/mapcar.lsp0000644000175000017500000000532214542551763015035 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:22:16 2003 ;;;; Contains: Tests of MAPCAR (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test mapcar.fold.1 (mapcar 'identity '(a b c d))) (def-fold-test mapcar.fold.2 (mapcar 'not '(t nil nil t t))) ;;; Error tests (deftest mapcar.error.1 (check-type-error #'(lambda (x) (mapcar #'identity x)) #'listp) nil) (deftest mapcar.error.2 (signals-error (mapcar) program-error) t) (deftest mapcar.error.3 (signals-error (mapcar #'append) program-error) t) (deftest mapcar.error.4 (signals-error (locally (mapcar #'identity 1) t) type-error) t) (deftest mapcar.error.5 (signals-error (mapcar #'car '(a b c)) type-error) t) (deftest mapcar.error.6 (signals-error (mapcar #'cons '(a b c)) program-error) t) (deftest mapcar.error.7 (signals-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest mapcar.error.8 (signals-error (mapcar #'identity (list* 1 2 3 4)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cis.lsp0000644000000000000000000000013014542551762014745 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.729790225 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cis.lsp0000644000175000017500000000212014542551762014340 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 18:42:15 2003 ;;;; Contains: Tests of CIS (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest cis.error.1 (signals-error (cis) program-error) t) (deftest cis.error.2 (signals-error (cis 0 nil) program-error) t) (deftest cis.1 (let ((result (cis 0))) (or (=t result 1) (eqlt #c(1.0 0.0)))) t) (deftest cis.2 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) for vals = (multiple-value-list (cis x)) for c = (car vals) unless (and (= (length vals) 1) (eql c (complex (float 1 x) x))) collect (cons x vals)) nil) (deftest cis.3 (loop for x = (random (* 2 pi)) for c = (cis x) repeat 1000 unless (and (complexp c) (approx= (imagpart c) (sin x)) (approx= (realpart c) (cos x))) collect (list x c (cos x) (sin x))) nil) (deftest cis.4 (loop for x = (random (coerce (* 2 pi) 'single-float)) for c = (cis x) repeat 1000 unless (and (complexp c) (approx= (imagpart c) (sin x)) (approx= (realpart c) (cos x))) collect (list x c (cos x) (sin x))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/apropos-list.lsp0000644000000000000000000000013214542551762016625 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.729790225 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/apropos-list.lsp0000644000175000017500000000471614542551762016233 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 14 06:21:45 2004 ;;;; Contains: Tests of APROPOS-LIST (in-package :cl-test) (deftest apropos-list.1 (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) (safely-delete-package pkg) (unwind-protect (progn (eval `(defpackage ,pkg (:use))) (let* ((sym (intern "FOO" pkg))) (loop for p in (list pkg (find-package pkg) (make-symbol pkg)) nconc (loop for string-designator in '("F" "O" #\F #\O "" "FOO" "FO" "OO" :|F| :|FO| :|FOO| :|O| :|OO|) for result = (apropos-list string-designator p) unless (equal result (list sym)) collect (list string-designator result))))) (safely-delete-package pkg))) nil) (deftest apropos-list.2 (let ((pkg #\A)) (safely-delete-package pkg) (unwind-protect (progn (eval `(defpackage ,pkg (:use))) (let* ((sym (intern "FOO" pkg))) (loop for string-designator in '("F" "O" #\F #\O "" "FOO" "FO" "OO" :|F| :|FO| :|FOO| :|O| :|OO|) for result = (apropos-list string-designator pkg) unless (equal result (list sym)) collect (list string-designator result)))) (safely-delete-package pkg))) nil) (deftest apropos-list.3 (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) (safely-delete-package pkg) (unwind-protect (progn (eval `(defpackage ,pkg (:use))) (intern "FOO" pkg) (apropos-list "X" pkg)) (safely-delete-package pkg))) nil) (deftest apropos-list.4 (let ((sym :|X|) (symbols (apropos-list "X"))) (notnot (member sym symbols))) t) (deftest apropos-list.5 (let ((sym :|X|) (symbols (apropos-list '#:|X|))) (notnot (member sym symbols))) t) (deftest apropos-list.6 (let ((sym :|X|) (symbols (apropos-list #\X))) (notnot (member sym symbols))) t) (deftest apropos-list.7 (let ((sym :|X|) (symbols (apropos-list "X" nil))) (notnot (member sym symbols))) t) (deftest apropos-list.8 (let ((*package* (find-package "COMMON-LISP"))) (macrolet ((%m (z) z)) (intersection '(car) (apropos-list (expand-in-current-env (%m "CAR")))))) (car)) (deftest apropos-list.9 (macrolet ((%m (z) z)) (intersection '(car) (apropos-list "CAR" (expand-in-current-env (%m (find-package "COMMON-LISP")))))) (car)) ;;; Error tests (deftest apropos-list.error.1 (signals-error (apropos-list) program-error) t) (deftest apropos-list.error.2 (signals-error (apropos-list "X" (find-package "CL-TEST") nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/locally.lsp0000644000000000000000000000013214542551763015631 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.729790225 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/locally.lsp0000644000175000017500000000141314542551763015226 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 8 06:02:47 2005 ;;;; Contains: Tests of LOCALLY (in-package :cl-test) (deftest locally.1 (locally) nil) (deftest locally.2 (locally (values))) (deftest locally.3 (locally (values 1 2 3 4)) 1 2 3 4) (deftest locally.4 (locally (declare) t) t) (deftest locally.5 (locally (declare) (declare) (declare) t) t) (deftest locally.6 (let ((x 'a)) (declare (special x)) (let ((x 'b)) (values x (locally (declare (special x)) x) x))) b a b) (deftest locally.7 (locally (declare)) nil) ;;; Macros are expanded in the appropriate environment (deftest locally.8 (macrolet ((%m (z) z)) (locally (expand-in-current-env (%m :good)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/format-a.lsp0000644000000000000000000000013214542551762015677 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.729790225 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-a.lsp0000644000175000017500000001721614542551762015304 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 2 01:42:35 2004 ;;;; Contains: Tests of printing using the ~A directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.a.1 "~a" (nil) "NIL") (deftest format.a.2 (with-standard-io-syntax (let ((*print-case* :downcase)) (format nil "~A" nil))) "nil") (deftest formatter.a.2 (with-standard-io-syntax (let ((*print-case* :downcase)) (formatter-call-to-string (formatter "~A") nil))) "nil") (deftest format.a.3 (with-standard-io-syntax (let ((*print-case* :capitalize)) (format nil "~a" nil))) "Nil") (deftest formatter.a.3 (with-standard-io-syntax (let ((*print-case* :capitalize)) (formatter-call-to-string (formatter "~a") nil))) "Nil") (def-format-test format.a.4 "~:a" (nil) "()") (def-format-test format.a.5 "~:A" ('(nil)) "(NIL)") (def-format-test format.a.6 "~:A" (#(nil)) "#(NIL)") (deftest format.a.7 (let ((fn (formatter "~a"))) (loop for c across +standard-chars+ for s1 = (string c) for s2 = (format nil "~a" s1) for s3 = (formatter-call-to-string fn s1) unless (and (string= s1 s2) (string= s2 s3)) collect (list c s1 s2 s3))) nil) (deftest format.a.8 (let ((fn (formatter "~A"))) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s1 = (and c (string c)) for s2 = (and c (format nil "~A" s1)) for s3 = (and c (formatter-call-to-string fn s1)) unless (or (null c) (string= s1 s2) (string= s2 s3)) do (incf count) and collect (list c s1 s2 s3) when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest format.a.9 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@a" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "NIL" "NIL" "NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL" " NIL") (deftest format.a.10 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~da" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "NIL" "NIL" "NIL" "NIL " "NIL " "NIL " "NIL " "NIL " "NIL " "NIL ") (deftest format.a.11 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d@:A" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (deftest format.a.12 (with-standard-io-syntax (apply #'values (loop for i from 1 to 10 for fmt = (format nil "~~~d:a" i) for s = (format nil fmt nil) for fn = (eval `(formatter ,fmt)) for s2 = (formatter-call-to-string fn nil) do (assert (string= s s2)) collect s))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.a.13 (with-standard-io-syntax (apply #'values (let ((fn (formatter "~V:a"))) (loop for i from 1 to 10 for s = (format nil "~v:A" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" "() " "() " "() " "() " "() " "() " "() " "() ") (deftest format.a.14 (with-standard-io-syntax (apply #'values (let ((fn (formatter "~V@:A"))) (loop for i from 1 to 10 for s = (format nil "~v:@a" i nil) for s2 = (formatter-call-to-string fn i nil) do (assert (string= s s2)) collect s)))) "()" "()" " ()" " ()" " ()" " ()" " ()" " ()" " ()" " ()") (def-format-test format.a.15 "~vA" (nil nil) "NIL") (def-format-test format.a.16 "~v:A" (nil nil) "()") (def-format-test format.a.17 "~@A" (nil) "NIL") (def-format-test format.a.18 "~v@A" (nil nil) "NIL") (def-format-test format.a.19 "~v:@a" (nil nil) "()") (def-format-test format.a.20 "~v@:a" (nil nil) "()") ;;; With colinc specified (def-format-test format.a.21 "~3,1a" (nil) "NIL") (def-format-test format.a.22 "~4,3a" (nil) "NIL ") (def-format-test format.a.23 "~3,3@a" (nil) "NIL") (def-format-test format.a.24 "~4,4@a" (nil) " NIL") (def-format-test format.a.25 "~5,3@a" (nil) " NIL") (def-format-test format.a.26 "~5,3A" (nil) "NIL ") (def-format-test format.a.27 "~7,3@a" (nil) " NIL") (def-format-test format.a.28 "~7,3A" (nil) "NIL ") ;;; With minpad (deftest format.a.29 (let ((fn (formatter "~v,,2A"))) (loop for i from -4 to 10 for s = (format nil "~v,,2A" i "ABC") for s2 = (formatter-call-to-string fn i "ABC") do (assert (string= s s2)) collect s)) ("ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (def-format-test format.a.30 "~3,,+2A" ("ABC") "ABC ") (def-format-test format.a.31 "~3,,0A" ("ABC") "ABC") (def-format-test format.a.32 "~3,,-1A" ("ABC") "ABC") (def-format-test format.a.33 "~3,,0A" ("ABCD") "ABCD") (def-format-test format.a.34 "~3,,-1A" ("ABCD") "ABCD") ;;; With padchar (def-format-test format.a.35 "~4,,,'XA" ("AB") "ABXX") (def-format-test format.a.36 "~4,,,a" ("AB") "AB ") (def-format-test format.a.37 "~4,,,'X@a" ("AB") "XXAB") (def-format-test format.a.38 "~4,,,@A" ("AB") " AB") (def-format-test format.a.39 "~10,,,vA" (nil "abcde") "abcde ") (def-format-test format.a.40 "~10,,,v@A" (nil "abcde") " abcde") (def-format-test format.a.41 "~10,,,va" (#\* "abcde") "abcde*****") (def-format-test format.a.42 "~10,,,v@a" (#\* "abcde") "*****abcde") ;;; Other tests (def-format-test format.a.43 "~3,,vA" (nil "ABC") "ABC") (deftest format.a.44 (let ((fn (formatter "~3,,vA"))) (loop for i from 0 to 6 for s =(format nil "~3,,vA" i "ABC") for s2 = (formatter-call-to-string fn i "ABC") do (assert (string= s s2)) collect s)) ("ABC" "ABC " "ABC " "ABC " "ABC " "ABC " "ABC ")) (deftest format.a.44a (let ((fn (formatter "~3,,v@A"))) (loop for i from 0 to 6 for s = (format nil "~3,,v@A" i "ABC") for s2 = (formatter-call-to-string fn i "ABC") do (assert (string= s s2)) collect s)) ("ABC" " ABC" " ABC" " ABC" " ABC" " ABC" " ABC")) (def-format-test format.a.45 "~4,,va" (-1 "abcd") "abcd") (def-format-test format.a.46 "~5,vA" (nil "abc") "abc ") (def-format-test format.a.47 "~5,vA" (3 "abc") "abc ") (def-format-test format.a.48 "~5,v@A" (3 "abc") " abc") ;;; # parameters (def-format-test format.a.49 "~#A" ("abc" nil nil nil) "abc " 3) (def-format-test format.a.50 "~#@a" ("abc" nil nil nil nil nil) " abc" 5) (def-format-test format.a.51 "~5,#a" ("abc" nil nil nil) "abc " 3) (def-format-test format.a.52 "~5,#@A" ("abc" nil nil nil) " abc" 3) (def-format-test format.a.53 "~4,#A" ("abc" nil nil) "abc " 2) (def-format-test format.a.54 "~4,#@A" ("abc" nil nil) " abc" 2) (def-format-test format.a.55 "~#,#A" ("abc" nil nil nil) "abc " 3) (def-format-test format.a.56 "~#,#@A" ("abc" nil nil nil) " abc" 3) (def-format-test format.a.57 "~-100A" ("xyz") "xyz") (def-format-test format.a.58 "~-100000000000000000000a" ("xyz") "xyz") gcl-2.7.1/ansi-tests/PaxHeaders/special-operator-p.lsp0000644000000000000000000000013214542551763017700 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.729790225 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/special-operator-p.lsp0000644000175000017500000000300714542551763017276 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:51:41 2003 ;;;; Contains: Tests fo SPECIAL-OPERATOR-P (in-package :cl-test) ;;; 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 (check-type-error #'special-operator-p #'symbolp) nil) (deftest special-operator-p.error.2 (signals-error (special-operator-p) program-error) t) (deftest special-operator-p.error.3 (signals-error (special-operator-p 'cons 'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/logcount.lsp0000644000000000000000000000013214542551763016024 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.729790225 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logcount.lsp0000644000175000017500000000221114542551763015416 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 23:12:56 2003 ;;;; Contains: Tests of LOGCOUNT (in-package :cl-test) ;;; Error tests (deftest logcount.error.1 (signals-error (logcount) program-error) t) (deftest logcount.error.2 (signals-error (logcount 0 nil) program-error) t) (deftest logcount.error.3 (check-type-error #'logcount #'integerp) nil) ;;; Non-error tests (deftest logcount.1 (logcount 0) 0) (deftest logcount.2 (logcount 1) 1) (deftest logcount.3 (logcount 2) 1) (deftest logcount.4 (logcount 3) 2) (deftest logcount.5 (logcount -1) 0) (deftest logcount.6 (loop for x = (random-fixnum) repeat 100 always (eql (logcount x) (logcount (lognot x)))) t) (deftest logcount.7 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) repeat 100 always (eql (logcount x) (logcount (lognot x))))) t) (deftest logcount.8 (loop for y = (random (1+ most-positive-fixnum)) repeat 100 unless (let ((cnt 0) (x y)) (loop while (> x 0) do (when (oddp x) (incf cnt)) (setf x (ash x -1))) (eql cnt (logcount y))) collect y) nil) gcl-2.7.1/ansi-tests/PaxHeaders/features.lsp0000644000000000000000000000013214542551762016007 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.729790225 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/features.lsp0000644000175000017500000000107314542551762015406 0ustar00cammcamm;-*- 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) (deftest features.4 (notnot (every #'symbolp *features*)) t) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-10.lsp0000644000000000000000000000013214542551762016326 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.729790225 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-10.lsp0000644000175000017500000000327614542551762015734 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/check-type.lsp0000644000000000000000000000013014542551762016223 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.729790225 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/check-type.lsp0000644000175000017500000000414314542551762015625 0ustar00cammcamm;-*- 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 (signals-type-error x 'a (check-type x integer)) t) (deftest check-type.3 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is NUMBER? (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) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is STRING? (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) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is NUMBER? (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) (assert (eql (type-error-datum c) x)) (assert (not (typep x (type-error-expected-type c)))) ;; Can we assume the expected-type is NUMBER? (store-value 15)))) (values (check-type x number) x))) nil 15) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest check-type.8 (let ((x 10)) (macrolet ((%m (z) z)) (check-type (expand-in-current-env (%m x)) (integer 8 13)))) nil) (deftest check-type.9 (let ((x 10)) (macrolet ((%m (z) z)) (check-type x (integer 9 12) (expand-in-current-env (%m "Foo!"))))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/doc0000644000000000000000000000013214542551762014141 xustar0030 mtime=1703597042.984022401 30 atime=1744351538.814879383 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/doc/0000755000175000017500000000000014542551762013614 5ustar00cammcammgcl-2.7.1/ansi-tests/doc/PaxHeaders/ilc2005-slides.pdf0000644000000000000000000000013214542551762017250 xustar0030 mtime=1703597042.984022401 30 atime=1744294960.729790225 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/doc/ilc2005-slides.pdf0000644000175000017500000036366214542551762016666 0ustar00cammcamm%PDF-1.3 %Çì¢ 6 0 obj <> stream xœmS¹N1å—A„û.ÜŠM<öìÚ[‚DGÚ2]HHA ü¿ÄØccom±y;óæ½9²j Rù'¾gs±“7”Ÿ¿b!!„Òk6—O˜Ú½‹Ñº•‘FAÀÔʸYæ< TmÜŠ©ÀÌí2u'”EÊÕïzŒ1¸5!0Ó8ýfNÞç ´˜¡÷ nEòA¬„ªtÈ`ú“d{: X×4Â&|úÚ‘ûZK„Ú–³å2?U? ¹ µ-†ÎÙâendstream endobj 7 0 obj 401 endobj 43 0 obj <> stream xœ•SMK1õ QjEÔñ³õ°u'›ìQÁ›a½U<Úÿ0“LL¶´‚ìa÷M&ïͼ™]@=A¨éá÷l.bbé5›ÃK'žž¡û)µ¢-õÄ‚nÌDB7ã‹ÇîK >Äøˆ§i"T€­ ð„ Sн‰ñtù8ò™MNè¤R uÌÜfž6òL¿™( óx(]<Üâ»Iô˜s¥Ê¢T>ËkÑA¥cW!†$ÆÀ‹[ˆ{,mŸ_g~/¯£Ü€ TMƒ}mÞ| u¯¹Â 3¹Wj®ukœ8‹É6ís®âιР±ï±‰JÀJµ+-çQ ùÐõçÁ¹ƒÒÓßT³j€¬k]:àµëXÚ^xQ7!pHß3Jì ¢ÌµR+mta™lqvãÌi=Ò¢éðyê¿È€V—±‹k^*tößæ1pÃ÷ò|&§Êû_XãCêÿ˱Ÿ~‹•³-I念ÁƒòÐÚ5J¼†JFæ›@åÇÅ+}KXsî]éã}Ú_•¡¿˜J|Øy—•fá…^;xôü‘Qí5endstream endobj 44 0 obj 425 endobj 57 0 obj <> stream xœ•VKo1 æM™VPB ©ÛÂló~Aⶤ=r+‴Håÿpbg’ÌÎÌ.Úì'±óåóg{n_ Æãž7»î¶»e"½Ë›ûºí®¿0Á¶¿º¼µ´ukÉ´Ðk˶»nuÿrû»GãØög·úñ‡l‰öËh*0u2_E³WL«d>M¦6žõJsôx¤OÖ´œÀèÑ4!™§MIYÖ‡âÚ+À,z¯h¿_\&‡ˆVŽÐû½*è#ѸJÁ¬¬÷fz:-4Á%ÞåZ]ŸÓšE Œpp uV¥-° Ês2ý(JT6àPº¾Yo”¾ÝÝÜA Óœ,dÉÜÁ èW²JV í«Ýw!_ÀNJcΪEbÏÐM1©C&ÄÍ”ÊÈPDȳøþï©Î6§Ð­ŠD˜Z>Ë·0bžmE¢(9w5%ÎOÉ7GVVµäÚ¢Àá0ô]ZuzÌ®*°áø”`A-œ ^ÜKÈjoLÐM1 ÞÒ \‘o<Ý/–¢ÐK7sDëlf£úù\.µ0U[mÓR¤|“Ž¾À¸%Ê2’©¢ ïø&…k³K‘Ï1r(Jˆq½˜_T\ÖjÎÕ-ì1¶ß!i'ÑÖ´ø$çˆúÕ ¤¨=Ì ¸®[_Ìç‚” »)?µ;—”î†þH]Ø€rA9Ab…²uóÌ=kÈBÝ•ãq#lþxl“#Æ1GHh”²9Y¨+Âÿ>½  ôø<\@N!>Í™i‹G„êøCºžšÉ:Äkô“´g]Ý"ø0L,àa> stream xœ•TÁn1 P„”V¥H”K1§îfÛI“AâÆiŽ{+‴•¶ÿhb'›Ì2+æ0û_Ób®Š6gfðí#×´N‘Où<«^êº,]©Dµ+ÄZ×v%mùD–¦4¿¼%‰ÒíEg rlRb\²d5†‡Á¢ïTÕ>+ëÈ:»UíbòeÂÆx˜ý°8ûÓ[Te)#‰GìÔo6û¾T&¥z]›/µÉ|Pöé*©vä¿EÃ2¸ÏÅû<—8¶ÿˆ”ºÜ´–Ñ%?ûRŽ}Ÿà§ÉÏ3¯endstream endobj 70 0 obj 474 endobj 76 0 obj <> stream xœU;o1ˆ—– &È`ƒÇc¯í$º4HWÒQ )üÿ"¶g¼¶7{芽ñŒ¿y¾u† ÒO¾—ÃÕp˜ÏÊçâ¾î†Ï_a÷k(¦cúc90z:›`w9llw¿¤(þ6?þdYÃî|ØmO4&«ž'ÍH •Ê2$9¹ Y¼]DŸÅGÙÚ¡…‘È2ø›|@#e™-ËO’L0¢ªUôÇžŠµ±Õߨ-  ™tåÙàˆÑ4gö—á,£äëA[ÖÛt`R%0Ëw%Ÿær Õc“^ò®\>xœ½O0:®Ö«l€@ä›Â’àIjhÙøuAŸTEWÀyÝAÒ*@##=¤`«‘{·ª&­få¥è£ÁÔ¶/žM¶Ô¦¹´ª-‹‘Ûnž0¸¥¿iq» “~ƒ›d@ wðXD¢}Þ8Õ&«AºõQº¥ÛH•TíX:ç8Œ—¬ó´Èb­àÜíu Ã;Îó x o•~)ÝÑïµqÜç‘Òl›W×ÄmbÏoEÇùŽÕ|÷¤z/…ÔTÅ„‹Ó¦­Lí fB8Œ„f ×Öõ TB&~n‡ë¬CW6ßØF¶ˆû£­«lñ©àkßîiYÒ±øBB±MàI;U"#˜¨îb-Né¶^t;ìëvtãÚš§ÌBìŸï÷IÖeàRyÍb³Ãšz®¾äx(ix·èúê1Y+Ó—ßqž ž›–l¡[Ê’-È%Õn~ERí]gg«“ Dûè+½@ƶX%„ucþ_> stream xœÍWÉn1’@è @Ä&ˆ‘X’C^»í°&¬.HsÌ-ˆRÂÿ(»ªÚv§gˆD„PÛåZß+W 9SBÆ?ú=ÆËWèX9™Ö×Ѷ *-oвχF8ôãàßõ¨ëà'žËJ³¶ÇUçAB™ÑÍ”í¬·µà3bâ%B 6 ê~Ejq9#yíPþ5åOwÙéxcôé2HwèÉú ‰€uQ_G"«ŒrµÞw¢í ý^è×›Cä}Qâ˜Åûé\ cjÄ—õ‹‘(þÕY £íŒ] k³ àç˜`a:Í@Ý·ìºõ¥¬RnYb8ï«\b;A· &î´W,ÜèUVf˜JBKÁk•¹ ¢dŸ ;ˆ¦„jÈ©w5ßluëkŠt5E”ѹ ‘íèùîþ^º(Ðw Âô(}›ÑCëé@ñ-#ÛÔÈî d®”¶%8Àxë´U8 ;PǘŠÔ}‰üY2F(ZG²sñ7$P9‹ÐÍNOÃä¬;«LðËõEö²‹ï‘J}·´RZë³t8ROuãÞMTËà¡õ?ò J6¸:‰š˜¹BC“—È„1 “øŸ±¶ÀJÆWJu‹IZtÍÈ«îY_Â3àXÙá¼ eG—‚ŒÓØ)9Ï)’zQw;Tì[ƒ°ÍÂH@λ@NÈ–:1ÌôS½ŸÛ8…™ñ†ª‡1"äëãÁ©CÑ{lŠ8ÊUVK_—¾¨*Mc ¹Ð…I­•OR©¥|¯;ÑöÓꤿŠ*ýµw î54—|úȸ²”ç3ìšk»•B~\aB¡)m4C¼sÕ“CïÕ⑯îH¡/ÚþÔøbGÙ•/ËÇ ØêqÀ&¿< 2d4ž§U€ìq*hXVôø ŒÓ5MªÅv ô”Ÿ6SÓEârÐÓshMñPdö4cèÙÕÔÑÈ4hïF#TñÉÅ飅»Ë]±˜$£ó²ÖîeF0|³`Zé{SÓÍ%CÚÖŽÑ»ƒ³Ð€;*Üç¸óa.¾6ñï7ûu &endstream endobj 88 0 obj 985 endobj 106 0 obj <> stream xœÍU=O1¢ „… ( b áRøðŒ¿vK(¥‰´åuQ ]¤Ëÿ/b{ì³½Ü] Úbwfìñ›7ϳksžô^®ºu·Œ¾üZ®àaìîîa|êòR>´Ös F›y㪛~Ÿ; ÎÀø§›KPŠ†è8 o#©hŸÇ 4¯ÿLUµ]Â~[ø8…ÑÈhã³qÀhž%Ó• Ã8ÿòÞžs-þr\6™)áúÊÁ”ês†E²Ú+š“ÈòQ6(«"µ}I-¡­ wõRŽ]Ç< MNGßUôy:Hr_˜p ¨R]³ˆÆw ±á.í2a7¦á!ï ýŠ¤Ý2g6Æ WbK%B{’üY‰*8¥–Ô¥&9¤Œ:ÊÃWˆŒæ4ƒ¡¶kNJ<ËáOl*Ô[Zz”Å¡·JkKÿ}&-w¢4PU·G‰8á^†‚Hš–ÉYnr‹´9ÃŦICƒN$‰Í'Þ[åä‘¢UµFÑ`ð?ØNìá2Ùr¢WÑ MÊSbGµX¨›  ÊL¤½ç˜õ:'=Â=Dâ”Hœé^HH¹ZBÓËîyU}¹ŽA#/º¥Ûé©'3®K‰š‚¤½-xQø¢‚â4훊ž¨Ô‹üc@[ó†é>l~ICY,¬W§AÃù×ã¿»ðüpWy³endstream endobj 107 0 obj 525 endobj 112 0 obj <> stream xœ½U;sÔ0f(]3i¨u$…‚veYR 3 I `ÞᙄÀÇ3áøçHÚ•%s9h€¹Â·ïo¿]¯§B-ƒPñÇÏÍI3m¦’.?6'âBßœ;/@ôÛMv•ñOÛêe+Z¯—Qô“fñÒR¿×H¨•è·šÅ…(‡D6I§Xr$¢²KÒéªx²žX¹Lv4>)€£ ¥>–üÑ ´¤8h€ÕÊ/([§“t&Wãä $÷¥äˆ­4>nÁÓjÔ` ’p%¡è!‰W m ”ê¯GÙ†NW¢ëÙ†ž`_£,¾+~È9¯3hÝ’±§–Èx#*ܬ·ØˆEÞ®w¨¢ƒqofóÜHgšîeÒuW¼3µtŸ 0ëùàÑÃD¥ÐØ&Åc^$P8Ûê“</ÇóÌ‹ÜLÛ’bõå„c¹ZêZöEþm˜NW7oœþ?5C£)A—ÞŽÝRi,…Bçë0?ËÀk‚Ž‰ (Ì L)ÖÄ]†ŒHÖ7u²·5ÑïnyßÞ§´6tÛÕ݇÷GvÊV•­pªxØQ{zn{2 F] fS‹œµà0Ž¸Ñº>WyæèçJÃqýøþîðî¨ÙKô1³¦gãþ`¤aQºŠè€J·cn(øÓ`s„ù3çVséRÃÍØ£ºJdàŠlû_¿äsT‘Ru£2ùS5êï[¨çŸwçx- }OĆ“©*âÕ°=,ò\Ë0zo‹÷ šêµÅ.~¤×ÛÏ.ºŒ.Š0¢›[@¢ ‡týÙ;bíêõŠÑ-I  ïña^ÞÌ)å]<`ô¯Øß5 "ØǺ4¡!ƒŠ–íGT]ìÅz?Éxendstream endobj 113 0 obj 719 endobj 172 0 obj <> stream xœUÉn1½÷WøÆäÐÁUv{9‚Ä 2 ê? (d‚ˆÄ¾ÂòµØ®rÛNf$„æÐSvm¯êUy)ä&üÝ]tËn) åÏîB\»«×ˆq¯Ëª}ü£¼Û´Âl¢ÝìÅƸßõh*%Æ;ÝìV<€!èGi+JÁ¯³I|ÅA‹äž%óp¢€Ìwâub¼ÙÍæW‚-z—nn“+oHïÕK’QÙ:…·aEÝnÓ-ÝÝ'¥))‘Ò9â[àÛŒ§D)nèιâŽGV($»=®™=š ñšõÖÖÐÛ¼-EBÆú†®rß&GJP°wQV¬ûžÓ¬°«€rþP×ð#öCE7Q\­ Ò· µšCmO…$“'¡'w9/I9ßce…M-ÑÝZʧµ/Àb¹ +º:CôŽ¹)Z›Š·–ÁŸdaó³U³‚2*WŒåÄ’Ö×'®•'ñŒ#åM¡C1fvX/z¯†þ>çÚ¥ørbaÓÃ/uóO£`´ÐŠŠþ5ù1VxªÒ1¶wª™!žÔ9¥€©y…C©Wl¯«Æ8hg¦ÕY}cSæÑ倆ý3Iç{ÊÝ @¬rW&l%ð^WUÒäG ý¼eÐIžKíûÙò·Œ.ÉÇŽ¡‚¦=ðÒ[3À=Y5ƒ¨LÅŽ¸À40\\åÉŸˆè CÜÖ±.ŽéÉð` ƒr-ë X¶iÖê_"­‰­5Ô¹rÍž&°írÑïÆŒmùæLÙÙrZMô.Øú]€æ‰Aú+¯8Ùìß,–L³ýäU¯{m‚]^£Ç™¼Ã§)•–XFx> …m!U[<–°Ê%&®šÄÝ…(ÿå¿àâ3è뇧w„„h‹Íj‹Cœ6x^í§L žãߌÃTséÃNRâÑQìtñ÷ôJíÈendstream endobj 173 0 obj 730 endobj 200 0 obj <> stream xœÕV»ŽS1…ˆêîjYŲ€0ÙÂÁãǵ½ ‰Ž)eºEHA 5-‚QP€o¾”±g|¯’ QR$ãÇ<Îœ9ÎJ¨•>ü}¶ìVÝJ@^+_gKqÞݹ'@ÌŸtå¨L?lïgZØ3/æËnzádþ´3L/æ»éùdJ#Œ"û2mK€lîÓ¶Ú©¼°8É0²Öya’ì”HÈæ™Ádë7ƒ§ËÏÈ»: ¼Í¾Ïå`=Ö$MßǼv3¯ÞQ./ÜÈ Ú ˆääbZÐN€Cáèúâ9לQIA6õayº.Ð2¯P‚ΖÄÚ-^Lsh©PlÁõ@åL5‰%,âxóðªíC°#¬¸M]9jP=*5ÅØÔ¤ÖvýØi.ÐÓ|: ºFÌÃFç¥¿àššúº&íM³Éä9àVPÇjej¨%;¦Náåhj°…ä¬/qgìf &C•@ÞÍ i$m ù_’‰«mò%„Ñuâ©©v'œÖÕôâ!;^s¡”𮊌D…š^=f)uï Â9âœSpIÈݬ¤®{Ób®¡eœnp¨È:*ʤö|‹ñæ*¶1YÅ1q‹7&rÝN²Ä³8PÏ­ÅtµÄAÐÝ',–%p˜‚õá[êƒAº¯eW²oÙªÙ4"Žò¢„ñõUI ¸CŸ8­HìùPĉJ|ÏcÎsý¦TLÞ&¡’Ìó4y)Byæ¾åò‘®GBóe]ávõ›#ŠôšÓ 0¦•æ]½ãŠëókâJ™1T/¦æ:5ÌCdH:»©kû…¢¦Õ[S"Ýnèa›¢þYqª¸T"Vàÿ‰ÙÓ»Å~·:IÆd{»6ak›P‚zôXN+©§_Éê+ Ùé÷o…Ö~|1ðñqk'T1G¬ŸRRÆaxG(ãJ÷H þƒÎ§CÙòvxÖ÷ÈÿUNÝ5r.]—ª! ´bÏÿ46wuíÿœÚ*„Ò"¦Úr§® ¢ ?“ù`.uéó a¤7Ôendstream endobj 201 0 obj 776 endobj 212 0 obj <> stream xœ½œû‹EÇUDÍ*¾ß/F¢&AwÒïž!!`ôÀ€‚¿ø›„ý‹|üö£ª_;Ó³{K…@îæfo·¾ÝÕŸ®ª®¹GùÀü?øúÓÃÝ£Ý#÷ÍÞheÜÿî[¥Ø<ši°\È‘ ÿšûv·|;üùÇ_¿ìnÿ0ðÝí¯ý÷¿ûÒ}yðÕðÄîâÁð=¼Ñ°ŠÅ÷QãÞGú´÷áÁHüòÓÃáþåîö.Ý¡í{ÿò6–ñQ —w7Ÿ»uùÛŽ\šáòçÝͧü¥{'Ã_x®^öWrÐs¸úñ¹—ŸTüÁïñþ>¾úuq¹*S»%©Lí^˜Dªa*ì–Ãå7»›oÞºáˆYfõ“•q_)MÖî£f˜™'pxµ­¦†Åá1NœWñ²SánL:ß舓¶ãL:îÒªQuÝKžâ^²r/v”w a±wñI”‹¨ö/Uû—:Ê¿¸öT‚œè_\ðÑú—žØhO§`Æ)7ˆÁ+á´x#yÖ%a\²‘sYÎ&P9.›gâ\¨èùoÇ«©¸òNÅâõkáZX÷!°PnúŸøÅWg „‘’Ø ÓFŒ6û$J‘":ÙßþrÁË>ñkE ’Ç[ŸÆU´·QCøÅp;’äú†&RT{MJ‰q šþ†…#TÖä,EÈÝ·#¶þÙ0›ÎÞli%øØ«¸þÏ~äÞÆ–0Žsñ$Þ²™½ÞµÈ¿é÷ý¨ñy¸-ùTƒe:ÊIÉí‡@8ê0h)‹Sw' árjfR”3‰}wC)ͽÏ5Y-+ÉÃãÔþ»€«!ßFN³ '©iùè?"räiœ)“4L¤YòÈEdú¸CWaˆÈžï·»b[”^mùN|¶]gÆ!¡E«;h‰±üõÚ?ïá¥Í@õ—"ûD~ñš‹ ZžZáÍÆ9»s€ý´d맶ÒB4ØÚ`” b*·jË‹PaH‹Üäšéi‘´˜ "…”0!8!Ìæ q›³‰ë+ßÖysvø‘6ãÈÆXòÂíòU´Ì ª¸Ôg7+ÌnŒɳÈÞR?¢F?ˆ*ÛBÔ}2¯ówV;+LâG@\ lJÏ&sÅäÍóXõS ZŠ†1É] ÚÕÖXÒÝxUÐ"Ô©°.aÀ "Ñ^Ö¦ò¼5tL¥%¨š*‚ò„EV t¹YËì…Ž¶R‚LPE‹Ì Jp¬|,¦ž‰ËYB3_)ûá9ûé(£Åfp-—]B¾“LUµå¬›˜¥µ|&&£¢Æ¤ðßI˜ÜDØM‹2¡Äšl»ˆ£ÒŽVlÛ¹×¾úî‘Ìe´x Êšœ;,–S«™ÛjĶÓòNø•Ó¯‰îÝ‚ó BùF»ì%ºÔ+À<Ã*æ;ædœUÉ k’ïù(÷¤EdÁ1þjöÏ¥ŠOÆÌRå¨ÅkG-!ƒ0Î Ìðu\gsez“ï!;_« %dœILîvZCMLæÜÆ}„‚ ê¨Ñ߈~¨ƒ×Nüx~ù9L6Pôupje är'*úÂ{k#Ri!¤jås‰ E %¥Ý¦Œ¼Džj%@a7„š{ž||uï]´ˆ ºÄoëÀ2)¾³a6)]Å<»½ú€®r.Ó£rõf^4eZ—¹Ž¹Që™´ì ³³^.Ww ¯c)DYÂnG-9™•‚¥„ëAÕf›£ì<“b–ô§ïšQÖÍeÄä+@ÅV.RóY†YTÅ$35¾<­…¥yó\,ÉÆUaja¨qŒHùêLjû|<Ç*KKg-9k:6(@¤ëzC¶+r3ï*ËkyÊ¢E`µÞœ´7Ý!Ói‰L÷½˜qz+šjÊÃà‰¼ (¡¾8lXN‹¿`¹ºñ$S»GÑÞ¶‹egZÚk;ºh᧠À¯è¶äiÂíuƒ~¸šÏ¤ŸšgòÖ!7šád'ž÷~åšmþÙFáÃáÌM«p§V¾õÜ*Š¤%Ÿ9/vfêUlzˆ·@e«^Êháç”™6þcuò/7eÐTZØ…IÓ°»Mµ&'¹-æÝx9‰&éhž +íü°ôc:ÚéŒ#-zÃ86‘gÓ”Ñ?ç=|¶Ùñ;²®BÞŵ~&…aä'ÞœÍ#/ÊŽùy]V» ÉΔ<íC|±)^2<²Î}â¤Ô¤ÓÒ2H_h±,«8Íaaö¿>öÕÝ”ÑÒ2(óäcªŽA+”禓-[iql]zNGeŸÊÙæÆâ°§Gu–*/Ïo£åWv˜9£’•º`ù(Õa@¶uˆÊÎF.À3ÿÌg‚]õ¯c=Ò¡ ‚»Ž‰üû°§FØ¿ŸFÊÿû¯JàBendstream endobj 213 0 obj 2522 endobj 220 0 obj <> stream xœ½Z[‹ENBÔä(^#*#&f£™Ù¾Ît ººàB…¾ì[Ô!B‚þ"ãí_ZÝU}›Ìåœ=´²Û;Ó=_UuõUw?mXÇæþÑÏÇO6O7Oîÿ~<~Òœl7Ç_6¼Ùþ¼ ¯¶îÅe§­L³}²9jïmÙ¸gÛ7Gk´²ÚøöM×–M˹o¾ê ÓHaýÞp€6ҷߦþJûæ›[ýüW{ ÛûæÔ• ß| ›ð¼Ç?œßóa4Žß~³øéû±¿Í>Æáá#7Ú]÷ªÄO½^•ƒoD#ìù©¬!ðñ5×V ׬ڢ‹®bg)pì—ÈEàki™A394±4ýú,¸ÿBÚr„öÜÛ¦|󹟢·£K[¡a@ü¼ùçoŠ°Ðj4CTb6åÈógøPÛd|cÏwƒ©Ö¦‘œ©¬œJ}1•¨óÍÐ 8klù.Ë­â ýð9ƳŮ·# |ú Ÿ£·ÉÁááCtpøì›ô!3dqm]ìì—T3ð,ZŒ?¥RßÓmó=,m˜L=Lž†ê¡!5³]ošÞ*Û €“³ÍñÙ·ÍoÏ~ÿisüCÃ7Ç߸ÿN¾û ~œ}Ý\ÚœžÅ¡b8ŽêŒGóNï7ÎÎl#¥c›Þˆ®÷|ó/ÍUL‘žÍOÿÌ cäz`þع֦ùÅj =c¢ª¢Wf¨áw9YyÆHm;³âw>ò;QÇšß%ã{¯›=Ñ c;Yø]ÏR¢÷»ÙÉï\ Ô1\1à™ýæûŽ~7BurºÊ™OôÄXc¾b(yÐPÑ8cV'QÖ…bX.…8pJÁçG>GG†¢LÇÌB‰Ucr¼ŽpÈô†‹ Jšl*‚dd]¾#µ4û‚¶á¤m>^ƒV•L™UÆ%]C¡ÔÕY (¥T–1ß 4 K),U©väòJ"cëò/ÄA Þ )KPª’)@qTª=|ªå¬tº›—I+ôø¥Ð™²†ïìæÖ#§Á…–Š¶’ÔÉu)ÚÏCÎ$%õµEqAÆ ÃkYÇ*s›0nªõÖ’MW)n¤ôÃJaã ÔhËKaÊ©`Jgb,A&Üì®Jwæ©Ö(îÙIžKÀj’æt#RÝ°n+º°A‡öèíã"Ë^ö¹Šë±fåê2‹«+^•øÜLtÔ'á÷¥ÕÁÔ¤>…D}÷ÑMfŸ9Îe¡1…ΈOÆ=ƒ¨$7ûÐ]ðAUºÃ€¬Ó]s(Ý @s¢6ÝA=É}=Œë‹Ç¤Æ6:T*'‰Žh½LfdU]2Ó¸Õ€µòŸk`ª˜w±+:¬óJp±‘©’I{n+RmÂËþå~y}¡u Ë*e®˜e\ºÖ U¥/íÛ‚ÈŽºäíàQŸ®€9”‚4‡¨6Aå+¬'wHÙdJ]Þñ¦LUˆý“5pUyHJ` ÇC™²M¼s9d^ÖO%æÀ4‚ª„k¦w¢'d®ç¬a§ˆÕå,pŠ“ï!ÿÍJݦ*Ky0ÔƒNu=0ªMN•a¿~ò¼b”¨§dÕJž 3ë’˜_%€”&bÌv6S¸CIM ÿ©qÖÉLWµX)ÂLó&~æ›ðmÄR¸ÊƒKåTƒok׆f‹±~'AØúÝŸó^—½áSˆ–ÏJ±®*Â+#œ+ícB*`vÅîº,åZ*«äÒYΠЪr–‡–”Õ ’«&± œ5wÜ@¥àzÖX0².cy#¹ÔTO„ ’ »Ÿ¯€;”±$†¾2cqÓ;Ʋá„îzÔï‹9½¬C½ÔÁg.ŸÃgÐÄ›ò%9¡*{¡æÜìR àj²‚SËÈ—©—ùB3rŽL¬µbp›¹¨ÊÝêêÒ7”iÚéz¸¦&¡!˜‘{ñpeì;X tA'^á »"1Í”g--/¼tê¼`zUšÃ  žhnî°%€9Öø`ë_øà½ð\aÓîÔÔ}¶¹â'èÐø/Š­m‰¢Êå«e…̬K\`¦žÝÀŸ«;#´ª´å#0:­\ªj@/°B/”×Bœ&³ãíûå#ÿ`g]óv®—’LUëÝ"†Zžî}ì@Bã‹Ž t™±Í^ù|4¸P˵gðK]ŠóAJ{øs©&€9”â´î«YBÔüšÜuA0úìMºC3Éo:»¯é²ÚÂ}Éõm¸àºdq—7BM2·KÁT¥?è/l»]Á ¤cŽQ´¿ŽCˆtq/õ…ã4¢ÄAv¡¨ÔåGïˆÄ³I)€©Ê~Š¤²•îó¼2‘ývh¬(ÓÒ0¹&ÊwvÒFÜ(œj¾$^ðQ]®ôs\)—9üB—œèrÿ[p;›¥}àá8î}’»ÑF÷ï?óÞÕÓendstream endobj 221 0 obj 1845 endobj 227 0 obj <> stream xœ½V]k1UñAV©•¿ ôI›É$»É£‚o¾÷±o„ õOù7ÍÇlvf»»¹ÐÛÉÍÇ™™sNr­Ì(“?ô}yÕ]w× ÊØøuy¥>î»ó Ôþ[7NÕù‡åo0jÕíîœî¿wøAí¿v»{9ÎÛ„ÔДà0¨|,ÑÅÏú…êF¨¬¯³/NóˆÊš¾ <È1(Œ|³Jôœ`Xƒ%>"Ã47EaÔ˜À²£ÒÙºgÐrVW³ÒôJcˆî›2„ש°”ìÃ2Ù…¶<.¹¶.>&Îóó£_M'ƒ‹+%ÏSýô[JÓÖ•ï*Œ!* `j%ŸµÔ©M?h ëÛ¸ l 7€yØ F*Û(Óàs·{rz’ÖZÙ¸ÐoŠÃD’T 0‚C£œ¬¨*Ä—­LŽÓ±®¼;–ÅÍé<[Àšüë:H¾7"yÀ ú-­`-t6‰=¥Y©˜„¹æ…?«Áà'¤¹´¤±R’ÌA*­Ir¼¥’µUDƒ÷U ÊZóØ›jª¡§)÷©”àDÏX)¡òæWM.0ûhEy8…XD˜ˆ5rÏ6óëmŒPöŸX&šküœ8u@Ñd.·Iv"èQfÝÌÈpî@¡2!á8ád_6Yñ Fó¸èÆcIé^Øó½<Ù¬ºbÖ/®·"ÿì¤ü §çI@ï7Ônûáï-‡(<(rräK„_‚ùª²–ó+ݾÚGÚR¢›Ã,Uï¸[$ h$±ÎÍZ™œv”„„Rp¦ZäÞs_w…SO+¥l”2bSªà?¿ï²{j¥&ï¹w±ôr2Yù* 6Œâ$U,³(ß’Ù+7ž%®n>gäA£•ñŠéŠ;OÈOO8FÍP†gĶD|œ¹„\ï¸j&¶ŽõÇhäJtii;)7ÏÛ.v$‡¡f*ž}y;¹`Xêߊn#ÃžÛ K[ßîìäŸ /]ò€Iä1.kæ 'CÜ~s1q@q˜GÆAZ?hw‚X)†tÃÌÞ Ö2u…ä\|=àA*šó~Ú«/]þü7Öˆsendstream endobj 228 0 obj 824 endobj 231 0 obj <> stream xœµVKkA6AÆ  ñ â¡=e£LìçôôMOF×Ès‹Ä°É!ñþ ÿàó/Z]U=ݽdÀ‹,dSÛõøꫯzf.ä–2~ø{神7s¡ð·ôµw$Íšû…³ý&¹¶ñ+åV/¼öbvÔL–7g‡FY1{ÙLvßFÛ€o´®Ð¡ 6›­çP9· Í•ämèô˜Ý=ÙwÈYÉ®>V½/­9ø.;kMµ×’ãH"Èífòms#æé5žÜ 8¿ÐP ¸«tü l¾Gû"ÚÚA¿¸Ð=`¹Tì/”1ÂØ"l-sJhÂÕñ’ ¯R¸Ê3ƒôýRBÈ *wÏÛÎå5¦hÞGÖ­sÑ'2¦™¸ïè 2qDÝ:WÖEe)œË¶Žp>¡`ÈƵÑ!ªbe²A*)P"‰Ò$vÂÎ{x¹´«‘˜šƒ@¬1.ä dYQ14pf±þµå˜ˆg@Æ¡ ¤<'¨jïDÛ{lkJª ¤¥¬».ûÁ¡*!+Õx_üÁt &ß1|V G¶½ËÞq?Éù56‚hÞDŽ5踅‰•mzÑò>H¥x÷S]6[kwô*ÚÖ»]à¢ÏþN?¤ŽuÙ£â=M¥(ôŒ‘MÇ?iâAð½sH© g9ìÐéÐèëÂHâ‰Ì"`Ί\öÙêi¾'€†é æãŸúMÎcTõÕèauzú‘4j‡žN™ªWf½ª¬Wàú£ ©L­õÞÿ%år¦Fªxö)[güqãce±%m²T§Üq½\Jºl¶PYëP5éû¼}­µƒ´Óž(© eà ÂO¦iR¾îm%}F3ÊÌÂp»z¸jq¸²®nqÁµ–¯_0<øŒ5õp Ñi>KòeŽ8³îÇf;ÕÕgýù3ÒvìªÑ©âvuQfCþóaXŒ ‡U îܾXpŠ‰®¿S¼Œ•1¥®™– ´eë´Ÿ’pÓkÉ~­µBÇÎ5:Á­ƒ:~¶)ÙQ¬•”IÂÕuç-Sÿ6\¦¾ieQÛ E ×Åg·! .”š[âx¿ðX=¼Z:^MíøúÙÛ—¾2»B~8å—ò¥—“Èèv|¤oàK¹®$WÆË/=†µN¦'|7ÓnÒlÖ((îè|wq˜tWìòþñÛÕ‚ ã\F1 娉 …g½L=M@/•ýþA×`ã-ÆHo3RjCGëñLì4ñóZ/”endstream endobj 232 0 obj 967 endobj 241 0 obj <> stream xœVIkTAVQ/3b"Šd¢¼ØÕÛ{í%(x2qpä”àAˆÿ•žâ¾ü:»»ª¦»3ÉaRSÕµ|õUÕœ ¹BÆ?ú<>mΚ3é;þ8>O'Í£'Ää]æmüǸnÏ Óù=/&§Ív'ï›V °FLNšñ­(kÑ$ñ:«uŸä­(K¡4Z~`ó$.£<Š‡£,šñúîNô£<>¼‚–2;ÕBƒMâ¥iJ]i Ò'q¥|ºJºÞf]ke/Z#JßÝFwÑÈaZãøê‚G—„"PÚàð¾+|†ú¹¬Ç©*!tQ¦ÖgȤДýy™îò­(ßW•_[Ìã-Ù¶ ë8"¿£¾á¤1Ìëdm„6ð·(ƒ§Ö®°Ö‚´Gh¬©éß“6<¶˜Ø„›*/ð¾¬AQ{ÎYmdVCâÀIà@ìñAŒ¸“:Ž¥ýH6Î'ÕËÄ” $?“ÿÂøû¿ÁÂ`ËÃã6@Ž9üJß…vydíMB¶4¸/HÌ-Ú$[«ò<æ¿™’VŸ­1¯ŒªiE¸¬".(\¦˜ZªL¹VÙ¶óFzlC•P%º”™*ƒLG¤Ÿ3"±ˆ×6ê\_I¾”€`\椡¯¢è‹ëãô©šéÚÐU1@kdéh uYE#»K(“<ÂÞÖ“tg0f´Ô˜Ak4¯6K]Ÿ:¼ýçwdŸs&°½§Bï!ƒiú/nëâMÂ-ÌO]A4!Ò*ÂüÒ‚œùTÒÓ-ÆNƒ/±“P«îUœçÿ§šÆÉá|t²jjK“4kUkAJœbgÃVU]‘îㇼl^ä«åq‰ÇFÏkjf÷Åæ’B;ºöNçÜ¢LìúÌû¤¥Ú˜`d?B÷º[g„º,&2BC7ÏÁèÒa™ugâ¢T´¦±Ñ‘äÄs¬Ëøpú83ÔÔ^ÌNð¨`-Ÿ¦·XWÙ‚¬p¥I™. U,Ϩ–EÆaukíó% —µí0øU>q>ç’¡©W Æ +]ÓZÇ œ™O…”˜yôi öñ‹°ûAeIPÐÓ%¾”NSXµ®žÂvD ¹jÊ‚%âbÓ —°\3½«©\žÓkL³’Hm> stream xœUM‹1ñb+ºãŠìª‹%;ƒô˜T>:9*¼sœÛŠa„ñGù'ôÇ™¤*Ý•vf`e=•T^ªê½ªìA­5¨üãïÍ®Ûw{Ðe­~nvðaÓ½{6ߺêÚç?Ã:‚óv°ÙuË«Õæ{§Á[Ø|í–—ÙêqDU~å…dG2ïf3]£±˜PÍbeË€‹ÅÚþ,Xt ìíÚïÉû!o£õÅ~DXA`%ä04gQ¸®ØŽ°Ï+t‹­M(ökBCc4Êé_Å)RÜÉñs·|¶º.!FÓd?a0ÚóÎÑÐøª8e§ èYUIW2ð\Þ_•<ôvÐäõª¬Eðtõ}‚ü¬®"šëoÞ4’ÀT7TsÎŒ<ÜkÓÖÕ©‰¥ÞZ„~°ÄÄŠÇ ®HR6˜Èx\$å@GU£ªyÛrcÖ;Õ$RÓ褯’®8¨¦@tð¢æcÛB…êTb¢´ÛÇÆ{[l/‚ÌLËo*ËÊÿo†>6so¬+°k5Ï (õÀPX$ÒŽ7·IWê|H¹õÖápBÕ<<.ØÂã<ôYS¨…Æ:wÌüE“Š zYA¤@µ@§{„3½äÉä¨ÔOy×:Yé]¹âÑáÝg´=P©±ìd–Žó|¨*1ϧy½ í)7/&{ˆ¾1•ƒ£z•Éì±’£5ÍA îÄ|Nqp™¶ËJ˜'^°ü ž×‡I+#Nô6ߤPT61<…Ÿ0•á„ ŠnXýãlbaÔæåHhª¡Z•!¥9éÙ«shBå¾ÃFV¹c¼ä&»Ì{xª¹ ›¿Å8Ðt€9.€-۪ѣn3?<#4³þ|T« 9«Ä5oAÕ~©w —9í]OÏÄôlòÃ4ÖŽÅÙ³ÂÃ6Œ][ÓèÑÈÐ̶Yú DÎä%gèúOÙü¸/]þýÆù¢endstream endobj 257 0 obj 726 endobj 262 0 obj <> stream xœÅV˪1•»Ò¾¢u|– 8ƒô˜w'nDÁ¸f9»+.„®%ø~œ•T%ôôÌèJfÑSIºRuêÔ©¾±– ⟗»îª»™Öòãrï7Ýëw aóµËGûøGµvà„^{Øìºå“Õæ['ÁØ|é–‹hõj¥DZøÐdžE¯‘*™Íd]DKƒ ÉÚþH¾4HO¾·ßi¿§Ó7y[—ì[äËW¾Ð³šw•$ç2û¶äûNvÝú–Ú'û9ySZ7Þ(§s¾ŠS¤¸ñà§nyoõ2…t“ýèSƒ–6™×JDCsV„1;™œ^ Ó J RQáýUZñ˜9Áô&]ëÉ~&³ƒu¸Ö/Ò®‘˜9¹~›Ü ·RSZÏÒZGæŸPU|¸ÐëIUçz ¡É ŪQ¤&ñ…·ÓÕé7Ÿ&½Þ'ÿ¶…Í5/(¡çè|ž·7v)FÏ©žåÓCC)Ûà6¥”aŸôÚ\Q2róG+T1išée ô&³åwZ³ˆ÷‹3ù_%Æ„b­ª D!”\’í’ßÄ$ÖšèxŸk€2‡+é5Œ—I ¶|•KTà‰´™¦º™š„P¹IhIh R9X…УäÚdaé¹ß¬¸Ö¼'*¿eÁÔcãFþó™d_¢ÈÖÊYí?ÉÇ=1Ýc>ë_Ó܆¤xF G­áÛ÷8z¿tóQjà UVÕVz*G|šA¤µh±”£7QfP™lr:‘e£·â0Cb‰M]qÓôzŽâ輦A zxÐÐN•v¿Î@骟GâÏ&ƒ¡ÊÞt…-´:!ªÿþ¾ÂQŠVÃ~O2m½—KP¾ Ç‹-À\P†6Š¹Ñ‡oÓвEç'uúvÓG$9Ž<·ý¡Œ¢nZQwGHxZÔU¥j¨J›‘òzL‰Ã@Á}Œæ‡ |îâïëPsendstream endobj 263 0 obj 782 endobj 266 0 obj <> stream xœ¥UMÔ0 …ÔEìò!Ä.̉™C—ØNš„ ‰¤綈Ò ÿ€?Ãï$ŸÓ¸LG‹V•¦ãØuž_üœ¨+Ÿò¾Þv»n˜Öêëz ŸÆîÝG@¿w5´ô@WŒŽ¿ã¶[ázüÑõ h4ŒßºÕ“h3ôˆÉ|PÝì’ý&Ú ˆsôæg Oæiö¢ÏææW´Cä—nõlý6æ!Ÿ?<É‘jJÊÀh’ygɶ±¨|2¶ŸžŸ3“¯XÑgÿû”ÚË©@¦šÁßkpJÎ`|Sªæ>)Ù 3Å]AOFXÄLJ´0X ½6œ¼NkHáiÀÄíyàvÆA4•¨1'½,Nã&3ì1ðTC;_Dƒ€ÐÉTnh7ÊûÜ•4Ÿ–P&>Ò¾!^ç’6«È{¿Ú³l&–{²g×|AÂqMhCÇ0û…>¯Ø}«&%àù66°¢ÊY­ ºµ7#—}°]4“=Ø.‹·ÇU$o²³fo¥É\ 1ÔQ“¸'vÎ[%‚]x©}»ƒ!ATæd´nˆÂ)åývà•»¢Êú¢å¦'S—YÛvYÏËÅÌn†|p¨Ð·xʼW¶Ü[ap™guÖð2 Ðg@Ok3A®‘Â/Ã!ÉÍÀºÑz=8ÐTêyY’ÚlþŽæç¾vñù Ù·Ù> stream xœ¥VMkAEñ4ŠFãÁ€` ‚dbWLwßTð¤aŽ¹E<Ö³Wõ ˆ§€þñ/èo³««:Ó=É,!²‡Ý×U¯êUUïÔ‚¢|vën ˜×Ê×Á!<»‡a|Õ•£=ý°zØÀ)¿ç`<ìV7vÇ×`|Ù­n1ò˜Ñþ[†.fx…PoÊx‹qŒ|ÞÑ‚E@£3ÆÙ…‹lÑf¸ÍÁ]Ù_—tÌä a=6L´2¾*»¦æMŽNû”‚cÚÉSð)²l[ÓÂ2Ö>¥V¨¬òÊôçíN^‹ …ï#ɪژG¦Ð{íÀh¦t’"}<§('£s“% .˜)8ªš¸)Ëèp2m b c{ Û¾ÉQ%&>ÈAk7‰O®ÔbŒY@?¦£Ï»ÕÎîýŽôñ•R ¥ÄT¨…xZn ãؤ•iâ²jIb ·ãp.Kð:ªYô¶¶K½P¹.¶µT:¬9ä{ù²Ç˜ê1Èÿ¯ÇtÔhfó›Éûrý‹œlûÓ)®¾e©D«¯I+êb¾øž¶œ&ÑÙò»lɹtÙ6¶½Ë¦Ž²)Ï?HF$ùGeˆ±°rxŸëæÿ›Ù¥P¢¯bK»\"4²ªî:у^TêÇ42¥¶6*ÎÇŸ9×0nšÙ\Ìj&¹o‹Ù.sj1¥ª]> stream xœíTK‹1Öõ¢QÔÅ‹zÐÂÎ I%é<ŽŽ.8  0àeo«„VÜŸ Þ{ FëÅú /ØB†g 6&H|¾=¢/F‚qŸÉ°EÌÖÊ}3<ïð²±®˜\ÎßÀH,áXõ: +`§²¹•ÆÅÁ1ë9_OµÍø\áò|DqÀ\%¿zà,_¾Â\Ʋ¬í'lÎÆ'‹±-\%o•ü}&sZZ`ã¹€¥¶ÇLe ³³×Lð‘> ®)½Zª±*àL¯*Iz¦<Áz3^¬êlß  Ý ªr?e1¯æ€u_@òÃÄÃÄÇ~â-0|Å0q(¯ù.è”áÛaŸ øÿ¶½ÛÜ ò'/kg°Æ¥¸©;¤Îð¾W”iÖ™Æó=YhJ*,jÖ†§êa;™Þ `C4z5mÑS쨩í™úè~à ûlßÚ3ºT™êƒÅ†p~X$“RW¤­™¼‡›;ÇXP8ÄW¥Éx…ãè´u À…4™ŠñôŽ|ötï¡ß— Æ·è1¹{_Ó›òˆØšf®¥·– F9icR6o­ÃÛª??Ql[*­J±kQ±k]Ù³?*œ|Γ¸ëÜo¤ÝƒWƒH:®.íŽ<Ú€žº´l´È1|áFÅñÃ^š£ ÚØ…+@ÆaaZ j•bPíªÂ‡Oú¥0¿æÂ`]Ú+´ñVf[fæÏW&m¹ÀCù°§ñÿ·è¿´E±#À—$ÿÒ8´†ÆÙÜM«çD Ž £Lóò]¶Ä Öl€VÁŠ@@žTÈl”ŠEÖÿf_ý¾bvZendstream endobj 277 0 obj 700 endobj 288 0 obj <> stream xœÝU½n1î÷(¦K(L<þw í…è”+.   P: JxˆðžŠ±=^¯Ww+A]±7žñÌ|Ÿ?w Ÿ ÈôãïùvØ ;À¼V?ç[x6'Oa¼j¨H´‹àe„q;Ÿ>7zZÁøf8¾L¶PÀæ«dJP!fó,{Ñ‚Ò!/œ?JÛLrûЈè²y•LëAIí/9›7 šm§f”Éö{nF!fûºVS+Ýüã~GŒuéKº‹îšBùCÐ+øKú{FÒ¯¡·Tk–z/™oú^oUÎö‡=Èjáw vžXà‚#Õ2‘7ôrÀ°ä(®rd—)Ç;}¯;âJùÚÜ&ÙDÙø"Ió(Käë Ó‰±©áSMÆòÛÌIj•Ü! ÏîmZ ›9œXÒíÒXSòcö’­E…ÌgY!ÇÈz‚œòâpM¸æP„2®&~ÿÊèÍG·o>Vrú1†º{YlGÔöþäpÞ–IÂùÿO¥W×ÊáR³³9¹›äŽ¶ÕN^ÝÎ0™s‰ådëÏ–=èŠ:Κrׇܕ0ÍèÏyAK“^¾ØÑÅCý¶­nk‹ÝËJ)ešÖ®'U9’oU^ænª8¿rÖ `º³VóÅ=bõ’õ|„³!ýþ endstream endobj 289 0 obj 595 endobj 296 0 obj <> stream xœ­UÁŠ1UñÔʪèA¼AØY–^S•t'¹©àÍ‹Ðǽ­xFÿAYd/ ü"ý(+I¥“§ÇdØ©¤ºòê½—êÒ' tüð÷ÙºÛti­|­Õó©{òLšÞt%µ?ìèNPÙ éÿ´îVצ·V¬š^w«Ów16”£1èÑ+CqáV\ ß}IŸ‡`R|/=`”Rx-ëÇÝϹè!…W8W“c ù¨ƒf ·s¡!ˆS9¼™ …CÎ>=J+65ÁaZ|ZŽ³^bËáUÞ6:ƒ½c¢+Ç©m°9>–òFµM"8]§lgT’ÃPÓc±à% ¡¥!¸%B{T>,¢üIFÏ„0Ç,Ô¦òA'ƒnË)d¥x3²sSa‡­ØnhLFÌ#Ö“–[T~õ{P‘ãPö°M|h‰GƒMåIHc«p ›0n£^rA¬®±öAjäÝ;œj†Š[×J¥K?^†ƒ]Ž!·ùË+Úm‰Ž‚°Vt¢mël @†´|ޣ¢œ'=H­ÙUÌ x·Ø =ø2&þyÿG¡z”=´ÖžO}œFM8䥇i)P§bÑÙ_åÛ´¤6CõVv-*V¼’a+…ÿñ6ô¡Ï»ð<`>´S÷GqG>î#_[Ü2–_²?åZ);·Ñ"Ñ<€3Àyâ|Îõx*|)N1-Nà‚ß[Ø?6K-ö~•÷•¯-¥&`iÚÆÙz5üÓI:²^ñ€‹Z€Ôù ˜€C¼{t.èÔát^ÚÚLh2M+ZêÐí›ã`\5²™_³pc« h½¨ÂŒÔH¤v©'‰t$ß÷Xÿkk÷oRös~9O‰ãì/Úc²G×̈X9?þIŽ"n|h [ÖlÅ pý{l ûY=æ¥Cž$®F/&õª‹ŸßÇƸendstream endobj 297 0 obj 719 endobj 302 0 obj <> stream xœµVÍkT1W/â«h«Ú š‚ÐM›É÷;*zó"ì±·Ša…õßÓ?ÎIfò’¼¾ÝjAºd2óûÍçn„º¡Ò‡¿¯×ÃfØÈgåëz->¬†Ë÷ÄêÛPTeúÇêñÂ<þ]­‡³{ç«ïƒ4\«¯ÃÙƒ$'CcŸ¨²°Ïwѵwb¯~$Ù$Ÿ(Ó¥Ž:‹ìµ%í³t¢h’ŸfÑ¡ ‡ZÑõ³b.K‡ôغ–é¹™™Òx>ùužàöUE_©bœ( W?‹Ãh;®’À>ÎׄvD×¥”%PT‘ñà«zòìj¨6L]ºE®åLãe ªèó—µe@VÒFC^ç³c ÿšÕBð¾ Ž*±šÈÙ¹±ƒïgäÆ»’Á%ö6+cz”½'|<ú–džÔ¸Â\l‹{ K¸ )oêSDé Ö ŽÇ"ÿR9ªã¯£iýÐå/¾4 +{Áüš¢4»‚®é^t”éåçlê”,A%ŸÛI…¾ÆY"â©=z…áv¥×‘Ù®b`4 ºç,—N »;ÑlíÄÚZo¨1­Ãn2Ü»¿ó™×˜jòð17«à'SØ498*uáz<6.z‡KÍ F“@cG…FÄÊÇ^A$Ù¨kâCIš,ï•Â¿hîRÕ™2:,Ü—©ºzîÌ,´Œj GO0W3÷”à =aËÊÏ9ÜVÁƒ…ˆ¤ÍÖ”7æ8Éû\EVHSrr#g了™­CÞH¥È¥wÛÜV8xãÿ‹ôØFztõ©ÄäCèçîÍ*Ón%:SºÓîg³zUhøYVË^Å·…íÍ 4ä°}R„|!^Š'üÒ4žÔÔw#ag$TC‚W2ÏÓ²’-x8õœjx ºæÇ ný—¼÷ŒévhYÖe¹® ÍìÝöƒ·ŸgÏ\¯\™DG¥^´ ³E ý¢ ÕI‚Î)J,mmÑ:ˆ'èúo¡ïúÝŠÍЮÑ“ÓèÆU]é~æD¿Œ ‹32¡Óò€4.“øi%¾ éóŠ¶i!endstream endobj 303 0 obj 795 endobj 306 0 obj <> stream xœ½W1o1 †Â€®¨Z¡R‚„ÔWàJâ$w9[¤7²1 ©üÄ ÿ„?PZøE8±s—w÷^ßPuxuâ8±ýù³ïDÈ%¤ÿãߣãâ¤8*¬ÅŸ£cñj^<{)”˜¿/¢jéÿ1U}`…mœ˜³+ûóE©…²µ˜¿+fk^öfš nxm³Íý½Bã¹°þöéU2ˆ7ÉŠ`x߯h)@ZZøéïÒipD~^k iÏü :È·‚hQVÝ+uküN4¤èRÓ$W—þ¸6¹9ENoµ÷«*¾Ûi Hú›t} ¡Ó¾RlŒÚÐÂó°ë„#c"FÜöéQ£7Ë(¶ÊŠ”osX8IœZ’® éÞôL@”X0†”}ݤw×*‹2HE¨êtQr ª(À: 0Ê.I8*Tt×ãpÀƒ´¬ ]ø ,5ØÄÓè-äë=¯–¥hêL·$åuVÖªIáÅaÝåÝJwQÅk´Í‚VféÏ×4R¤Ð òS‚­†t“6Ÿ H³ª(9@íËLmÛó‡˜8êïíaV×Ô†\|¹Ïmè3dk§%©r§Ke†Ò1’ʨ=XOÞO›¢„îþÝ–HCAùE¤D»g΃éF4…sF˜é¤w•£ìí ³‘7˜M¾ú¯_ÀL—œÌG|;¾½R²ÎJ@5tæKt–žô- ìwŽ:ñkd!pªc!”ùúS6Åè`ßëÜwãÉÁy+³HjR_Mîk…”g;êÁ§”:w0mµ”‰ë Ð!Z¸Æ™³õTžk'nW+bEÄVl=$n³)î{-|sb‰ »Ç¶ŒÍ+£N3Áî¶gÓ6Ó»CGëõ Ýû„TˆìyÇ%jAv¯ò#l•0¯AÄ!õ°Ï?ÃZ-•pcPºš*i岺d¤ð-åÐïžßÑYtb÷É);ZÑiŽ"»LeÇÜ 5IkÂ6¼08`J›t`ˆ¯Æ|7¬Ú¥b‡7¢²Ì0ª ‰¢à¤]+øDÈÓ)— F%ÔO™—ù$ë>c¨Ǹ¾¨áôÌ­ö3‰déŸä¯Ú/œ#X=Ÿ*éQø ‘& ªthC„sý^çwªñq¡ù«†ÂìÚÁ&’ŠâYkˆ> stream xœ½VKn1Ý÷)¼KX8¸üiÛKØAH¢¹AP@&Y@JX!!6p ×Èø߆²«Üm÷|¢°@YLÊvW½zU~å…P; TúãßÃy·èòZù9œ‹Û³îæ-bvÔ•£2ýc‚Ý1«(fónûÞÙq7gºíÝd)6î'C !›{ÉtZHP6/¼N ÒYaÀä…ý¼`-‚èóÂ×ìMòð0™ÖéÍ¿Pù‹^˜„m8ï„ÑÙ|•÷µ€à³}Bገa<ŽŸK¶WãóøñÝ{ Õ‘\PÞlQHŠ¶”Ç·´`Rê„d^0’Ç5mOhÓ°aüÚ[! ¥õ–p#³¦Ý¡íë}üÀXÂM5ÂÄ49|Aá€izɼhª4æD u$po˜RɱJFŠÑsÐm °!o…8 Ú@ªª%æÌùçÈ8/˾ÖvÜ—®B:°´ö½Àë[Ó&2æi÷]ÏÍp€L8ç}^×ó‚oˆ±ª*¾Ñ€fÝ5€”kðaèc¢ælÉò®¥$ìHª8Ÿ~R×ä4š±ßS?sC_ðÝ6Ð×WÇ ?Ú”>eN”Ρ>b(<ª•¯¿ÕÃÂeË›±º,Jj«ô?°ù~5_ÂÀ‹Ö÷néwßT‚û{¯|ÌöõZFêˆíµkï0‹Ù£¡ãú2/¡v-ê*ã,WÆŽ±’X°ÎE0…ÒP].pBDSą̃»qxJÈYt×äÅ ;ôáè(·|¸eNW <šEøöÉ7¬Òªóbšz—²ù9Ðk&8´jqTÓ!ãÐëçØXžr+ùîíJfk5÷xZ·¼óñƒâj6KV¥A5ŸèÍc7Îcœiþ (}EVyLz äX”qS`'€÷ix±ÄÚx‰~ÓЬägumOÙU%Ø}¡R"š*®\ä€ïJ¨t¿)`|ØÀizãL{£B@½“aî7óê-rÝ[‰¾žƒ.—¢<'íE'û× 6G~–_K–þnæÙ`Ò»°~MüJ@ÊÀÕ4‡am(µ¡NI¯Œíù‘ôtN‡ÊÈZU¸tUˆ×󶻫êô_]©)#AùB®±‰9Ý?%´oøvk§+’¯Á¶Eí§µè§µ€«jQ©Dz‡MÚJ·ó¦æ5*‹$ã’ã€[œ_ȘÌ;3±ß¥¿¿°Rå.endstream endobj 317 0 obj 901 endobj 327 0 obj <> stream xœÍV½n1î÷)Ü%)6ØcïÚ[‚„D„D÷AEDâ’B (¨Q^"y@äi°=ãõÌÞÞE (ÅÅk{~¾ùæ/•Þ5J§?ú=n¶îleЬãÙXãÖfZˆSðõŒÀ‰:†ö?¥60CZx:"ìd²˜ÜZsjÀ\çd{å6–:NiÞ™ÓX.‚ˆžÞçí®‹9£«ß’7?dØ¿rœÁ»ŒàÕ­K,`¤/Ø ÃsË6®íÁ"âWòÈ cY?£GS³¶ÐçàöReSÚÔ¹Q@@ï]z!@ Cå–©v.u€˜g*·ÒU¢Ð—b×’¡ï+œÍ7;QÆa}+¥` ûg,Dèl”Dodƒÿ‡"Ùù±¥þ‘@:á CyWÆŒ5j„q)™½Ì°)j©"™ÌÐœdz_I‘T¤äxÂWjS$´õvjÏH|A 8^ÌÙ:€Eá©”¸ÐÐë\èÔoB”`ì¸Wn l@%ø)sV¦6Q,â[‚ý›‰Âú:±%Üi¢8‚ü`ô ëKPI9Î6ySì¤oùبýCÜ1C)O®–FV1˜È­°%?-Þ¨çbs†0iWR§Èb÷oHXè2’ŸXSêCÍ?OÛLBÇ&Ìm'ÎJ vü–ôNÑ î+Þ'º]H‡5|1¦yg§¾Šú)”ºª>ß ÉÍ0‘û¡Âåé0§ÇÓçr”g®+S³y?óöÎân׊U¹†à©Æиxôßi"oÕúÞ;-ÄŸÌäž ’gÓB1žõ}ÔǪnŒ7I~ÐäVþfÕöQZ>\¨ý&ýýK0ëÊendstream endobj 328 0 obj 889 endobj 332 0 obj <> stream xœUÍŠ1¾÷SäæzÈšÊO'9*xœu¥ß`eW™UPTô   ">ÂîkxðîE}“TU'™•9ôTºRõý¤Ò+¡vA¨ü£çÁrX +eKqe.] ¦ÃSeþc,ìŽÂ«(¦å°sýât<€R[1ÝvîåX P“ê´5Or ­Z™²p”RìJô·‚­·K¶F—p+鈵r²é÷ªº×yãE©åmùÛ iL×Lk,ðh· c‰WÜl,á‚ÂàëV™$ÑÆÖ^RámÇZFdv7øÄûâ„eUØ"nY•ÉýÇê€1ôÄ ¶ÄÈ­Ç̬ÊÈ-%sÓ «™2)Hµ‘ˆIB`ú>Ö†Þ‘P5Üð Ù|gdFÅ¡{ò¤ð͇îpHo:A”kC>’ DIj5âC?ek×·këzFIMfuƒˆH»Î¡ÑGZ;#;+ÀÇ£_ wç“ÓIˆ!üù$¨mLùœšc?žŠg¥½Ÿáoo¾ÅÓÙ`ª8 ï×:, b©»§ù„®3X£ƒQVwh|Xw¬âÂlÕÖC¢ç©¹¿6ã{\ŽÍ;ûù£TH+„ñdû(‘· VG‡þ²;ì·rÖ¾s ][ s†mÔ:ìð°Ç6Ÿš#2NÅÿgQg‘HéüÁð9íSNùºÀŠÏËBL|7e|µÐJû·_‘»€çïcIN–Qç9NRÐý÷’^£¯ñ%µ}š£Ñ kä»’ÒùƒÞ:ïšZ…%ø\ ¸™å+*‡çKï#áI¦dDý‹^@}Þ ÊýÔ~;¾Q@—ßÛÞ¼7üe¦kâí]Y8ê†4¸¤Dƒ5.tw_ËáÕIìù÷:ñäNendstream endobj 333 0 obj 677 endobj 339 0 obj <> stream xœµWËjTAÕøÌUb‚.¢"¶ $Anìw÷]*¸²f™]Ä…!þÿå·ø-VwUßîêÌCˆÌb¦_ÕU§N®¹òX ™>ô}v>\ Bå¹òuv.>®†÷„«oCÙ:¦Ö‡c'œÇQ¬Î‡Cu´ú>ŒF(gÅêëpø4ÁR>.Ë&äñ›4–BÜ}ú£lÏÃG´[[\¾‹»rË»uFOyâIš€ñXöÿÄójBsÏȼÅå-²æóh?/Z¡#Z˜ÆJ4½‹{ƒjöBTÓT-%ôp¸ƒCºuªˆˆÜš ‹gá–“tçAZˆyë|„ kcÌs¯óœÒBøwÈ´ã”e©Ñ6.«ÒÔ¼‚-_á¸ä›–¦{UG‰È)aX’eͱœ Q2ê;v9¹èÖh`B‘í£l&´ZÈ¡&Ç)ÄHÛß!ÂBk×F¦´aü'ܾGΓ·”iY£†£-½èÅQØÇ“Áµ¼ŸÝ|™iY F`+6¹2íÞ&—tdxºé¿á™ˆàâ:m åDÅÍŠîH¦ Ü€L춎ÐÊ)î½këpÔÌ[ª ŒWN·¤ZÜô¡UÜcÎìÈPPÈO›à-TßÅZ—5‹À-c84•Ü,^Ó:, 4EêžSì$us±DšUîEvs£uÀ=Û¥ TPGk4àêúò‘F’¯¯r] ¿AwòŽÌáŠdN–ˆŸ»˜Ž TÀݧ‡”?m›ô8NW)¢Y'DE˜‰ë‚@¡*[HÇäâi )æU\'€-ß1ŒäH,1ù°Œ‘šÅ4µWAÈ.—6 K«×Ñ ¾*lÜ÷ˆé¦Š-´£“$j×á_U‘·g¹£×k‡¿©ó ÐtP´ù íLÊM/v‹°$S˜È{t¶gTãs–)˜L§ŠxÍU×wxMµd©×k’Ùµ`ö"ucõWm«…§¼¼Ä–È h"mKEMÕ-r£Ý¦‘¬G! F×$„ܺmçÖmý¶‘”ìré¢ôÌ3óÆ®Á´é‚#Kn!tí‚y—ÒvÁiÕ3 /õï¬Y3ä}ó6 +/½‡¬>RAx’@‡ùú+?ôO{Ïž’<¨ÍûgÒ¹"4kðÿ!›ú&dsnäJîaÙL¾mA¦¹'ºOŒ³ËƇ> stream xœVËnÕ@ ]¦¨@âÑFBê­ Åö<’Ù;6HYv׊ÒEº|_Ë<<ÉÌp“ªU·Nfìãcû8À+ ò{³ïÝ(>Ë?7{ø:uŸ¾Áô³ËGûðFÖ©«¦}·{{9ýêzL ¦Ûn÷1Ú ˆÇh_ÿˆaúÞíÎ./:ÿJÙøêq>ª†h¿ ¶GàL4_‹îÞ†»ñ4[Jž/Ãÿ€ãƒ'1¤·çÁ`+ù¾þ#ÁÆûY¼ .$Ò ‹³ÆU0K—¬“Œ2¥bb™½ÜJ˜/Žµ‰B%ÏÓaâd¾Ãf±(RîÝ\,^N£_%åyik?>Œ6Kv zÉî4ƒ ±~­ëü -$‡‚Ò9Ð\V@€Íõ¡QUÌõT¹fmK®zNæûøzð°zC:]Y:3åòrŽàŠ¡}¨¬+–èr«¾ÉáQ•ì÷â:׊\Íb/™Ÿ‰7n¿ÊHœ«z]Ùǽ4~ìdOƒR®"ÝnúMÅ9q™£LX¶lå×Ô~‘Z®ÀÇp?úTCÞ‹¾qɪgãݧècìqd‹Úö~šiqØ%± VÅP˜¹3fNi(„‘b˼PóÖnCe3®]÷84W´ÙZ]X»ZŠj$X¡ÞfTº&{¢Š>?k…¡Ò£ÌëêÔÎCPr\-àÿ³í|> stream xœ½XÍnE¾ïSôÍá0NÿÍôô$nÆ`kß ÈD!–³Žø‰@€@ Q¡"Ê-WÞ€sœ£`!ޅéªÞÙãHQNÏt×ÏW_}Õ³+¥wÒùþ½v¼X-VÊ”gôçÚ±zo¹¸ú®2jy´ ­]þúÝQ cØjy¼¸òÁ;Ë Ô¨ÕòãÅ•ò²³*Ʋ¼‘—Veñ%¾3z(ëÛy­•5¦,ïÀÞ6_‡—F÷uÙÙTgGxžûô —ælYž‚9ë›rÜ÷ÊjW|’¤5ý‚œiîL9Øû!X²Q×4òf+Ïšz¶Ê`V?[Á+ç ;åÖÉ™µZÀ`Xà 3oWä ÜÇåêÙ.ab±Ãùµ‰pü¬Fuƒ%ªF8¨@To·!Ò¶åa!˯(j(â­^qåòSùÿ,ï'Ì¡zNe\{Z‚lƒ,’d¢ÕÌ_âÖr/ÛÚ¦Œ@áï)ÆFl0š%æ; “ó¼vžËz=§Ýò:“,?“»_BZ Ü~„0Û‚†º¡ ú¦ÞuC`”pÁŽÁD˜úfù™ÑÎFü"¯c_ :IPiå0ø—ä;Ô5µó™e* êÄ-ì]ŽZrŠ>Og™f¿%ëDŸÎEÜr“,bÙNä‘y}Zk@í™Üÿ \Œé$ð}yI÷&¾Å‹(J•õ•Q5¹™ÎiZ0ã*óÜþŽ›T–(ûë^¤:s„z wY[¡$oIç“çC£ò~ tk*ï…ÊûJUÞnUy·eB$7ñSzÛ(½}¥ï¥Ò­Ò³±¢Æ‚am‘„X‹7”J_Ï•–èIúª“ÀPL¸DJ|†N¨ìÅKæÇ^n¿ÂK®)¥È~[ðrΣ~m €ø/Š—Þ*ûñ>6y‡Cêkhâ þ Q1û¹l¼BLî€\¹ŒfS:Í‹è.«NnÂÖNð­"zÑ*Dóº†uq± ^Ág”*-nMy³òx®<$$ˆ¤½ì H^ì “Ðó¿À€Œä_õ¬(@@ÕT*ü}¨Tùo%¦e¬ ¥qH§Ði,Æ=sý‘JUVŸùð‰†S %ÖùàxÓÎh"ÁôB븛0Ê“(‡“(Yvc}µ(õL”ÆI” àwºmÙ&®šõ®‡ú|]F’caìôpâñHªÆŠi­ôÒ MvÌ4óTõÏ‘QاÀ8GrbÕô€ÊÚ ýú­°qb¯èËáT |6Ò}wyÝo®_6¾¡î3¤ëEâuu`ºß T…÷œàwÿWIyï°Sn5Îå‘æc£¹¯ŸmÝüê…gät ÀÿušIïl¨&}/%>#…f¿^Lê¦ðL o-"wI¼ùfa_X¥Ž{9ðŒÛ¶ãÑä_ÞÖxdßòz’‘C HYŽ›‡Ô¬•¬Ž“Î4m/†oûÜØ.ÊÆîë(Éâé'å½IË/¼)WÓŒ¤AÎ ¶d3è¾lZIðîo|‡ç'> stream xœUÍn1† l#h)J$P¡M={m£J¤Þ¸ åØ[¤"…WêƒÁ£`{ÆY;íö€rØÌÎÿÌ÷Ín@­TúÉóòªÛtÀü®<.¯à˺;ý ë]1íÓò~À*ë«nÑ/×?»hôµ[¬–']¯=è!ª¾w‹gI¥- Æ,ï%™ ²ô2I ë.~'±'@O1r¬™¨µUYöFåGkŒ™²4ωA£oc{Î|À¡Cî—ÀÚeù+IćIô¹½'©=Zq’ÇIc 'yžã¸˜²7*pÑoò»]¸É{¥GËÁ/~q’ë@z l}Ä• æ¼(ÎÚWÎlüJ"›Åë$:^Ëyª;väC;¹Ð„é9Î~ÎSÕcWh«a¦*MS–±S;®>_äd‡¬Že<Ó‹evOœý)‡³~l2… uíH¹ÍÃØfTÑÐà‰]ßÊ°d¥ Zkg[ #\ œAŒ#9æi:Ð$_äq:nB1öîÌ.%p†!HA‹wãàGBˆ­š4½ÁC–Þ1ŒuäºuÄcÃM=’²H«Ū˜võR Õ©|%UÛœ`\Ñ›n ]–Cêÿo‚uX¾sÙ*‘ŸÚêMâ:×hº N³²S­Ñ'jNv*7‘ {¤ó5|ëÒï!ÅTendstream endobj 353 0 obj 711 endobj 358 0 obj <> stream xœµWKo1 ¦¨P@¢…AªÔHç.$n\öØ[¤EZþGþ"y83q:;ÚBÑv‡c¶?{7LœéƒßWëa3läµúuµfWÃÅlõm¨Gyú¡­;7L{wîØj=œÞ?[}¸bR±Õ×áô ‰Q-â#½Ëâå$«¨+I{xUI™å'xØÍ]½WÄróUQ£¤Íâã²'}–Q­m,R ”ÉâT+‹¦ËŸE6aÚå*ºcpÿ,¯XçWA—Å—y-0 剷ø" ÕM˜ìÌê4Û÷³, ƒ óÂôñ@¼ÝÑÙ Á‚oÑ—¶ÊÐWá·@˜Ôñ¨˜áb1T§ÙoÛ)Š+îV/Lªó’Ø,…š«Ñ‚Câˆ)Jô8À4z1:¶ŸŽð)(œ`HÀ+ÜO«zÓ:Â-ßû…œ¬¦ì·øν¦Wânõ :¼€àUÓíñ2zR M|““¶?œÜ·M˜¹ÔŽq0GGL1‡$¤S§”HÒ‰u\ŸDsóáÆÎÐ 8¡¡ý"²bŠIÜU0WîM¶x’- ›ìðÑŽÏùîÉàuþý+þLéüB"xX*œ+MÙ··ð'ÖÙ^MåYç*ÓA »v|u\ ƒ=Ÿå Jã;òG^÷k×ÑÀúÖ<´˜½=Ó\•Ì‡©$ òD¯Fl«Ï×8Lw4¢HÉpŒEMZ­;¯hÒ‚ìKÄ Ìó©FŠü ÷ëù®¶[¬å?ÄÚµÁO!ë©cIç2¾)Ûkí ÖZêijÁvCˆK0-»& ¡,÷ ˜N¹"Êm£\Cd¢²ð.ŸÎƒAËË€AG¡¦”SFØYûzÓm§*™ó:f:¯¤øY_é&ÂA0ÓFs<¶Žï}CŠV….îK£×Ü{º,I²ã(\K6d¤¸ÿýœÚýͪ”qŒ©"˜ræ ıÜ=IÒ§û2¤ÏaëNendstream endobj 359 0 obj 876 endobj 362 0 obj <> stream xœVËjAÕ *£¨Á,|,lAðF褫_ÓãFݹî2»ˆ !B\»Ñ…¿áG(þŠ¿buWõk2÷$‹›š©îª:uêÔœ uBÅ?þ=>N‡SéYþ9>/ÖÃásbýnÈ®2þcýx …³V¬O†Õ¥ýõûA h¾VG¢mÐ7Z×è%L¶šÒ ó”ìò•|ö:¿ɾŧƒKæ 6Çq!R>«©g 8s\¥k\ ˜Ý|5Ú ÌÔ…(‹Û9Iè“4!ÙÉ[³Y¼)­;ì¦ê,½sBZm|zö€’ÁÔ•i³~¿€h‚0ÔR”àBÎVñâÎ|$ÛMmÖÒƒ£ýthUñŽ{Ÿ!3&t­ó]™0MmVÁÔªñ¥ò]"#5ãg©ˆlm=~=¬v÷ãAíéÖ=ö”3~ðE….-?ÐæVÌ^sŠ BK.ÕÂè ¸G)¬Õ^H£ yüJÏ\@ôù …»³èº.ݵ¢]f‘‡ŠAD·ë¤öü^‡nžc0_wÚ Yûa•ÐN«} Ó4µ'b ü9®:c"a¡ƒ0š*¸™ˆ¶ë;C=Sÿ•vºÑìŠàÄ(ÏTã"^tµ­Cñ4MŒÉÓHu8lEØk6«¡W37Ó ­"jª\–˜(:þ,>À<%“13zÄQ nÆhîç•ƒÕ Z7Ùƒ˜æêÐõ +É÷ÛuíÝ躌8©±ÇMw†V ŒœXêRŒ(1é©òF|MäÙXÛaæÊŸ\³ék½¥Yä•ñ%yuBs¬y‘…[ÛÔzÎb=š.1ÎLôÊwVQÁöÚ‘WÏÒ=O‚¢V­¨ÑP8½‰Z(–ֱϱ¼LaxÁ-䯄»=yòšò!P6•WÕ3®dÝÏmøÇT›Óé囂<Ê:Fc«+芗 Á„¾žQì™áÕ¬•›÷RuÓ{›qIÁ—Ô=Olfo¸ ßK¶û¸jç&$§a™­âu#mÐÜÌýY&Ë€3³ŸTmÒ6l o[¼ÃÙ†˜º¬Œ:]ª é|Í>–§GUÝ¥+Äg†aRÛÆÄVÔM‘sé€4Hv #/é¦@zð9>ˆËGö7Ž,BÍ®ß3]ˆë_’ªè¸èþOt•+ûð÷†RÿJðâb°££+éFæ_²^­Å›!þý÷`~ endstream endobj 363 0 obj 890 endobj 366 0 obj <> stream xœuR»JCAE;W‰‚‚ÍX妸É>²ÙÝRÁN á–é")ı¶D;ñ#üÀ°ó[œ™å&p‹½ggΙÝ9è¾?9'35Ws0+Çd§œ€fªJiœÖýA'hfªºè5×Êš+U=f0u®ªï^Wi°ÆRæ-g?‚Oz uJ„ï3®½g8ð’ê!¡géFyÞPµÃbfû%l†Xà)0%zÄBÿ%ýzÔÂÚF pþ ±[œgEÌgOè5#ëÈä;šÌB4Ïý`ÕRøæB€Ú:ϱ-‘nãSGÞÒ÷óÔ ™xã»Ò*;ìUÜ Å#o™‹7¶];Ëé]2°Ì~qdS8©Ëƒåöå.dû;E‡×­h‘‰ˆW–UÇч˜³2heÒi¶»)þÒ’û mn`ÇcŽåv]\U}X§¶{-¿Œ?~jÉa¿.‰ülFg \ªüýü¹Íendstream endobj 367 0 obj 381 endobj 370 0 obj <> stream xœÕV?kTA'6ÂSÔ H¢Í r¼dgÿ½]¬Ò¥®´‹Xbm«ÁB 6’Z°µT ý~ ý$ÎîÎÞ›=ï]LŠ¤¸Ì›ÙÙùó›ßì[ dü£ß½ýæ 9¾•Ÿ½}qÒlß &›bÚÆŒ2[VtªÛÒb²ßŒ/nLž4­ZI1yÔŒ>´hm?&µÓN(— >¥/DðIÞ$ |å [¯Vy—äëä²úrVK¡ŒÉ§Çñ‹êËÜIr·šìQ­(Üd²x!¨$ ³t¤Nö¢! K¥ ’ʼn¶Ž›‚¡=+9{H®µW ’ć>ÈX°¬¾Aj㸶…\Kå0øZ­+ß`%ÏQ¹nN3n•ftž‡æÙνW ò»Z×y™2ÒÀêƒê « [ }ÆOË'“ÞXÑVÆÛê*ÍQ]ÇQƒ%Í^M¢Eúà[Ýl­¥ ~¤ @´.weDWú!©EcðùÃÏ”0f@mÀ’ª@)ÍIÑ›™è%o¹·ÕDA•wˆTèÒ®•¬ìL]USu8ßy‡N·ñ¡B¿VÓTn>~°ÿ`÷çÚANý=BªäÝOðqŠ]+Œ4K‹a8€#;fœ€KC°6–³w`ëôÄåÕ;4 ï(NÂôQ¹ ²··T\ȇË8gÎ{Ãàˆ€F <Ì̯…¿D Gx–R>Onðƒ¦Ù×ø¡sÉö[¢{å³é‹zWË–MäSvNP6·)wz&,ÑáNÏ.M×w³¡è´ÔôûÛ@‘Æä}ñMõ¹›Ó¶‚dO²ÁN¨#'æ¸*LQ³¥€u3áñ§(v¥ã©*z¸”EHM˜·»m½»YÅ΄ÝAŽÍÎÊW#½ÙŽËà'éur¬SˆGùÅ¢¥åAøÿNdÄèÑКž¾ÛdÍC”v&âAÿ~}¶èúendstream endobj 371 0 obj 909 endobj 376 0 obj <> stream xœÍX=oE&."q‰B  4)Èhý¸»¥A !d ¤·t”É‘LMKR€UøˆßU((ùÀÿ`vgövö|ï½NPraÏÍ~ÌÇóÌÌúL™#P&ýðï{§ÝYw¦ +¿îª6ÝݨÍý®,ÕéßÑW= GNmN»ÃËw6_vFÙàÕæ‹îðuÇ,ÝH’v bÌòÉR›,ÝL‚íCßäÅ>dq´\¯d­U.öYþ4É ¦Õ'_ñî‘Ô×i7]{‰un ³~$¥#“—$~O&‚¡ƒ¾e#m–žr ÷’ä€v>J"\yœt]HöÑÒ¯ó%éƒ3õ¤š1Ö{v\ †.zšDÍ{-ï}¼`î]¯t0»_ò·%—KxI×)ýƒ‚ÐrrÈ°äÈkY (ƒ„Zx®±I=]÷­ë“³ŽàõvþW×gsŒ“æàöy釾j]̱Úϱ×WR Ì.¿ýÌoSý6uùòŒ”o•ÜÏ¢"I“ò¤ –”ûdI@9Ö›5Þ ´àäN¾Ê©¾á¾5VF€¬¾ÅG3÷dY¸UÐëej4cûiúõ’yaÎî•LÃjÑñ¢è`¥€¸¤¾Z@ IVD`÷Îþ+à–ºw›£‡Ê‹”^ÓšïdÆ¢Ì}JY?æ›Æ)”~£zŽììÐ@ÖÁÜ‘~[ÒêßÊvËÖýɉ‰~ÎІ@‚´ÆZÍCË€/ÔYtšŠQ`Y `½Œ=6¬´#fFÉøŒ7Ðïrc@¸!•×aDô1Ñ–Ûç_ùÎTá@`#LÀºÁ36oÙ 2È!¾œ¢bÝRöž»¨p4_xQ1mbž©Ã‡•†ÀS“tœ‘tTÜÅŠéÀ‘ÚçˆówMF¼ØírÚ bRJ¥™Q\œ6Q<´?W“ž)¥Š,SÜ‚˜9V9€™ã˜ÓTqÖqì¤ëîÂ8-Žcc» ƾ…±µÿQo4qŸ¿8¯ÁØÉj‡%¦À8W;”5ÏÓ¹©â°©É¶_óz¥PéÛûùü±Ô„¶³Nñä«X®¹RáD_så|÷UN(Óä'2e:úç${4¼Ú‚(§x'ÕÁ’w å·ïBoñ²èjØ*´5‘¾½"Aw©” ·ÒªÑc+ÔS‰¿RjŠ³¢Ä§1„9ša–‚sœ÷ÐÉ öË+ª½èÝ|ò€ Ò‘G€Wi=cjªnNV·:‚üÍøo ??‚pâv·5dwhBзÃA3™¤9{{uhh[zËä¹y -Ü…¼Ö¨’–…ZX_œ"t£h ˆÓ8k¨ÐzìÆZ¶ª¸LP—I©˜Æ‘þ¢¥x^y,ö;í"ÿãá3fÊ@;ò?°iŽñòë<½°Ï½uéÃ#Ök>ù1Œ´>7üŽyPïý,£~}† > stream xœÍW;‹eEFQѳ¢»¬Èjb/;ƒœÙ®~wæÑ@öc´²0ÂoêÅÀß ¹þ 1ñ·XÝUý:÷Ü;³×Ed‚¹Õêz}_Õ9ò„LüÿîÙt> ÈkåßÝ3ñæfºý†±¹7•£súat81ÂE}âÅæl:zåxóñ4Gá¬Ø|4=“D)¼ÏÒËy¼PòÂ{iŒð*‹?$Q‹9š,~›k¡®GÛ€V%ñGÞžé©ox·]•BËÅ/ò;_yw:úüøÖdúF{÷³\Ð@w¤ïòÙ?ð¬DscÞùŒ´‚4M+ €Ìÿ‹Ü3h¡Ë ÷Ø=°tÿ:ûÇ<Ë÷A“%7Ë}Í÷Kx‚¹¼ÿrô?ê¿ïýr¿ÿú"ÿÃà?u£¸i÷qÖîH|.o+‹Ï‘¶çÓB’ çùuÁÊÙzúiQ|ÿ8(2þ…$½Ä³·&“¾ˆ¿’K\‚ü†lùIÑpkÙ¼A»AÎ)©ÛáYyô†NØ?ÀÆ`ÛsÉFÙlD%Æõ»)ÂI¼RáÆm=V—%eW9\š˜ bp’AXJï ·\¤gft†ržów•Ì¡\?Vl•jÍ•b«V±)—‚}ú æÐ^©‰%]×8-6ôwG§ ½óR9Ú…;٠؇ùF<ºù(.ñ(å# ÔŸ ¶Ã£GŒ‰¯æËk6‘Ÿÿ=¯9%”!/ŸN ¦–ÑëÅKòä òR³Æ'‹E&2ÄcðT$l¢á¢™ÙÂk4­:KáünuKt2¾/.?<ËâuM¯§Àà&[Ä$Ti%¸þ&øŽtôPº#ákm‡]èºcºwx€V1QìˆD)E†—q#Š¸bÔ.UÑ.iØ/xAþ×4 CFâX#œ‚cc±|é´¤÷‘èf¤XM¢ªÔÉVyœŸHE0Ò•¹“ñ(AZˆ‹&cv·›@\ÛnMÏ}Gÿ¶ è%Ÿ`Òf94B óIØ™¼,&1>W"ÃyP*/4þŦa7æ²ökIZ½d¼¾äÓdòOLtôûª™T}Eg¹TÊ®ŠÐk*Ù®”­ÊŽM“¬U¹q)êÿ3N1¤üÂ#CIÚ•Qi’qdØ•.@‰Z¢Ä-Pb.’­Q 'NB÷ÈCKÃÈÑ©ãÒÈ5.QØÖÆ¥dE¡Ì4\ø ?Þüš·í‰Á¤ßh…âœ=Uj€£¼ÿJ+•5µwÆ-¿Bm ˆ¬ð­3Æ@ h†‰}3Ðu Ú‚B.ìCa@Ù– ]›P+Š®íO-¯Í" hWjõËó`ðôf*÷y½ò©¦î­©iÁ=º ¸:äSÍt£Tkø¥:¬¢­Žeº{?öÝ„ˆñI#…çÆy§èà"ù ɉ©ÑÐÑÐööKi&Tå¿æ,º˜OÞÉ.%-tö7.=¶æ´‘ô7wÛÈ2õr·Å:Èâ[\ÚîþdNâ¾ Á¢û¸¾JݯL²²ŒŸó@Ák&—žPö|¤¯ »r'ü|Y¤õ¹e‹4díOeRÒÐ29{D§rÜ“nœ9úï$éíxJÿ¼gendstream endobj 384 0 obj 1201 endobj 387 0 obj <> stream xœ•UMÔ0 …Ÿ«åH€9±+Ènì$mr‰¤÷¶ˆÒ Íþþ9NìL:¥-ª4­c?Çñ{ÎlÁž#ØüèûjÓm»-`Y«¯« |»‹O€0þìj¨ÉžBþ ìÙt§ÏÆ_q`"Œ?ºÓãlr–Þó™˜9¶: ÷Å|¡PL‚=Ê6²i‹ùµ¸ˆúb_þ¸m`Þ(H®7%xÀÆÊÚ[I@ ö8ô ù•`ŠàHªyšøIŸkµšìH÷÷Ósb¦ÎšÓA*ÆmMã,®…þ“­`ŸHƒÆo9ð=;¨šÃ¥â9f÷ÔIúËkÝO3.mÀm `ÈÇiÛ ‡F Ò¦óÊYèWó±ú¸F;q¿7éÙ«ÈR±O*ÚÎб¡ùÐέòÇôh.¨­‹ÿC¶©Ú¸Vxr«äs¡a_Ç‘’Wµ+íëgyEV¤»Ö8LkãRf-í•p!øU ¦á†ƒ“3ùƒelœr*/à» Þ×*Fl­2¸wC£Éô|A˜¬[”+îê‹j"É,*¿Tîî4Ö¤6­Pë ¤=A©©U°ô½úÏJ8bÃAFúÆ—¥fi£ñ|()óuåDÐtÊ=Oy?ÌÚ¦³xk׶›\=ùï÷úÉ×Ç*ß<5äE¥V* %ï½iËîë1Q«Û«óá®@A¾Tâ”æÝè ³k64ð¿V1>”i‡DsÙ-é»MÎä®5‘Käy )EEñ'[_FøÞåç/96€ªendstream endobj 388 0 obj 573 endobj 391 0 obj <> stream xœEÍA 1 PpDô9.f¦I[­K ténÄ…0B=ŽGñ0žE’Î Y¤/?¤®c8­©#*`›ÍmqÊÔÁÈwšW[}ÈÞu !ø."Ô|¶ùAùFÍFé ñ`\T²«\U:ÃZá1m^_ÊÖƒ“¯ƒgÍ[6.§XÂîJÓ`üZ, âS´Y_KÉôV3.¤õ 73endstream endobj 392 0 obj 159 endobj 5 0 obj <> /Contents 6 0 R >> endobj 42 0 obj <> /Contents 43 0 R >> endobj 56 0 obj <> /Contents 57 0 R >> endobj 68 0 obj <> /Contents 69 0 R >> endobj 75 0 obj <> /Contents 76 0 R >> endobj 86 0 obj <> /Contents 87 0 R >> endobj 105 0 obj <> /Contents 106 0 R >> endobj 111 0 obj <> /Contents 112 0 R >> endobj 171 0 obj <> /Contents 172 0 R >> endobj 199 0 obj <> /Contents 200 0 R >> endobj 211 0 obj <> /Contents 212 0 R >> endobj 219 0 obj <> /Contents 220 0 R >> endobj 226 0 obj <> /Contents 227 0 R >> endobj 230 0 obj <> /Contents 231 0 R >> endobj 240 0 obj <> /Contents 241 0 R >> endobj 255 0 obj <> /Contents 256 0 R >> endobj 261 0 obj <> /Contents 262 0 R >> endobj 265 0 obj <> /Contents 266 0 R >> endobj 269 0 obj <> /Contents 270 0 R >> endobj 275 0 obj <> /Contents 276 0 R >> endobj 287 0 obj <> /Contents 288 0 R >> endobj 295 0 obj <> /Contents 296 0 R >> endobj 301 0 obj <> /Contents 302 0 R >> endobj 305 0 obj <> /Contents 306 0 R >> endobj 315 0 obj <> /Contents 316 0 R >> endobj 326 0 obj <> /Contents 327 0 R >> endobj 331 0 obj <> /Contents 332 0 R >> endobj 338 0 obj <> /Contents 339 0 R >> endobj 343 0 obj <> /Contents 344 0 R >> endobj 347 0 obj <> /Contents 348 0 R >> endobj 351 0 obj <> /Contents 352 0 R >> endobj 357 0 obj <> /Contents 358 0 R >> endobj 361 0 obj <> /Contents 362 0 R >> endobj 365 0 obj <> /Contents 366 0 R >> endobj 369 0 obj <> /Contents 370 0 R >> endobj 375 0 obj <> /Contents 376 0 R >> endobj 382 0 obj <> /Contents 383 0 R >> endobj 386 0 obj <> /Contents 387 0 R >> endobj 390 0 obj <> /Contents 391 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 5 0 R 42 0 R 56 0 R 68 0 R 75 0 R 86 0 R 105 0 R 111 0 R 171 0 R 199 0 R 211 0 R 219 0 R 226 0 R 230 0 R 240 0 R 255 0 R 261 0 R 265 0 R 269 0 R 275 0 R 287 0 R 295 0 R 301 0 R 305 0 R 315 0 R 326 0 R 331 0 R 338 0 R 343 0 R 347 0 R 351 0 R 357 0 R 361 0 R 365 0 R 369 0 R 375 0 R 382 0 R 386 0 R 390 0 R ] /Count 39 >> endobj 1 0 obj <> endobj 4 0 obj <> endobj 10 0 obj <>stream 0 0 0 0 135 159 d1 135 0 0 159 0 0 cm BI /IM true /W 135 /H 159 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x-pAþƒÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿóJáÿ&«ïyÁcOÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿì.¾  EI endstream endobj 11 0 obj <>stream 0 0 0 188 138 272 d1 138 0 0 84 0 188 cm BI /IM true /W 138 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Ø`³ì@çj”Cƒ¾îÜš¯àÍ£ˆâ8Ž#ˆâ8Ž#ˆâ8Ÿÿÿÿâ"""""!¼àÀ<}‡ûï‡ïÿÿßÿÿÿÿ¯ÿ×…ÿÖ¿„¿­-uÐXK­,%®,]d“æ•áñäÕ/ÚÚ€€ EI endstream endobj 12 0 obj <>stream 0 0 0 0 110 93 d1 110 0 0 93 0 0 cm BI /IM true /W 110 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID & PCÙøTH ¢!4FÃ*°ÿøzPzÃÒ¾¡õád4øPˆ©5fl(×X?[záÿ¿Ãz[þü-¿ß ÿÃëÿûñÿ½ÿÿÿÿÿßÿäÕuÿ¿ýᇯÿzÿ[x_ýø]ëÞ»K½wë¼.Òï^ máwál<%°xK‡‘Ra!eì‰â·…±[_†¶ `ÂØ/à !¤[† ØVOÉÇ€€ EI endstream endobj 13 0 obj <>stream 0 0 0 0 141 129 d1 141 0 0 129 0 0 cm BI /IM true /W 141 /H 129 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ÜäuÿP_¿ð¿ß¿ú†ÿ÷ÑNŽ#ˆâ8Ž#‹ÿûðB"" ÿﯯá>ÿÿŽû×ÿÿ~¿ÿöð¿ÿÿ×þÿÿÿØÿÿ[ÿÿþ]_ÿÿÿÿï×ÿÿí&«_ÿÚÿÿøzá¯ý¯û×ý…ÿmÿûip×þ×l%þ»^×a¥Úáávm.׆—k‡­† v¼]†-ƒ oXa‚[#a¤¸2b»%!€¶+k m~ÂÚÁ…µ† ö°aa‚Á…ƒ €Éðad Ʋ C  EI endstream endobj 14 0 obj <>stream 0 0 0 165 141 292 d1 141 0 0 127 0 165 cm BI /IM true /W 141 /H 127 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ÏàWG@< 7©ÃSüá›®¡zþð—ÿú ¾¿}‡ÓëðEÿþ!½ÿéÿÂßþýûÿß_¿ÿÿÿÿÿÿí&«_ÿÚÿÿøzá¯ÿö»×ý…ÿµÞûiÃ^×zÿ „»^×a¥Úï °¸m.׆—k‡­† v¼]†-ƒ oXa‚[#a¤¸2b»%!€¶+k m~ÂÚÁ…µ† ö°aa‚Á…ƒ €Éðad Ʋ C  EI endstream endobj 15 0 obj <>stream 0 0 0 0 136 108 d1 136 0 0 108 0 0 cm BI /IM true /W 136 /H 108 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<áÿ‹ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿþelþMRØ[YiP EI endstream endobj 16 0 obj <>stream 0 0 0 0 138 140 d1 138 0 0 140 0 0 cm BI /IM true /W 138 /H 140 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ðdB‡ેMP?ÃÃááƒÃ‡ÁƒÃƒÃ!¡Kƒ ><† 'Áðø|òÁƒø~? ? €ž ¾ ?‡áƒò¼?ƒ  ü0þÃÈj…x†þüƒ!O†ø?Èÿ‡áùà|ãOÂð¼ƒ9>×…òã~Á/ÂðAx@¼ È5‹ü/„‚ø ¼Ÿ Âà‚ð¾D(ð|„‚ ‚à¸.ù¢Œ ¹Ä‚  ‚  ‚„ ‚ „ …¯¥X ¡Bà¡AAIªð EI endstream endobj 17 0 obj <>stream 0 0 0 173 136 287 d1 136 0 0 114 0 173 cm BI /IM true /W 136 /H 114 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±î?‹ÿ\èŽ#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâÿÿÿÿÿÁb"""""""""0áÁþMP>{†Ì.÷Œo aà߆x|0ðÃáᇆ <0øxaᇇà >xaàû†øx0{x|{Þx0{á¼|Þx>=‡Þ {àÞ>öðo°ð~áù¥¿üš¥°¶  EI endstream endobj 18 0 obj <>stream 0 0 0 0 143 112 d1 143 0 0 112 0 0 cm BI /IM true /W 143 /H 112 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÒKá—Là£àƒÓ„ôÿ Zý@“\& Ýéü„G×»Òýï ;ðAß Ü='¿Iï„Ûÿé8~¡ßþ¡·ëýü%¿½ýÿú ýßÿ«ÿ¿ýÿãÝ_ÿÃÿþÿßÿ÷ÿ÷ÿÕßÿRj¯ÿÿý¯ÿ}{kÿÿ¸záÃ_ÿ°¾õÿ†í_nv¾õ¾¾Ã w ~Âí†Lþ½a°¿î½­Úì>®þØ/kpk†Án_ø0· |;>‚È€ EI endstream endobj 19 0 obj <>stream 0 0 0 131 136 186 d1 136 0 0 55 0 131 cm BI /IM true /W 136 /H 55 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±˜ gœ Áþ!§ÿÿÿÿÿÿÿ@ðÛÿÿÿÿÿ&¨&·…°¨€ EI endstream endobj 20 0 obj <>stream 0 0 0 0 110 104 d1 110 0 0 104 0 0 cm BI /IM true /W 110 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¬kyÀ,† ¶àá‚„Ÿè éè#ˆâzýø‰ ,"¡è« g÷ A½áèôx[ÒÓ|/Iúo_Ûëè>°ýÿ ÿéÿÿøí?ÿÿÿÿòjš_ÿÿkþ¸¯ûaÿuºö½¥°ÿ­µÃa.Âðh-† ½l0—ä 3{"€Âö¶¶¿¶ k ,/à   ØV¯à EI endstream endobj 21 0 obj <>stream 0 0 0 134 106 289 d1 106 0 0 155 0 134 cm BI /IM true /W 106 /H 155 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Øa•ì@lÎÔwpï“T÷ç‘ÄqGÄqGÄqOÿÿÿˆˆˆˆˆˆ†òƒð}ø{ï¿á¿ïÿ÷ÿÿÿ×ÿëÂþµþ¿ kúZ ô°–¸KK‚Á,ÈÍ´ø_çjï¸wrj»íäO¼àÀ<}‡¿ïÜ?¿ÿßÿÿÿëÿõáZõø]/ëAk®ëK k‚‚]d“æÝXGb…‡ÿ&©~ÖÔ@ EI endstream endobj 22 0 obj <>stream 0 0 0 134 106 218 d1 106 0 0 84 0 134 cm BI /IM true /W 106 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Øa•ì@lÎÔ÷pîäÕmGÄqGÄqGÄÿÿÿÿ äàûì?ß|?ßÿÿÿýþ¼/þµü%ýik®‚Â]ia-pA`‚ë |Ÿ6êÂ;,8ûÿù5Kö¶  EI endstream endobj 23 0 obj <>stream 0 0 0 136 139 155 d1 139 0 0 19 0 136 cm BI /IM true /W 139 /H 19 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x’Û¦/ÿÿÿ&©µÚkà  EI endstream endobj 24 0 obj <>stream 0 0 0 0 110 80 d1 110 0 0 80 0 0 cm BI /IM true /W 110 /H 80 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡°—Ü„oÓ ØšéßúÂwߢ_YÄï„F>ü·è áþ>úMþïÓß ð·øwÿéÿ¿ûÝ×ÿÿÿÃÿûÿÿ÷¿‡Rj¿úûÿû×ÛÿðýpÛ_†í{m½¯½|"ûaŠÿ·Û¯kØ[ ¯û a¶¼5»¸0¿á!{>†X€ EI endstream endobj 25 0 obj <>stream 0 0 0 0 134 92 d1 134 0 0 92 0 0 cm BI /IM true /W 134 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & z a¯ XSø@ò ¸@ðAéþ<' ôðˆÚ8Ž ÿü(ˆoDh ¿½Ôô?¤xA7þ‚ú~ŸI¾ƒë|'Òaõûôø_ïAÿ…Õÿ¯ýÿ¯ÿÿýÿû¯Âÿ ׯûuþá.÷í¥¶‚Ãý¥°Â]®ÃK K a„²ö—‚âÿÿäÕ/ÚÃP EI endstream endobj 26 0 obj <>stream 0 0 0 93 136 171 d1 136 0 0 78 0 93 cm BI /IM true /W 136 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡à±Dàxáá?ò„ýBý$úÿë×ÿ¯_…ÿþëÿÿúãÿÿÿþÿûàø|“ïɪSaþö}oßýø?°k!³a<3CÿÿÿÿÿÿÿÿÿÚë @@ EI endstream endobj 27 0 obj <>stream 0 0 0 146 106 230 d1 106 0 0 84 0 146 cm BI /IM true /W 106 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¤v6áý?ÿÿû_ƒ6Ž#Z8Ž#ˆâ8Ž#ˆâ8Ž#ˆ/ÿÿÿüIUˆˆˆˆˆˆá`º"tµ¯¤=u®ý-x]kÿ¥ÿø^¿þ?ÿÿ¿ï“Uïø|>stream 0 0 0 0 136 120 d1 136 0 0 120 0 0 cm BI /IM true /W 136 /H 120 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xl%Á¢?§‚OAþžžÓТ­Oÿ^ð·Áò ôƒ}>°ø úMÿÐ}&ÿÿ 7ÂÿÖúúþ°ÿÿ§ÿÿõ¿ÿOÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿù¥¼þMRØ[_ EI endstream endobj 29 0 obj <>stream 0 0 0 0 110 84 d1 110 0 0 84 0 0 cm BI /IM true /W 110 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¤v€Í„D"–1 }ðÿ‡ß}÷¿mÑÄqGB8Ž'ÿÿ÷‹ˆˆƒˆ‡ÑBƒX~‡×o_ÒØ|Í-þ¨> þ=ëÿ¾—þÿÝ/ÿ×®ÿýzø_ëÿÿÿ×ÕGÿÁýÕ_ø]ü}{ýWª†¿ö’ɪ……Úý¤µðõ\*ì0•q¯®Âö«ipõáv½ ÂØ/ˆ2öCø`²À€ EI endstream endobj 30 0 obj <>stream 0 0 0 0 138 16 d1 138 0 0 16 0 0 cm BI /IM true /W 138 /H 16 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±”8@þ/üš¥û[  EI endstream endobj 31 0 obj <>stream 0 0 0 140 136 281 d1 136 0 0 141 0 140 cm BI /IM true /W 136 /H 141 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Vj©@<ƒ ¶APªßÁ„ž ðƒÂzz‘tq\/Þˆ¨lzÞˆ4= ׄAU'Â7­è?MôA‚¼$ßOÓéõ½ýC÷éô¯ü(~¯ß…êßýz¿ý7ÿúýCðÿÿÿ_¿ñßü.ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿüÿɪ[ kà EI endstream endobj 32 0 obj <>stream 0 0 0 185 103 277 d1 103 0 0 92 0 185 cm BI /IM true /W 103 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<! x9øX´ëX/­kX_ZÂÂ×Öˆ5¯ p—…Òép½Ð^º]. Òè/]Â]z ¥ë‚].½ézá.‚áz\%ë ].½.õ ¥×„º Âéb¾µ……¯.«œP¿_¯×ÿ×àŸªú¡z“T„…†  EI endstream endobj 33 0 obj <>stream 0 0 0 0 136 156 d1 136 0 0 156 0 0 cm BI /IM true /W 136 /H 156 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±î?‹ÿɪçÑÄqGÄqGÄqGÄqGÄq`ÿÿÿÿÿÄDDDDDDDDD ‚Âë x6á‚& XDš×ã<3à°£‚á‚ ‚Á‚ „E6. ,ƒ8ž\‰¼ °@°\X@¸X °ˆ¡pA`p°@°‚Ápˆ  B …‚‚ ÑÁ¢\ ¤Á·è."ðeÍ@xþDàË•x*áþÃäh \<0|<>È°Paðx0ðaáðÈ° † ƒ ‹Öx0x|x0|<( ¸aáðaáƒáä…ðÃÁðÈ°††%†@ðjÃἆäTðx?šY øÿɪ[ j  EI endstream endobj 34 0 obj <>stream 0 0 0 126 106 185 d1 106 0 0 59 0 126 cm BI /IM true /W 106 /H 59 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xf ÿÿÿ_…ÿ…þ¿Kÿ^HKýkQü.—ZZZá-ÖÒÁp–Aœ¿ ²_6Ï„v(Xq÷ÿòj—ím@@ EI endstream endobj 35 0 obj <>stream 0 0 0 134 141 226 d1 141 0 0 92 0 134 cm BI /IM true /W 141 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Ø@ÀñÈi”þ<†j®<z„ è=<"6Ž#ˆ?ÿ " è†[ûÑ&o@ˆm(áÐL< ¿ô›éú} ß õ¾ŸJ¿O×…ü7ÿ ÷úÿ¯ÿÿ¯ÿ“U_…þ¯_öëýÂ\5ïÛKm‡ûKa„»]†–0–à d¥xAþŸÿÿý¯ÚÚ€€ EI endstream endobj 36 0 obj <>stream 0 0 0 120 141 198 d1 141 0 0 78 0 120 cm BI /IM true /W 141 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x-ð¼OÅáÿÿ~÷<3„ÿÓÿÿÿÿÿÿ×þÿø_þ¿õùBúׯýf”xQøæF©uýX“T¶ìíTÈAÿÿÿÿÿÿÿÿíu†  EI endstream endobj 37 0 obj <>stream 0 0 0 176 105 330 d1 105 0 0 154 0 176 cm BI /IM true /W 105 /H 154 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x4¬òzä ಂ‚ùÌV@ôQ‚äAr¥?Ö A]KÈ6*ä5 9R D, Èf©`¹ê¹ yR x"rK$I„UJˆX`´JÁkŠæFÀñJ€<"ðÙƒƒähEò&¹)|‚Íö"‚ðx2¦ ’SÁò Ár@¼ªd<ƒZ¦CX ª ʘH0yE,‚Án <á¹OäbÒŠ% x!‰Á…‚„þ@ðÎ@ðtž@ðƒRž@ôQ‚Y’Þ²å¸"XAX+!´‚!AŸ%`^CL³ Ð[‚äàˆPkd°6¤-ÈrÜ&  \”‚ÕÑÌr6ˆ TàÁN‚‡*ð`áÁò,²k’€<7ÁòTÀ’ø`òOƒÈ9& ’†”ƒu,†R– ©†VIA¼ƒY& ’†$ò ŠX2¦.I\‚š¦ äA2 Åx7ä1Y AäAüà^¹Ã085<4â  EI endstream endobj 38 0 obj <>stream 0 0 0 0 94 57 d1 94 0 0 57 0 0 cm BI /IM true /W 94 /H 57 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹°< Óˆÿÿÿÿ;IýB®¦€yzׯÂÿ ÿÿ_ëÿþMPO†«kà EI endstream endobj 39 0 obj <> endobj 40 0 obj <> endobj 41 0 obj <>stream 0 0 0 0 143 164 d1 143 0 0 164 0 0 cm BI /IM true /W 143 /H 164 /BPC 1 /D[1 0] /F/CCF /DP<> ID & PF€¢@£ð@ð@ð@ðàŸè< zx' ÿAè‹£ˆâx_½~ô„A¾E7¢6è ´˜[Ð Þ| ý>[ÂOÂo„H7ÓëzL>¾é7Ð|-õêßOÂýõ¾½X}~¯[÷ë÷áx[ÿþŸýoßþ¿ÿÿøîÿÿÿÿÿï…&«_ÿÿýÿúï_ö¿ÿ‡®ëßë½wø^ýÐ]ûׯíwK¿]…ÛK†½ûh-ëµÛ pÂðÒÃk½l »^]ƒ¶ %‡­ƒ!¨²(¡rT v+k ml/ØX5µ† a~ a‚Á‚Á‚Á‚ü@ÖA™<@ EI endstream endobj 45 0 obj <>stream 0 0 0 55 138 146 d1 138 0 0 91 0 55 cm BI /IM true /W 138 /H 91 /BPC 1 /D[1 0] /F/CCF /DP<> ID >2w°§ /Ã[[á¬5“Uû †×†» v×[~à v» pm-ëa ¶Â\5ÁºØioí¥ƒ Ø]†–Ú[Ö 4¶þí„ÃKXm-Šý…†°û[_†°ÂÚë­uÒáa--tºák„µÒÒëAa‹SK°½ñþMRý­¨€ EI endstream endobj 46 0 obj <>stream 0 0 0 0 81 81 d1 81 0 0 81 0 0 cm BI /IM true /W 81 /H 81 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Öu¹ ‚EÃdzx@ÿO ééè?Ó§§ÿ ÿôÿðŸÿü_ÿòj—ÿþý¯ÿØ_µµÿ†¶¶Ö×á­¬0[X0¿F€ÄY½` EI endstream endobj 47 0 obj <>stream 0 0 0 0 110 91 d1 110 0 0 91 0 0 cm BI /IM true /W 110 /H 91 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¹à< Ñ G‚ ‚ɯÃÿAzW¯ÓxKéý½ýé?Pü>?ûÿê7ÿOþÿï_ûëÿÿÿÿö¼š­ÿkÿøa¥ÿaÛA¶—kþÃK°]놖^ m°Â_[$ÃK²k‘@Ç VÂÚØX5û aa¬,0¿KJ ,ƒ`AZ¸€ EI endstream endobj 48 0 obj <>stream 0 0 0 112 141 204 d1 141 0 0 92 0 112 cm BI /IM true /W 141 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¤e?Óÿÿÿµø3hâ5£ˆâ8Ž#ˆâ8hâ8Ž#ˆâ8ÿÿÿÿ‰0Ê Âb"":Â}¾:Më ½ytõ‡¤?O„›Ò¿ô›ÿ„úß^°ýð¿ýÇÿÿë÷ÿë÷á)5_þëÚ ÿú[kØ^m…úÛKmx0½„a-ý’a¦¶ †X"`ÇŠØX5µ°¿a`ÂÃX0Xa~Y 2Œ†¸ÖATd@ EI endstream endobj 49 0 obj <>stream 0 0 0 0 136 142 d1 136 0 0 142 0 0 cm BI /IM true /W 136 /H 142 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨àdbáÝ÷pìà¥>Õ¨0­Zö¤Õ¹0¾ÂÆÖýµ†KµÛ]´õ†ÒØa.Âá´¶Ð,=m„¶\5ÛA`Ú[Öà m„ µÛK „°õ°ÒÛAv¸m-°–ð¶ Â]®ØKm-ëa °Ú\xaml,5µûXk -­< ðžŸéá=ÓÂ!éð“z ‡­é7¤}>aáÞ· ›ÂA¾ŸA0ô˜zÞ zL>ŸA7 ›Öð`ô›á>oI¼-é“|'Òaà‚oXzAôzzO =zAè'Ðq Ð~§Ná:pš¡…ɪP EI endstream endobj 50 0 obj <>stream 0 0 0 0 139 104 d1 139 0 0 104 0 0 cm BI /IM true /W 139 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¤HÃ6A FC(ž?Ðx'¦ChCPFøL=4û êÐh?ôI£‰§þž´ô„/ §Ép/ôƒ¯ ¸zëÂ*Á“Áéè?X@›ö)ð½ôÓý| ¯I ßÿÿTþÿ×ÿL'ÿõÿÿÿÿÿÿý]BþMWÿ_ÿþúü.ÿÿÿÛIaÇõáþ–ÿiávÐ^»×~Ú^¼0K¿[h.׿zÛ¯kaµ†Ã ¿p×µ¸ílø ž  EI endstream endobj 51 0 obj <>stream 0 0 0 138 19 157 d1 19 0 0 19 0 138 cm BI /IM true /W 19 /H 19 /BPC 1 /D[1 0] /F/CCF /DP<> ID &©Eÿÿ“T  EI endstream endobj 52 0 obj <>stream 0 0 0 192 135 293 d1 135 0 0 101 0 192 cm BI /IM true /W 135 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Ä 5È3D0ƒÂ‚Oô éééþƒÂ"iè-ë#‹ÑH>B7¤øXz¤ß øO¥ëxH?Mõè'ÒÿÒo_§ë ×Ò‡Ãë¥Òá|.¯®—_ô¸KÂé¯K¥ëè, ½}/ ½zÖ—…^•zT¿A(KP°´– IP^¦h"†ô^@ð€]%Õ}uÂkù5ZaoMaðÁb,-›¿ EI endstream endobj 53 0 obj <>stream 0 0 0 0 139 98 d1 139 0 0 98 0 0 cm BI /IM true /W 139 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Ô@ÀðO‚‚„àŸè=2 çÐa=? ÿéÞˆ8Ž&_‡è˜áa˜þ;ðAýß­ýú ‡OéÞ—ûôü( ûô¯ÿß×ÿþ7þµÿü/ÿõÿ¯ëÂÿªÝWþ²j°«Õ{×úúöÔ ¾—†K ¤¿U¶¡.á/ja¤— $-ê¶P—\5Ã&B!€=‘°Â!D·ªØ‚"‹ìWá­…†Ö á…ƒ Y E¿È6©äŠ²êà EI endstream endobj 54 0 obj <>stream 0 0 0 0 94 70 d1 94 0 0 70 0 0 cm BI /IM true /W 94 /H 70 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹ÀR:— ðAè? éééþˆ„q„[×Ѭz? ô| ø[Ò}/„ýCÒ}|%ûzè.—ú]C넼.½z^º_ázAh*ëëÕuâUÂé*\J‚UPh ² `úª¦š ˜_áØX°P EI endstream endobj 55 0 obj <> endobj 59 0 obj <>stream 0 0 0 0 133 97 d1 133 0 0 97 0 0 cm BI /IM true /W 133 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x3,ಈYÀ’¸X/‚Á`°XKò†h¡O…à «,\ ‚‚Á`aY,Â%A© HYÉ@mB ‹$‚¡VY b®È X." x@°ˆ˜ ÁtDÀðÑ?Ð<"… z |ƒü ÁèÖ ÂAÐ~ƒR bÿH0~ Aü‚°¿†rV >stream 0 0 0 0 139 92 d1 139 0 0 92 0 0 cm BI /IM true /W 139 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔvPä36`ªòö§„àµðµ…­u®‰4qGGÄqˆâÿÈEÿü"2΋"!˜Aèˆ Ì!>¥ 2ëÁ„÷¤¢-ø[ÒA]?A<>¨}$úMø_$¯è?ÿI7ÿÃáz½WÿÂÿÿÿ×ûÿþ¿Ã ‡ï^ázɪßúû×Úý„»×Økö–ÿ´½°¼80¿h/ 0Kw®Ø0Kán5ò6ìWl-à Úö»÷ax0½­ Áb /Ã%@× ,ã1<=p EI endstream endobj 61 0 obj <>stream 0 0 0 60 103 79 d1 103 0 0 19 0 60 cm BI /IM true /W 103 /H 19 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ÖÊ-?ÿÿÿÿÿòj“P EI endstream endobj 62 0 obj <>stream 0 0 0 107 105 204 d1 105 0 0 97 0 107 cm BI /IM true /W 105 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5¬<2µ…<4…òƒ¤…>stream 0 0 0 0 136 115 d1 136 0 0 115 0 0 cm BI /IM true /W 136 /H 115 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x3p@ÿôÿÿÈÿ?ôÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿù¥¼þMRØ[\í( € EI endstream endobj 64 0 obj <>stream 0 0 0 0 136 122 d1 136 0 0 122 0 0 cm BI /IM true /W 136 /H 122 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±˜ Pƒòƒ/D0@ÿôÿ$ïð@ÿÓÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÄÿɪ[ k!6· EI endstream endobj 65 0 obj <>stream 0 0 0 139 103 238 d1 103 0 0 99 0 139 cm BI /IM true /W 103 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID >ƒV<e¦P×µjÕ‚†¤Õ}¬6¸al4°Úï[a-°—kƒ ¶‚Þ¶ÒØaà ƒim ·­°‚Ãip× ¥¶-áa†–iv»ilAa­¬5ûX`¶¿O èý<"1=aá&ô›á>aè ÃÂÞ“xA7ÓéxIƒÖð7¤ßO„ƒI¼-è&aðô›Â ½oIô›ÐqN útœ'OÓ„&¤Õ!€€ EI endstream endobj 66 0 obj <>stream 0 0 0 0 97 71 d1 97 0 0 71 0 0 cm BI /IM true /W 97 /H 71 /BPC 1 /D[1 0] /F/CCF /DP<> ID &   ä3ŒÂAà™ ³ÿ¦A½ZaÓOA‚xM?ù¨=‚4õ .:| òœ¼&ç@N“¤ßÿÔA>5§¯¦Ÿþ>õðá?…ÿÿÿÿý|/Ãòj½þ¿ÿýð°â¿ö¿[ý¥á{]놻ÖÚ Òì.û nÖÃkvûx(€ EI endstream endobj 67 0 obj <> endobj 71 0 obj <>stream 0 0 0 0 14 66 d1 14 0 0 66 0 0 cm BI /IM true /W 14 /H 66 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ó‚ÿÿÿÿÿÿÿÿ“T¿à EI endstream endobj 72 0 obj <>stream 0 0 0 0 136 129 d1 136 0 0 129 0 0 cm BI /IM true /W 136 /H 129 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹€È¨8†@ðÐ{k Ö?°Á§`ƒ´§ðiØNù5M> ‡öþÓí<ƒìD¸;Þ>Ý> ¤ß°h&Ý>ôÖöéø?ÛI½¿Áá>ßì0·Ãýº|ýÿa¤ØßàßìpöŸÿßßßÁý¦ÿ~ü¿÷àÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÍ,…ãÿòj–ÂÚø€ EI endstream endobj 73 0 obj <>stream 0 0 0 0 93 76 d1 93 0 0 76 0 0 cm BI /IM true /W 93 /H 76 /BPC 1 /D[1 0] /F/CCF /DP<> ID & `à3Áÿÿÿÿÿÿÿÿϵ|?ɯò ÐA\>Âð—„½|ð}z^‚ð_AxA}xKÂëéx%ð^—„¼/ ¼ ¾¥á/ è‚_\Auýp¸\.¿® ¬€€ EI endstream endobj 74 0 obj <> endobj 78 0 obj <>stream 0 0 0 0 136 117 d1 136 0 0 117 0 0 cm BI /IM true /W 136 /H 117 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±î?‹ÿòj—>Ž#ˆâ8Ž#ˆâ8Ž#Z8Ž#ˆâ8Ž#ˆâàÿÿÿÿÿˆˆˆˆˆÁˆˆˆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿæø@þ/ÿɪ[ k“ ø€ EI endstream endobj 79 0 obj <>stream 0 0 0 0 134 92 d1 134 0 0 92 0 0 cm BI /IM true /W 134 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ìÍÁ© |qäÕ/Á—GÄqGÄkGÄqGÄB#ˆÿÿÿÿâ""$ˆ+DDC0‚ÖÁøƒ.¸$÷¢„·¯zÐeÓÒ‡ÐøJô›ÿ[ÒÂý½/áÿ…ú¿×ÿÿÿõþÿÿ®þÿ†¿ µïïÖÚöá¯k¶–ÿil^ÂðÐX`Á-ëa‚[ `_Ȩ'b°ÂØ[[_ƒ aa¬,0¿ ‚\aF@ðÜ y'€€ EI endstream endobj 80 0 obj <>stream 0 0 0 0 192 96 d1 192 0 0 96 0 0 cm BI /IM true /W 192 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡çÜ ðO Áa|†@j¤……‚Â\%‚Ž,, \,X"( ¸A`p°a< 0ˆ°jA‚ <Eð‚à°‚Á…ÁÁà°AaÂà‚ÁÈ  Á„   ´)„ „ ‰à« ª+…‚ …„ Ô+…Á ‚  ‚"á\, X\-áD(.„ €m MP_°¶  EI endstream endobj 81 0 obj <>stream 0 0 0 159 14 282 d1 14 0 0 123 0 159 cm BI /IM true /W 14 /H 123 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ó‚ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿɪ_ƒ EI endstream endobj 82 0 obj <> stream 60 0 0 0 0 0 d1 endstream endobj 83 0 obj <>stream 0 0 0 128 47 148 d1 47 0 0 20 0 128 cm BI /IM true /W 47 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡š²Á`°Y)äRˆYÁÊ»Èg@rèâ8¦£õ&¹pÛ EI endstream endobj 84 0 obj <>stream 0 0 0 0 94 70 d1 94 0 0 70 0 0 cm BI /IM true /W 94 /H 70 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡”H‰â2$Óü xL†®i‚ŸAÿ§Â ÑÄÿßA ôk Âôý ?ý[õúÿ„Ÿ÷ÿ×÷Çÿø_ÿÿÿ¯ýøküš¨Kÿÿh/¯¿‡Cý×`»ÿaÿ·Ûkþk;ím[P EI endstream endobj 85 0 obj <> endobj 89 0 obj <>stream 0 0 0 0 192 61 d1 192 0 0 61 0 0 cm BI /IM true /W 192 /H 61 /BPC 1 /D[1 0] /F/CCF /DP<> ID <I aZµý¨j“]¥Úï[il4» Úì0‚Þ¶[a.× 0— w…°Á-´¸0» à %‡‚Ø0Ka„¸0¸`È ƶD€ðp°ð¶ Á‘0<7É@vA±a•@.°Ä_ƒ† ,0Y}„üÝ@Q Y¹àÁdk9Âþ@ðÎ’  EI endstream endobj 90 0 obj <>stream 0 0 0 0 134 104 d1 134 0 0 104 0 0 cm BI /IM true /W 134 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xp@ÿOÖµ…¯­k _ZÖÖ°°ˆE¥ë¥Á.¼ ¸%ë¥Â\ ¸Azà—áÈ zàpKe,à‚äB¼.CMKÍ$äÙ¯/dpAx/ _ ;5xY[¨/•@=Ád°&¨‹àÇ `xþ Ö†–?ÿÿÿÿÿÿÿÿý¯Á‚äp€ EI endstream endobj 91 0 obj <>stream 0 0 0 0 139 98 d1 139 0 0 98 0 0 cm BI /IM true /W 139 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¨TÁWä5Œò[ì<ØÀÌ‚ðàƒÓ§Ⱥ8Ž#ˆâáïAˆâšÃÑw¢`O•x¼ ¾Dᣭé0øAøO¤ëÖú|+ôü+÷ÿJÿðýǧÿÿÿÿþÔš¬/ûü/ûׯí,?붗av_ì0‚ÛK•x'† †Léo[#@N¶JX.=¬5µ† kðaa‚Á…ƒ;  Á~CXÏ ¨§7€€ EI endstream endobj 92 0 obj <>stream 0 0 0 0 131 20 d1 131 0 0 20 0 0 cm BI /IM true /W 131 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡škå0 8/༇ÿ"”p¼à˜ÿùW‘ó 9tqYtqS@Ñú©5ËàÎ  EI endstream endobj 93 0 obj <>stream 0 0 0 0 139 104 d1 139 0 0 104 0 0 cm BI /IM true /W 139 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¦P†lƒ@Œ†RL Èm‘þƒÁÓAè0žšþ˜O §¦žƒAè«Gÿý!&]y.ØD` ÷ÁhÔ txA¾žƒè ÚA‡ÓÂ}u¾˜tý=}>úÚW¿ÿ…Š¾œ?Âÿô¿ÿÿ¯ÿߊØÿÿ¯ÿÿÿÿÿÿÿ½Iª¬/ÿÿ¿ÿµ]úøþDü%ýü0ºÿ~ÚN—ÿÚ ýµm.ÖðÂØ]´›-þ¸a&\0`²0EÊ°øø ÖÓï[ …´×øi­ ÖÓ°ƒ[L/ðh-„ ChÓGÀ@ EI endstream endobj 94 0 obj <>stream 0 0 0 0 192 61 d1 192 0 0 61 0 0 cm BI /IM true /W 192 /H 61 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xBZ„ùÚÎAŸo‚(ÝX#°€Iò »Â‚<>AQÄq\/ððˆ“SÂÞÀôJáò&†üÅ @Þˆ ÃÂ@ðÍ1ÁÐA½ð°xAô7ÁÒoAzÃá>A¾ŸH7 ›Öôaôý ½&õ¾ž)´'Oútè?á95I¨€ EI endstream endobj 95 0 obj <>stream 0 0 0 0 136 124 d1 136 0 0 124 0 0 cm BI /IM true /W 136 /H 124 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜Sá•?‚zzd6¦CV¿ðƒ@ôÁ¦žšÓÿDšiáa„ÿOEXÜ>xOéiô÷­¯ ïIÂ"ÿ?MÐ7Ðtá~ÃKÒzoú~áþÒ¿ÿW„ýk~ôý_ÿ^¿øcoÿªýßÿø\V…ÿÿ¿Ø_kÿÿþÿÿÿ¯ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿñÿäÕ-…µ EI endstream endobj 96 0 obj <>stream 0 0 0 85 140 171 d1 140 0 0 86 0 85 cm BI /IM true /W 140 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & `ì)Áȵ¬'ákZ×Â××ëEZ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8¿ÿÿÿÿÁkÿÿÿÿü! \]~—𿯎¿úÿÿÿù5^ÿÿÿ¿ßûÿÃÿ½ûþ÷ïaÿþüà< <@ EI endstream endobj 97 0 obj <> stream 37 0 0 0 0 0 d1 endstream endobj 98 0 obj <>stream 0 0 0 196 138 342 d1 138 0 0 146 0 196 cm BI /IM true /W 138 /H 146 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¯Á8X,,/‚ÂÁa,/ °– ‚  …„ ,,., X.,\, XA`¸ X ¸X@°Aap`‚äLá‚ „ „,.@| ¹À¼ °@°¸ °‚à´¯P¡HÀ< ðàør‚ ppä×ðö‡È V > x|<|…ôxaàø`ðÃàðaᇃáƒÃƒÁ‡†BÃVƒ†< <|x`ð|0ðaðxaá¼Ü<áàððð°a@@ EI endstream endobj 99 0 obj <>stream 0 0 0 0 140 117 d1 140 0 0 117 0 0 cm BI /IM true /W 140 /H 117 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Úv4ä5<­aá|µ‚úZ裈â8Ž#ˆâ8Ž#ˆâ8Ž#ˆâá ÿÿÿðZÈàx5`‡`x6ÐZõ ]a.µëAuú_¥ý~_úõÿýÇõÿÿýÿ&«ýÿÿ¿ðýÿ{·ü=¾ýá‡Ãáì˜ÃVüàÕgiO¾½ïï{Ãø<<Á…mØ×À@ EI endstream endobj 100 0 obj <>stream 0 0 0 179 133 287 d1 133 0 0 108 0 179 cm BI /IM true /W 133 /H 108 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ªx ¨ §ÿÿÿÿÿÿÿÿÿÿù¶i„Åÿɪÿ –çkÓáxKÂø_ |//KÁ}á/‚ô¼õðxKë Ð^¾/KëÂá/_/A}x ½/_ ¾¼ ^—…ð— ¾‚^‚õð—]uÁ\.¸\/ë® ­…ü,€€ EI endstream endobj 101 0 obj <>stream 0 0 0 198 104 290 d1 104 0 0 92 0 198 cm BI /IM true /W 104 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜lLd `駅‡ÿkÿkÿ /øx[iÚï$%‡ë|{_öÒÞ¿Øa-ëµÿm,<-ëµÿm-ëý†ÃÂãÈÇÈi˜CD6ö½ASˆôÿþ×ò*3¨û"c!°F8éóEÂÃÖøAÿÒo[ÿI¼,>Ÿ[éõ½o„ý&ð°ÿÒo[ÿI¿õ¼$Ãÿ„þŸÿú|<-¦°Á ø€ EI endstream endobj 102 0 obj <> stream 47 0 0 0 0 0 d1 endstream endobj 103 0 obj <>stream 0 0 0 0 97 69 d1 97 0 0 69 0 0 cm BI /IM true /W 97 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡”u‰á2 h?ÂxAè2‡ÓôÿôD#ˆ8x@„‡×ù¨?Aï?A¦úþŸ…‡éÿúøÿáÿÂÿþ¿á/ÿà ‚ÿª“U×Ò^ÿÔ%Ý%‡þÒKm‚áགAvA-ê¸0%°`‚¹II¤Ã kk ,0¿ -…n†C4Oò…à EI endstream endobj 104 0 obj <> endobj 108 0 obj <>stream 0 0 0 0 138 218 d1 138 0 0 218 0 0 cm BI /IM true /W 138 /H 218 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡dw!§<ƒ‚È!|àÈN@ðT‚Á`—ä’œÁpK xÂÈ „ x¡x" äJ\‚d Y²Ü H„%€« ¬[Ú-ÁpA`ˆP,ಥ¸"XœAp® !Ëp@°\"Š%`xfà´E@ðÔÁG#@xm”€x+‚‘€x©P‚9Ão"€xkƒ’°<‰® < _eH Áðy«†I@ñdSÈhRÁ•0=d” ÃÁ’P'kSÁƒÁ•@dÁàÁä‰2 JX2¦pePpðd” H3’`ùÉO >ICÈ“ x.IƒäX7ÃÈ ˜n@ðÔ<àþ@ðWI< ÆAäƒ*¸,á´7ä aLYÁ¤§°K’‘ ‚ÈdÁÈ0N* ÉÑ^ YÈrX °‰P*È2à¹ÐL\•‚Ì,*Ô†`&@¸&\•ád+Á < ˜@²e¼”á›@´EðÔ¬AHÐe  ä  e8Ê°<H ¸9ÃX–àÒMr†_Ø=•0<4`ðÊÀ V@ñ ùÕr8<XÈ0x>A­WI—VCn AYW ¤«†+ Ñ P±ƒ+ ¢AW ’†yÍW•H0yìáò ¹Áº—Á¸<á¦Qðx<àÈN@ð$äš ò x0P EI endstream endobj 109 0 obj <>stream 0 0 0 0 93 71 d1 93 0 0 71 0 0 cm BI /IM true /W 93 /H 71 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x7 :Ö¾°µ­}aak_jôºðK„½t Â\ð\à—äÀù Ñ/ P'È`«˜“°XY h_%©‘ $•`³&±Ô_Çÿÿÿÿÿÿþ (€ EI endstream endobj 110 0 obj <> endobj 114 0 obj <>stream 0 0 0 111 47 131 d1 47 0 0 20 0 111 cm BI /IM true /W 47 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡š²Èl' !¸/‘J!g*/":GÅ4 ©5ˆ؀ EI endstream endobj 115 0 obj <> stream 94 0 0 0 0 0 d1 endstream endobj 116 0 obj <>stream 0 0 0 0 155 53 d1 155 0 0 53 0 0 cm BI /IM true /W 155 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨œ2 üZa…í{Rjš]¯ .õ‡…Úí¥Ã °Â\Žšã×il0— .a¶–õ°`–à pÂáƒÁ‚[ÖÈØ)­‘@Û\”ŸA€[†Xa~X0Xa`Áa…ùs,0²Y±løO€€ EI endstream endobj 117 0 obj <>stream 0 0 0 79 123 176 d1 123 0 0 97 0 79 cm BI /IM true /W 123 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦xJOOÿÿÿÿÿÿ’ØýÿÿÿßÁä"²ÁÍ¿D 5á7àƒð~‚oÿA7éý}&ÿõýkáµÂÚ÷ÿ¯ÿÿõÿ¿……‡É¯_û­×µí{ oðÒÛ^ö lAaþ †Â{ aWý¬0[_µ†°Áa…† ò‚Xe ÈjW EI endstream endobj 118 0 obj <>stream 0 0 0 189 90 271 d1 90 0 0 82 0 189 cm BI /IM true /W 90 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¶hÒ ŸÂÉ0/A ðX=aëÿ‡­áoïA_5¬†¿ ‡¨íÿéddøY ðý`Þ–ÿßïÂؼxÿ­¿ÿýÿÿÿïÿþ¤×þþ»ÿ×ÿï.ÿõÛׇ¥¿÷¥·…ï^ a½w뇂 dâ=­¬5µ°¿kk ,0°ÂüX`² dðe8j€ EI endstream endobj 119 0 obj <>stream 0 0 0 0 123 82 d1 123 0 0 82 0 0 cm BI /IM true /W 123 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xmŸžŸä þa?ôï7ÿþøa‹ÿ÷ïÁøÿÿÿÿ×þþ×ÿKÿ à”G×S°Tõ×X× †d0Öÿÿÿÿÿÿÿÿÿÿÿòj—í†b€€ EI endstream endobj 120 0 obj <>stream 0 0 0 0 111 85 d1 111 0 0 85 0 0 cm BI /IM true /W 111 /H 85 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÜÐä× „†×ÿ¨Aëêž¾ÿAè¨_áz?)Àß×Âõÿëáqÿõÿÿÿßÿðù5ßßÿ~ÉpRñ"vÿ·ýáïx°ÖCfÂdÿÿÿÿÿÿÿÿÿÿíu†  EI endstream endobj 121 0 obj <>stream 0 0 0 0 90 77 d1 90 0 0 77 0 0 cm BI /IM true /W 90 /H 77 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡° @ðƒÂ„ôÈh þ˜ z~©ÂßkÑ­ËèC}MÖ“ÂéÚûúpo_ødOáÃ…¿áýøÿ¶þ¿÷ÿÿÿþÿ÷¿ÿú“^þû®ÿ¿ß_íÃø>v†þÁÚï×ÚðvÂǦú×¼a®ímmI®®þ  EI endstream endobj 122 0 obj <>stream 0 0 0 224 106 324 d1 106 0 0 100 0 224 cm BI /IM true /W 106 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x! h<ÁäƲ @OÈ+dò› ѹä ïOȲùÙRἚ¢ -ðû>ÿÿ¯ÿþ¿ýk×õ…ׯÐ]k¥…ëKAk¥‚]hð‘êÁ äÊ ° $TÈ+-d 2›Ž² ü}‘#iò ´ùÓó²DÛF߆—‰ØàØRÁX¬™R‚X ù(â$ˆRá‚jˆ€<6YÐ ¯³àx5€ EI endstream endobj 123 0 obj <>stream 0 0 0 0 110 95 d1 110 0 0 95 0 0 cm BI /IM true /W 110 /H 95 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x¦ o |¯ ´%'*üƒ*–AT—!®ekÞd2öGä6lfA}«ÈMd·åa@ð¿Á ó±Ã8zÿo²‡ä°-ù/Èlßü˜ «Ø/µ ³øAyFõü/¯ëéúü$¿×_Zð¿ý­éÒÿê¿ÿ]~¾—…ÿÿ ‚ÿúýB_ñþ‚_­{¥×ô¬%ýi.¡ {K°¡®< °£&©„¸úÃõµÂý­­¬5°_†Atù Ÿ EI endstream endobj 124 0 obj <>stream 0 0 0 119 106 290 d1 106 0 0 171 0 119 cm BI /IM true /W 106 /H 171 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x! h<ÁäƲ $È+dò› Ñ¿ü}é#eò ²yÆól2”„wáüìpÑ”°Ëe`åHd°ä  <‰̤Ãy5D@[:áv|?ÿÿ_ÿÂ×ÿ¯Òü/_¥Â×^ºÒÂ률ºÒÁ-p`ƒü" 1 Î5X(Èd‰? Ø—ÔØùþ@¾ôȲÿM“Èö7›bø^wáüìpщJ ¼¬[åHd°ä  $He ù5D@[:áv|1ÿÿëÿÿ…¯ÿZõøKõë…®—éa/ÒÐZé`—ZG<$z°CÂyrŸÈ,ä 2 ËYÃL†¦ã¬ƒFÿ _ddÚ|‚m>G´üì€Q6Ñ„wá¥âv86°V+¦T`–>Jø‰â€x`š¢  –tÃ+ìø @ EI endstream endobj 125 0 obj <>stream 0 0 0 0 110 96 d1 110 0 0 96 0 0 cm BI /IM true /W 110 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÌK†\8–è=ïø}ðò ðœŒ_Ð"_Â/…ÃzÿX7¥¿ï¥°úÃëÿÞ[õÿ¾—ÿuýÞ—ÿÿ_Âÿÿáþµÿÿõþ¿ÿÿ¥ÿ…ÿÐ_ýzúÞ—ÿRj¸^ô¿_Ð\=pý~ï Þ»z]à–ü.ÛÒï:NVÁÖ)u²%ǵ°¶Ãû ,0X2& ŸR$†® EI endstream endobj 126 0 obj <>stream 0 0 0 197 141 284 d1 141 0 0 87 0 197 cm BI /IM true /W 141 /H 87 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡Î9Á˜Œ.¿Þÿÿ‡áÿïÿÿùÃ7øAÿ§ÿÿè/ÿÿÿ¯ ÿ¯Êÿÿõ¯_×ò`ÿä”yF8ÿ x7ë x.¥<*®@ó[È3šd7}d 7™mÓ Ù½r›¯ ѺùÙ§ _zäÙ|‚lžG´å›u|íøG~yØà_)`Ñ•€ÓÊ6ä°òP ‘ XÊ@gɪ"óìè…[> üZ€€ EI endstream endobj 127 0 obj <>stream 0 0 0 0 110 106 d1 110 0 0 106 0 0 cm BI /IM true /W 110 /H 106 /BPC 1 /D[1 0] /F/CCF /DP<> ID & °F”‚˜A\_!¶[ø@ðƒÁ< z‚zxD]O‰¯Zá Q¢ D˜j=| Mè7Á>‚}/Xx@Ÿ ü/A7¥ëõé7¯ …ÿIõþ—úúÿ…×õþ_ÿÿªþ5ÿákøKÿKõ´ºý&ªµô¸i‡K°Kµð‚Û }m„¸2J; °È5¤ä˜[Ö0q_°¶ÖÁa…øk`°`°Áa‚ü†iŒ†ž° EI endstream endobj 128 0 obj <>stream 0 0 0 117 106 196 d1 106 0 0 79 0 117 cm BI /IM true /W 106 /H 79 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xfá®?ÿÿÐ_ÿýaô¿¯×­zý…ë^´º×\ ºÒÒ×K H„ž‘:°CÂx_Èd 2 ËYÃL†¦ã¬ƒFÿ _ddÚ|‚m>G´üì€Q6Ñ„wá¥âv86°V+¦T`–>Jø‰â€x`š¢  –tÃ+ìø @ EI endstream endobj 129 0 obj <>stream 0 0 0 97 103 214 d1 103 0 0 117 0 97 cm BI /IM true /W 103 /H 117 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5ýakZÿXZ×Zég°º”Z\+JPøam. ÐV”5°”Rjµ¶‚ÛKƒ\ l:ÃÖ  ¶ .× 4¶K¬0Ð[iv¸0iak°Âý¬|7ƒßAþzz£RH7Óá “zÃÒ é0}Â7¤ÃÖ ÃÒo øIô7^“Ò}ÂOA¯IééáCÒ kè ÂÒ°––º ®¢«áUWPªMR€€ EI endstream endobj 130 0 obj <>stream 0 0 0 0 134 109 d1 134 0 0 109 0 0 cm BI /IM true /W 134 /H 109 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xr$$§ò°¬x'„OðO éàƒÑGÄÿý"ͧ¢]oè¤ W O¤zøA>“ðOÓtºôƒázxK×_]_ ×_ô«¯þ¼,/_ø_×úIá~¿é/ý~¥õëá/]ÒíTþ¿B/iù=†A§ý²  »d4Õ8d2Ö¶ ˜aûëb°×àÎÓ…ÓÚ~v@(ÍØyû# FÓä>Óä{¯ pGtˆ#¾·âdˆVðÁRÃa-Ã+"àx5°<5Š@<6ɪ"ðe²ÿ ð€ EI endstream endobj 131 0 obj <>stream 0 0 0 111 110 212 d1 110 0 0 101 0 111 cm BI /IM true /W 110 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5@ð0Œ ÿ¿ï~ÿoß Â!áøð­è/ý/Iÿêé„Ã믮¿é×úÿÂÿøKá}ÿñKýkü,/ék×éZázù5Tkëý,=v½„¼.ØApa-ë°Kl%à ÔÉ0PÈÐU‡®!l/ÚØ[X0[ ðÁa…†JZC,SR¿ÈiÕ EI endstream endobj 132 0 obj <>stream 0 0 0 227 136 301 d1 136 0 0 74 0 227 cm BI /IM true /W 136 /H 74 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5 (@ÿôÿÿÿÿò?ôP‹ÓÿÂÿõëõëÿ×þ—ÿäF‚È0ÈTÿýd”xáò„ ×ÈJ¼áºÔdM2û¼‚¾éÂÈ6ïò{üƒNÑd ì‹ ÆÈहbvkþv yÝ@™5Gt þw`_ɘ4Ã$¡©Ù ®ÉP+öDÀ߃*À¯þ üý¯ÚØP EI endstream endobj 133 0 obj <>stream 0 0 0 111 141 222 d1 141 0 0 111 0 111 cm BI /IM true /W 141 /H 111 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡dºò¸LàÈä ¡IÃPª@ði< *ÈÖüàæ’‹»ÈïÁr›ò²²û"‡Ç Ë°ò{!¯ºò {OËÚ~v@kHlØyöBlKi0ƒç~/Ž ½°0ß+ÓåH5Ÿ%€«ä _"@±ûàŸjÂö}…â“ëá+Òúô¥ëõá~½%ÿ_…ëõúZÿø\%ü/_ã^µëô¬/é~‚µ× CJMWð—iv Ú „¾¶%ØK†A¬d˜ ‘ E½lV/ëama‚à ö ,X2.†$3¿ Öž  EI endstream endobj 134 0 obj <>stream 0 0 0 228 14 294 d1 14 0 0 66 0 228 cm BI /IM true /W 14 /H 66 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬?‹ÿÿÿÿÿÿÿɪ_†€€ EI endstream endobj 135 0 obj <> stream 48 0 0 0 0 0 d1 endstream endobj 136 0 obj <>stream 0 0 0 0 105 99 d1 105 0 0 99 0 0 cm BI /IM true /W 105 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xi­8,/¬°]k…ÁtT%…¯ZX\ZÖX@°¸K.XAap‚Ð\,XAk‚ .–A`— °–  XK…‚¥…ÐX ]h-ר…PP¥@  >stream 0 0 0 120 138 162 d1 138 0 0 42 0 120 cm BI /IM true /W 138 /H 42 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x/È A2‚¨á®) x5•H€¾@ðn« x.· xSIÏy Ï¿¹ØëYý@“dA[iò ›ÔÝ|ì€ÊhÙû# FÓäiò=§çd<ÛFßÿ‰Øàx¥,+xg*@x%€x4ä  2$ƒiH‚¹5D@ötÁgìødà EI endstream endobj 138 0 obj <>stream 0 0 0 0 106 99 d1 106 0 0 99 0 0 cm BI /IM true /W 106 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xYÃ8?Èb@ñDäÊd d Õ<ƒ*Ô†Ù¤†¾âA¯sÈeìå?ÖCfÂû#!6Ÿ%º°ŽÃ߃Nv8jÑK ¿ÊÀ2eH2X™(Ã|‰çùÄ°¶¶}…Š \%¥ÂÒýtºü%úè/ëõý/ÿÂ_ÿÿä'ùÃÕ<äF$ ÄÙBŸ ¬ Ú©!¦´ÈfHÜjMS Æÿƒ"m|ìH\í <3±£;Ð Y߃Oçc†­•°Û²ª –Aâϲ6†ðÊ€<¤"  EI endstream endobj 139 0 obj <>stream 0 0 0 101 110 195 d1 110 0 0 94 0 101 cm BI /IM true /W 110 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x5yÃ(=?ïÿ!¥Íä3+ð@ül?ôÃàøNõð›ÿ§é¾·AÿÉq< M‡Â~·Ò ýõ}'ÿ×õýü+áþ¿¿ÿèð¿×ïÿÚýë†ÿ…á}.þ×a„¿¶Â]…ãØRjµïÝxkþXv¾ Ã]†ûlƒ È)Ól{ý‡Þÿ†ÿö¸-…³`x4x€ EI endstream endobj 140 0 obj <>stream 0 0 0 212 19 234 d1 19 0 0 22 0 212 cm BI /IM true /W 19 /H 22 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ‹"¢zÇÿó¢ëñ“Th € EI endstream endobj 141 0 obj <>stream 0 0 0 0 155 53 d1 155 0 0 53 0 0 cm BI /IM true /W 155 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ~BüX¶@à+ ʵøAä6÷˜Aàáø xAá„AQÄq„J×áüŽtECMàˆ mƒÖôDMè[àôÂ0õ½Ð o§ÐA¼ ƒ[ÐA½&ú~}ÂÃéô›ÿAúxí:tü üš¤ÖÓ[M@@ EI endstream endobj 142 0 obj <>stream 0 0 0 0 132 97 d1 132 0 0 97 0 0 cm BI /IM true /W 132 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xR>@ñ‰áÁ„?Ðzzz òa]{Òo[ÑH<„ Àø@ø@›Ò÷¤ýøO¤ý?Þ—ï×ᇅÂÿïýÿÿÿõß/¾ƒáx ábá×k¿Úï]®Ú\^×a¥‡ù !l“ê"U˜ÿÿ΀xkÿÿÿÿÿÿäÕ&¿ÃMl&  EI endstream endobj 143 0 obj <>stream 0 0 0 116 121 199 d1 121 0 0 83 0 116 cm BI /IM true /W 121 /H 83 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`X zÿÿÿÿÿÿÿÎÉ`ûÿò ?ÿÿÿÿÿÿÿÿÿÿäÕ&¶šÁ‚ (€ EI endstream endobj 144 0 obj <> stream 45 0 0 0 0 0 d1 endstream endobj 145 0 obj <>stream 0 0 0 0 87 102 d1 87 0 0 102 0 0 cm BI /IM true /W 87 /H 102 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦xAééÿÿÿÿÿÿó´öÿÿÿ÷ð{"_ø@½x]/]}uõÿ øÚÚ¦±ÿÿþþ&¿¾;OXÏ®÷ÿ߇ïßü x@ÿÿÿÿþ×ím@@ EI endstream endobj 146 0 obj <>stream 0 0 0 131 27 157 d1 27 0 0 26 0 131 cm BI /IM true /W 27 /H 26 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¢„„žŸþŸÄ?äÕû_û[X0Xa@@ EI endstream endobj 147 0 obj <>stream 0 0 0 216 124 286 d1 124 0 0 70 0 216 cm BI /IM true /W 124 /H 70 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<è=8¿ÿÿÿÿÿ¬°\(P ¤0<Zð´Z]azÐ_×Zÿõÿ3_ÿÿ“UªÞŸÿL,D0  EI endstream endobj 148 0 obj <>stream 0 0 0 80 91 170 d1 91 0 0 90 0 80 cm BI /IM true /W 91 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡´x6áÓü ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿò{¯< þ/òj—á…øad5kÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿü0¿ö°Á@@ EI endstream endobj 149 0 obj <> stream 32 0 0 0 0 0 d1 endstream endobj 150 0 obj <>stream 0 0 0 201 127 287 d1 127 0 0 86 0 201 cm BI /IM true /W 127 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & HB$‚¨¶A°+!¨±ø y Ýæx xAþžž‰b8Ž'‚%+ð#†Îˆ˜j½ VzÞˆ¼" ááèo[á>7Â~é7þ‡×Âï×ôÿÿÿjMV»ýxaÃp½{]†— w®Áv\]† pÂáál˜u²4 Ë‘@Õì–űX0[[_ƒµ† _k2Á‚È6dE²>  EI endstream endobj 151 0 obj <>stream 0 0 0 203 125 296 d1 125 0 0 93 0 203 cm BI /IM true /W 125 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¬x!üßé„ôø¿ÿÿÿÿÿÿÿþ'a?¿òl:?¯ø^ ×…á/ü%è‚øKÐ_ Á&©h/Âíh-¬Xõáô¼Ð^/¯/ zø ^ø^‚ðAzøAz áx%áãë…ÁuÂþ¸.¸\á®P EI endstream endobj 152 0 obj <>stream 0 0 0 74 123 171 d1 123 0 0 97 0 74 cm BI /IM true /W 123 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔRá¿Èf áÁ„?Ðzzz òa]{Òo[ÑH<„ Àø@ø@›Ò÷¤ýøO¤ý?Þ—ï×á‡Âãÿ¯ÿÿÿ[ÿ…&¿ð¼:íwû]ëµÛKƒ Úì4°ÿ!¤-’`]dö©„þŸÿÿýïyÁX?ÿÿÿÿµû[P EI endstream endobj 153 0 obj <>stream 0 0 0 0 90 86 d1 90 0 0 86 0 0 cm BI /IM true /W 90 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ªu i¥y Á,"P>< ðAè=?ÓÐxOD O^úF4Iƒw Aþ oAá?@Þ“ýðŸJú~Ÿ_áôþÿôÿÿÿý¯&¾¸kÿý„ûkÚï]ü4»]°^[øa„¸0Apav@Á;µµ†¿amml,_† ,2$² Jò•ü@ EI endstream endobj 154 0 obj <>stream 0 0 0 110 90 189 d1 90 0 0 79 0 110 cm BI /IM true /W 90 /H 79 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Á83ü) ¹àƒ=Bªz§þ·…þõø_5¯¬(~>¿ úoAéäuþýÿÿÿ¾¿“\:ÿ׿Â÷ uÿm.þî— .õØ\6— Ø]’aœ-ë «b¿|5°[XkðÖÁa…ƒ†ä•ä5+€€ EI endstream endobj 155 0 obj <>stream 0 0 0 205 121 304 d1 121 0 0 99 0 205 cm BI /IM true /W 121 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`X zqy|ü ôôÿÿÿáðÿ¾ø>ÂÚý¬ÚØ[_Ð5Û^×`ü6í¬š¤ÚüíÑ­p`ƒa/ý´¼…ÿµí{^ 5°¼¼ü ÚkM¡ðÔXKAk¥¯XKK]¥×XJ'dàþÿÈ`x4ÿÿÿÿÿ“TšÚk Âþ  EI endstream endobj 156 0 obj <>stream 0 0 0 0 155 90 d1 155 0 0 90 0 0 cm BI /IM true /W 155 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID & A¬‰W‚„z§„™Ã7´ÈÃåB„ùN‚8„$²ƒ)Â|áR/ y‰|0¡ZgbBɪAd³Â[P¶ˆa„/ ¤ ´-¢ À¸aAa„," åž EdAq•ƒ)¨3ÁAXž x"  ðA%`ËÁž•#ÁPx “Á@'|/D¤‰pž)À†?"€~p©È(N5!ðv¸aIª A„ÙÔ ‚¶†x Å‹_°°ÖÖX0_†@ð(ª  EI endstream endobj 157 0 obj <>stream 0 0 0 79 127 170 d1 127 0 0 91 0 79 cm BI /IM true /W 127 /H 91 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Á8)ž ¹¬ x_ §…õÿ×Òõÿ Ð/„?Ä \hò  X[!¬)…È5Iªý…ò¸apØ"+{¼>—`ˆÐc[a¸ab@€ñØ\–àÂ!·^Șm•aŽ…°‚`°½BA§¦  iáƒÿ@Â*Äò0`ea¯A醓è<'¤iz Ap¿„^ .šÆA, ¯%`ú BÁö°KJÖÒ†‚äa…&¨0H\¨ˆ.7Çá¢Ëô; ­¯ÚÚà ,0¿ ,‚` EI endstream endobj 158 0 obj <>stream 0 0 0 115 123 191 d1 123 0 0 76 0 115 cm BI /IM true /W 123 /H 76 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`8 zqÿÿÿÿÿó´á”|PÁý;OOðƒÿÿü0¤0+ÿû^×µàÁxÿÿÿÿÿÿÿÿÿÿíIª_†Ðó  EI endstream endobj 159 0 obj <>stream 0 0 0 98 87 200 d1 87 0 0 102 0 98 cm BI /IM true /W 87 /H 102 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<ƒÓ‹ÿÿÿ¸l;ð_Ãï¾þC'ùzöáÿ¹šÿ&«]ëÿ\GõÂüßé…ÿN¢×õÒý,.ºX^ `”Iƒïÿÿù ÿÿÿÿÿÿòj“_í5´Ô@ EI endstream endobj 160 0 obj <>stream 0 0 0 0 90 96 d1 90 0 0 96 0 0 cm BI /IM true /W 90 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±@þŸÿÿÿÿÿÿùÙ¨Ãýƒáðø}ïÞïaïýá èÿÞ‚Pü,ë}(Oûzÿ_û¬>¿ÿÿÂÛÿÿ…qÿ×ëÿëÿÿ×_ïëëù5ÃשÄ|.ÂAw¥¼/µ^×᯳È0JÇï_õ½ø~¾šÞXÐ`º /ö‡°ÂÁ…†P   EI endstream endobj 161 0 obj <>stream 0 0 0 78 85 170 d1 85 0 0 92 0 78 cm BI /IM true /W 85 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹ é<7È°ƒÓÓÿÿÿü=á…íCV0­xaZ†¨aH¶°ÃŒ]…ÌÔ0ÒÉªÓ þ\a&± ãðÂk ÂÃ[ ôý‚dóz ðƒŒAþ §áŤß&­ðA:Aôâ Ð~ƒ§è:Á:t áÿÿÿû_&©~Xa @ EI endstream endobj 162 0 obj <>stream 0 0 0 78 87 170 d1 87 0 0 92 0 78 cm BI /IM true /W 87 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & y™„„ƒï ÷ÿßÿÃÿx<ÿç¢þŸáEø_þµýzý-pºZð´C]k ák_ë!¬pK ÐPaýÿÿÿ!_ÿÿÿÿÿÿÿÿÿþMRki¬0ƒ  EI endstream endobj 163 0 obj <>stream 0 0 0 213 17 296 d1 17 0 0 83 0 213 cm BI /IM true /W 17 /H 83 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦x¡Óÿˆÿÿÿÿÿÿÿÿòk…ûX`  EI endstream endobj 164 0 obj <> stream 52 0 0 0 0 0 d1 endstream endobj 165 0 obj <>stream 0 0 0 96 87 204 d1 87 0 0 108 0 96 cm BI /IM true /W 87 /H 108 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<?‹ÿþw€AÝÁÃîï¾C>@¡?ƒû“T}.õÿ‡®"¿áfð¸Aþ¿Qk„°¸K ª£¬ƒj¸®¯ƒ»¿¹ ü9„ðrj—û]®=›Â ?ÿJ-p¸K ~AT&Aµ\AÃûÿÿÀ¯ÿÿÿ&©5þA… EI endstream endobj 166 0 obj <>stream 0 0 0 243 85 269 d1 85 0 0 26 0 243 cm BI /IM true /W 85 /H 26 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¢‚™ðƒ zié§ÿúiÿÂÿÿ&¨ ×ûMþÓ[M`Á†`  EI endstream endobj 167 0 obj <>stream 0 0 0 0 135 96 d1 135 0 0 96 0 0 cm BI /IM true /W 135 /H 96 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xŸ=>stream 0 0 0 0 97 71 d1 97 0 0 71 0 0 cm BI /IM true /W 97 /H 71 /BPC 1 /D[1 0] /F/CCF /DP<> ID &   ä3§Â †e4 ¨‚h?ôÂM¦ž©á¼ƒ_šÂ0ˆb‡ @ðƒzÚß ô›Hàž¿}ôºoãúáa0ýþ¿ÚÿãÃaÿÿþÿÿ_ÿÿþMP}~Óûÿü:ÂøkØ_¹ž×uÒÿö &ëµ°^,ì$à lq]O»_í5´ÂÚ ,al3@Ùü0‡ ¡ EI endstream endobj 169 0 obj <> endobj 170 0 obj <>stream 0 0 0 0 103 82 d1 103 0 0 82 0 0 cm BI /IM true /W 103 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¬P ÔÿðƒÓý?Óý?ÂôÿOOÿOˆAüŽºCzß_O­ÿ ƒxI‡ÿO¤Þ·þ“è ßO…‡­ôý>·Óëz7ÿO„˜zßúMë}?>·…‡Óé7ÿO¤Þ·þ‚ ôøX}>stream 0 0 0 240 64 273 d1 64 0 0 33 0 240 cm BI /IM true /W 64 /H 33 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜T.5øAàžzx'úzè«G¯Â‹å@}ྂëë ^šÂ_MG.°ž±ª`¨dÕ¬5†@ EI endstream endobj 175 0 obj <> stream 59 0 0 0 0 0 d1 endstream endobj 176 0 obj <>stream 0 0 0 0 121 95 d1 121 0 0 95 0 0 cm BI /IM true /W 121 /H 95 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x*9Ã, ÿOÿÿþùôq`ÿÿÿ7ðƒþ/ÿÿÿÿÿÇÿü†ƒOÿÿÿÿù5Kÿá…ÇÿùÃ4Ä/õÿÿÿµÖP EI endstream endobj 177 0 obj <>stream 0 0 0 208 121 302 d1 121 0 0 94 0 208 cm BI /IM true /W 121 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÊD$†Ð®CT ÖK‚‚øAàƒÐ<' ÿˆª8Ž#ˆ=½DFðˆ5ÁlÑH Aõ¾>‚ú„ ‡Ð>·Óé7Óðƒé7ÿ_¿O§ÿ„ÿÿÿÿÿÿÿÿÿù ŸÿÿɪM†a EI endstream endobj 178 0 obj <>stream 0 0 0 0 121 97 d1 121 0 0 97 0 0 cm BI /IM true /W 121 /H 97 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`YB_ñdUáúÿÖtGÅÿ¡áäÿþCPÇÿÐÿÿÿÿý…þ .CoOÿÿÿÿÿÿÿÿÿÿÿÿÿÿüGÿü†ƒO™¯ÿÿÿÿþMVšÞšÁÄ0±à EI endstream endobj 179 0 obj <>stream 0 0 0 0 127 88 d1 127 0 0 88 0 0 cm BI /IM true /W 127 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡šN äYȬ>stream 0 0 0 103 121 195 d1 121 0 0 92 0 103 cm BI /IM true /W 121 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xf•?Óÿÿÿ¿ƒ6Ž/øˆ?ÿÈ+pƒÿúÿÿÿÿý¯ðÂäÿÿÿÿ›þü_ÿÿÿÿÿÿÿÿþ#ÿþCÁ§òëÿÿÿÿþMRzÿÃ`  EI endstream endobj 181 0 obj <>stream 0 0 0 0 127 82 d1 127 0 0 82 0 0 cm BI /IM true /W 127 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & `ì01!Ÿjÿ!öQ„ž§§ú|‹#ˆâ8Ž#ˆâ8¿ÿüâ鈈ˆß)óÿ„Tàáð@ü'éúã …Ýû¯ÿÿÿÿÿýþ¿¾¼š ëÂö½¯ Ã.RçäX|{_µÿµµ†Ö__cX0Y!¨± EI endstream endobj 182 0 obj <>stream 0 0 0 97 124 198 d1 124 0 0 101 0 97 cm BI /IM true /W 124 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡Î x5ü'‚뮿¯á~9­Káb<È<?†Ai$ˆpä, &¨Aðiÿ†{aÁ§Ú{iïïàăÿ†aàÁx4ùQ ø0ƒýïàÓôûÞÓÿþÓü0ƒÿÿÿÿ#Ï„Óÿôÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!àÓÿÿÿÿÿý¦¶šÃ0¿€€ EI endstream endobj 183 0 obj <>stream 0 0 0 78 121 170 d1 121 0 0 92 0 78 cm BI /IM true /W 121 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±0†T ÿÿ\èŽ#ˆýÿÿÿÿÿþ@ðÓÏÂOOÿÿÿÿÿãÿþCÁ§ùšÿÿÿÿÿäÕi­é¬C  EI endstream endobj 184 0 obj <>stream 0 0 0 78 121 170 d1 121 0 0 92 0 78 cm BI /IM true /W 121 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ _ñ~@ðk¦ŸþŸàþ (0¼0¬PÁA…á… PÁHx0°~aa°S5ƒ MV† z 0ˆ¿‡ y,D0aÃ_àÂk &°`ƒ !Ãúáüx x Èb™xiá?äOú`bÂ7È¢ð| Ž‹~< N!àÂp@áàÂpAÂÁ8X_ÿû_òj“^;P EI endstream endobj 185 0 obj <>stream 0 0 0 76 121 169 d1 121 0 0 93 0 76 cm BI /IM true /W 121 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x9 $&Ÿàéééáúzz*ÑÄõï¡àð§Öú}áÿI¿úú}oOÿÿ?ÿÿÿÿÿÿÿËÏ„ÓñÿÿÿÿÿÿˆÿÿÀðiÿÿÿþMRki¬0ƒ ø€ EI endstream endobj 186 0 obj <>stream 0 0 0 102 127 194 d1 127 0 0 92 0 102 cm BI /IM true /W 127 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ®hŽŸéÿÿþIT†X¾ êŸÿÿÿþ¾í|/ðá­‘e ÖȲÊ4I‚A¾AƒÞ¿ÂÃz ÁaúÛÒßøxKøS5ïOÓ×z¿ñ_ÿö¿ú“Të†ÿðÚ µívÒÿa„»^]´¶ ÿ 0‚Ø0K† ²6 «dTVõ†JA€¶+ö°Âà ,0¿ ,,,ƒ`WäE²  EI endstream endobj 187 0 obj <>stream 0 0 0 205 121 299 d1 121 0 0 94 0 205 cm BI /IM true /W 121 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x+§úÿÿól–ñÿ”àxey5D¸ ù&ƒ`ûß‘Fù4×"€ÍÃ"ÀV² ƒƒŽ  "À± Ò+ƒ"À¥Á‡TäX$pÁä°`ò B\ ^àøAgÓ ~5"‚Á‘W x¢X> àßäàä ¤ðãÿä0<ÿÿüš¤ÖÓXa@ EI endstream endobj 188 0 obj <>stream 0 0 0 0 60 56 d1 60 0 0 56 0 0 cm BI /IM true /W 60 /H 56 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ Š¿“UÂè?‹ù5×ì,ŠÈÚ(\z§±|qÿÿÿüƒi.5‘Bóè?ø¿&ºý…ø|†\†µP EI endstream endobj 189 0 obj <>stream 0 0 0 0 127 82 d1 127 0 0 82 0 0 cm BI /IM true /W 127 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & \¨Ãƒüx@È5Šh0@ðOÐiþŸO§Â&üâÊ}h—ð´6×ß OÓ`ý9é4ƒÌQÓj÷xW~ û¿PÞ=¿÷êØ~ü?ÿmÿ÷ûïûÿß&«þÿûþÿ×Ãðþ®Û_ýÿ».õì7ì;KßÛ†— °^IƒXk²6D˜«ƒcö°XZa¬/íl-…ƒ_†š¤Ápˆm—Á¢ À@ EI endstream endobj 190 0 obj <>stream 0 0 0 210 124 292 d1 124 0 0 82 0 210 cm BI /IM true /W 124 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡šBâÈü ðá< È)~ƒ?ôü&>ŸEZ8ƒÿüI¤è7ÂþK‡ÒáôßAü>—鿇é?¯ÿ ß…ÿÿéñÿÿõÿÿÿúÿþ·ÿ®MW÷ý/ÿøa„µÿíÚþÙ)®!…ÚÛÿ‡ÿ~íoî ,0‡ðøk°a@@ EI endstream endobj 191 0 obj <>stream 0 0 0 0 127 88 d1 127 0 0 88 0 0 cm BI /IM true /W 127 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÐtÃ<ƒÁ„éÒ Í/ Á„Âz`ÿ¦ž˜ODš8ƒOü'„¶ƒàþ6ºõµé‹ÐL•Ó" ž˜ o ÓëßÂ~˜_ÓáÐaÿÿô×Þ¿§áÿÿÿÿúþõÿþMW¯þõÿð×ÿá„Xaä={?]ëµî»4×bî·û­áwýaÚÞ·kØ/÷ ‡|5ƒ_†  EI endstream endobj 192 0 obj <>stream 0 0 0 76 124 174 d1 124 0 0 98 0 76 cm BI /IM true /W 124 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x)tžŸÿÿüàÚ2@ðÔQ x4HB~@ðØQ x0Y xp¹ÆI ~·ä$7›œ‚¾ÃÚÚ|í솮ßkØü†fûQ¾äßyÛ†YšÈ&Ýë"lÕë'»ü#±Á_XD̲´ùTŇÉ` `< <3J€<5À<J€<5ФX,Á‚‡* x¤Õ ?ɘ-Cá“@V‘6jŸ;àkyߧ FûQ±ù ÍÈ5ì;ár»þCkiäö&ç ±¸ò F’ërŒ’@ðárƒž@ðØQ xe È R†¢‰Á´g<Ãÿÿý­­¯€€ EI endstream endobj 193 0 obj <>stream 0 0 0 184 125 276 d1 125 0 0 92 0 184 cm BI /IM true /W 125 /H 92 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ _ñÿFá´Uá©0<H¨ P(* x™ZÙ4c¸“º!Þ€¯ˆÒøjgdL‰½2Øx?;¨;ÍgjÌš­N†Y »Þ² šb9ë^C1Wü†/ ØSÈ+‰rùÁÁ>A\Kl)ÿ!¤ Èf*ò Öæü‚æšy »þ´ò{踎óºàŽÃ ÜÀĉ¹ä÷ñÎÄiÞ€®w@$;€Y&€Í• =•P>stream 0 0 0 0 124 106 d1 124 0 0 106 0 0 cm BI /IM true /W 124 /H 106 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x2…§úÿÿþCOjüƒFÀà°XX/…­`µõõ„F€ñ4Iᎂè/ô¼®—ÚÂý5 Ǩþ¿ÿ¿“Tü᧟ð §éï·þÁûðûá÷á >stream 0 0 0 0 87 94 d1 87 0 0 94 0 0 cm BI /IM true /W 87 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xp´ÿOÿÿÿÁ|@ðÜ$bH,¸Ÿ‚È+HmAd4Õr.°DXò‚ür¾•È0Wä\3àˆ°(ÈAyšÉü OZüŠfò”€X Dð) kȨ|šä 2$˜2ÿ²P aïáƒò]< å\+ d6 ð`ù ÁÈ5pc× ƒÈ+y!h<‚À@ðÜ'=ŒƒÁÿÿÿÿµµµ EI endstream endobj 196 0 obj <>stream 0 0 0 0 121 73 d1 121 0 0 73 0 0 cm BI /IM true /W 121 /H 73 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<58@ÂüZÿÿÿÿÿÿÿÿüÿÈ`x4ÿÿÿÿÿÿÿÿÿɪM†0P EI endstream endobj 197 0 obj <>stream 0 0 0 0 97 69 d1 97 0 0 69 0 0 cm BI /IM true /W 97 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ØD¬†žA ³ð@ðƒÓÁÓü"M<$FAC^¨úðôBÁ ¾ˆ€èA¾ ô?@Þ}%o„OÕzì=—ÿ¤­ê¿úPðµÿ×õÿÂÿÿ…þëÿý{þë×¾MV^Ø_ë¶KØ0½Áqx®Ã v½­Úÿ¦¶…Á0± `Á~AcX€ EI endstream endobj 198 0 obj <> endobj 202 0 obj <>stream 0 0 0 0 152 82 d1 152 0 0 82 0 0 cm BI /IM true /W 152 /H 82 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¤vŸjí_ú 8²{(ƒ8iÃ?ƒNp}§E‘ÄqGÄq_ÿþqbˆˆˆ“å`¿&¨©àì–᳃O†Ÿ~† 7 >á‡Ãáð`ømÿÿÿÿ΋ðÿÿàÿð†¾/ÿÿÚÿÿÚþõà Úö½¯ød)ûȨ2øö¿kÿkk -¬0¿ Û±¬,‚–ÃÈ-,@@ EI endstream endobj 203 0 obj <>stream 0 0 0 0 124 100 d1 124 0 0 100 0 0 cm BI /IM true /W 124 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x)pþŸþ@ðÛ®@ðkI x<0 ä$ƒ9”¾þAWzÈií_ËØ”ƒH`äMŠrö5ÑØ@ÙÎôŒ#¿ x“ eòªrVœàAô¤` ’`xÔ‰àÇ’°<&¨…áþTÊXÃ|™Ì„KÈao!±W aK Ò[ÞCT£!¶%eI'/,« N_ Ê“!¶%ù RŒƒIn@žCa&C |B,äÖ0¸D,…áòTD€ðÊ$Àð. N@Àð!ÉXo•P+“0eÌ5äÕÔ gafü‰²|ƒIãËØ”†žÕÈ*ïY}üƒ9—>stream 0 0 0 104 121 202 d1 121 0 0 98 0 104 cm BI /IM true /W 121 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`Ó =4âÓÿÿÿãÿþC ³ kÿÿÿÿþMRÚÚÚÁ‚Á‚Çÿÿÿÿÿü¼ÈmfxAééÿÅéÿÿÿÿÿˆÿÿÀðiÿÿÿòj“[Ma„_À@ EI endstream endobj 205 0 obj <>stream 0 0 0 0 143 144 d1 143 0 0 144 0 0 cm BI /IM true /W 143 /H 144 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x0jiÄÈÊ°AþAh—<>ÍpƒÁúxOžý4q<" ½á~²8ôA§ÉH6pˆ°+½08zúÞˆøAð0ôëz ô øAð^“ÿ ½&ø^‚~¼/¤ü+×K×_Aè/^¸Ký}x]}uõðº­~¿ð«Âþ¿ëÕôºÿô¿Œ-|-]/ë\%¯é} ´°ºÉªiéz]‚ú a¯×`—¥Ø\6 vál0—`—ava®%¼.1=´¸2 e¸d…Ä-­­…û -­‚Úý…ƒ°°ÊÐA…ødä4Ê2 €Yj  EI endstream endobj 206 0 obj <>stream 0 0 0 83 91 197 d1 91 0 0 114 0 83 cm BI /IM true /W 91 /H 114 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡˜]™çÁp\.—: °Aaph.¸--H2ŸH‚¡~ˆ6p¼$C\O Aù²ØÈf©`µä-a<ƒ5°AÙtø• ™5E(3þòJ|©ƒV/%@Ù²* ŸØ.Ê@SØ\2œ0ÁŠýëú úÂþ–½ik…ÐZ]i`–¸Akø" ,yA¼‚¸¾Ch·òªy²\†b^AFÇȹþA6DÚy=ƒ£±Ãè™~V€¾% ÞTƒJ<‚¼”†ÜŠ‚¼"’`QÖMQ s¨pÍðÝb `–@üfAh¾ p´ ‚þHöx2À@ EI endstream endobj 207 0 obj <> stream 38 0 0 0 0 0 d1 endstream endobj 208 0 obj <>stream 0 0 0 0 64 166 d1 64 0 0 166 0 0 cm BI /IM true /W 64 /H 166 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬Ì Ý4ôÓÖð×ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿþÞûMm5 EI endstream endobj 209 0 obj <>stream 0 0 0 0 97 69 d1 97 0 0 69 0 0 cm BI /IM true /W 97 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¦U†¬†aN@º–àႧ„#Hâ8Ž.Š°ixD@*þS«@ƒ| ü}&ÿÒo§÷ÂPü?ü.;éÿÿÿû^MV¿áþ¿ ×m.×µØ0—û %°a. ‚ ÎRO BÚà kð`°ÂÁ‚Á‚ÈfþCLœ@ EI endstream endobj 210 0 obj <> endobj 214 0 obj <>stream 0 0 0 0 135 80 d1 135 0 0 80 0 0 cm BI /IM true /W 135 /H 80 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`x zqÿÿÿÿÿÿÌ¡‡Ãü*ªúÀðÓ ô¿^¿¯×ÿ¯ÿ×ÿ…ÿÿÿ_ɪ¾ÕbÖP EI endstream endobj 215 0 obj <>stream 0 0 0 123 139 221 d1 139 0 0 98 0 123 cm BI /IM true /W 139 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & HJ[äÕrix@ò»¦‚„žŸá¢.Ž'…áé ¥- LÀaò`‰ 4"t€š°¼*÷ J ú ÃáP}o„¡õ[ÂTý Ÿª}%¾>¡oKÒ__ûéWëð·ÿ¤_ÿÿKÿþ?úÿÿ¯…ÃÿõÿþëÂí­ÿÔš­¯¶—ëÜ0¿i{ûÚ ¶ü5á†%‡”–½ëm #ÛþÛ Ã[µím5ÿ …†5°˜X†°`¿ ,à€YÃ:x€ EI endstream endobj 216 0 obj <>stream 0 0 0 0 135 99 d1 135 0 0 99 0 0 cm BI /IM true /W 135 /H 99 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔUàÿFÀðAè< ðAþ™~Ó@ý4á?ôúô‘¤q>½ù0á`£áÍ×ðA¾‚è?„Ãé?ï¤×÷ôß ÿð¾­úÿýÿúÿÿÇëÿÿÿÿýÿ_þ×ÿɪ××ÿ¿éî^ÿ¯×†_þ‡l.×ö×öÿáöýðíwíƒÃöÇß ~ÂØ[[P EI endstream endobj 217 0 obj <>stream 0 0 0 0 169 60 d1 169 0 0 60 0 0 cm BI /IM true /W 169 /H 60 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡°ì´ ’0à¾N¿à½zÿ¯øKýˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâÿÿÿÿÿ…Ñ u>Ž/…¤"?ÔW×ÿ ÿ‡üš¯ÿûÿûÿû\,3  EI endstream endobj 218 0 obj <> endobj 222 0 obj <>stream 0 0 0 264 141 369 d1 141 0 0 105 0 264 cm BI /IM true /W 141 /H 105 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Øl„ÿ§ÿÿÿÿɪ_øa5Œú8¿ø? ÿÿÿÿò†o.iÿ§ûÿáþÿßÿÿÿÿÿýááõð—ù¥Ø_ŠêuPRj–Âý’ÉÃ(?ÿÿÿÿÿÿÿý®°Ô@ EI endstream endobj 223 0 obj <> stream 28 0 0 0 0 0 d1 endstream endobj 224 0 obj <>stream 0 0 0 0 136 129 d1 136 0 0 129 0 0 cm BI /IM true /W 136 /H 129 /BPC 1 /D[1 0] /F/CCF /DP<> ID >‚φ¡«V?µjÔ¿°­Z“T.GMqëm-††»u†ÒÞ¶ÐXmx~à m¥½m® 4»öÐ[a-ë ®Á¥ß¶–Aaý†Û®×a¥°ÒÃûh,7]…ÛK 4·ö[p»]†ÁµÞ¶ëm.<0·ÚÃXk÷ÚØ[Xk÷ÚëAiauë­-uáa.´µ×­Ö×^´¸Zá/ÒÒë\ÒÅÿòj–ÂÚ€€ EI endstream endobj 225 0 obj <> endobj 229 0 obj <> endobj 233 0 obj <>stream 0 0 0 0 47 20 d1 47 0 0 20 0 0 cm BI /IM true /W 47 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Ö?È&’1( ’¢ E‚“Ÿ A‚jaš  EI endstream endobj 234 0 obj <>stream 0 0 0 178 121 280 d1 121 0 0 102 0 178 cm BI /IM true /W 121 /H 102 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<(=8¿ÿÿùÛ9ß‚–;‡ß}ü† Oòõì=ðÿûÌ×þMV½ëÿÃ׈ÿ¯ ó¦ý:‹_×Kô°ºéaxX%‚Q;5ƒûÿä0<ÿÿÿþMRký¦¶š€€ EI endstream endobj 235 0 obj <>stream 0 0 0 0 86 78 d1 86 0 0 78 0 0 cm BI /IM true /W 86 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID & \À5˜@ÁÓOM>_ÿííÛKýëµÿa„°Ú ýëµÿm/÷­ŠÿÚü0¶²÷®žžŸÿÿkkkò *ðƒÿÓý=Óÿ§ÖÿÂL?ú}ÖÿÒoþŸ[éÿÿ§ÿ„i¯öšÃ0  EI endstream endobj 236 0 obj <>stream 0 0 0 0 47 90 d1 47 0 0 90 0 0 cm BI /IM true /W 47 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦x 8 `é§üZÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿäÕ&¿ÿi¬ `  EI endstream endobj 237 0 obj <>stream 0 0 0 0 131 94 d1 131 0 0 94 0 0 cm BI /IM true /W 131 /H 94 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x§úÿÿþ ಂ IÁ±$@ðkðYÃ(ª@ðn ‚äY`ˆ©ä[‚òå<ƒ1_‘p# '™¬ä ž² …ȸ6a`ˆ¨Hj‹ar % \‰ç \£‚á¼<"´ ðDiƒÑ0°d53@ˆ0(x"L`Ê|ƒŸÂ 4è" ¢]aô2, Ñ1OAøHX—„}dYt@öÃèáJ†<—~È5ƒÈ «v@ðØ3ÓTÈAþþ¿Ã÷íwàÁƒ\ZÚà  EI endstream endobj 238 0 obj <>stream 0 0 0 144 138 164 d1 138 0 0 20 0 144 cm BI /IM true /W 138 /H 20 /BPC 1 /D[1 0] /F/CCF /DP<> ID &± ëûÿÿÿÿÿɪ_î`ˆÄà EI endstream endobj 239 0 obj <> endobj 243 0 obj <>stream 0 0 0 0 135 160 d1 135 0 0 160 0 0 cm BI /IM true /W 135 /H 160 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x3( z ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¬à¤^@ðU' xkùÁ¬^@ðÌ,<©H ¬H/È{y}ÎAczHld‚¶ÕùÍHjlRA£eRö FÅ Ó; ›ä{æØ—ì 2¹Ú€jçiÃZ'a†Üî`Ëçnò– R°ò¤‹%€x?’€<‘ < Ê@<$Õxjlèƒoö||ÿÿÿÿÿÿÿÿÿÿÿÿÿÿû ö  EI endstream endobj 244 0 obj <>stream 0 0 0 162 138 262 d1 138 0 0 100 0 162 cm BI /IM true /W 138 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x! H`ò ãY‚Œ 'ä‰2 ‰y MhÜò÷§äÙ|‚lžG±¼Û ¥_ø;4bRƒ/ܬ^T·%€¯’€$È,þRá¾MQ—g@A6Ÿ#Ú~v@Í´aøøŽŠRÀðr°†r¤‚XƒNJðÓ"@x6”€x+“TDàog@<~φ@n  EI endstream endobj 245 0 obj <>stream 0 0 0 183 138 324 d1 138 0 0 141 0 183 cm BI /IM true /W 138 /H 141 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹àÈèèX”àx•x) <r&ƒa(ÃL–àÒBÀðÊ$€xlÊØ šáð3º蚣°À³áÔöv ³µ`«vLd>ÉäØ<ƒ}—Èeì¿;H$¶“!©´ŸÎÆË!àþüuùÙþAFßË3ÿ ÔµÈk*r`¼ƒ!W p)þ@¬=(ä~ð¾¾ z_ø@½/ð‚ôÂðKÐ/ á//¯@¼õð‚ôÂðKÐ/ á//¯@¼õð‚ôÂðKÐ/ á//¯@¼õâ …×_ÁuÂáa®Ð.°Aiapa.‚Á®Ð.°Aiapip´‚ø¨*…\B…&¸_ EI endstream endobj 246 0 obj <>stream 0 0 0 0 143 127 d1 143 0 0 127 0 0 cm BI /IM true /W 143 /H 127 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x‰òF˜O ßþA²«Èj„ ¾oþ6ôßOÓ½0ÿáú~·§é¿*ï„Bú ÿúL0Ýþú~•ÿá ïÛõôÿë~¾¯ëÿëë_þð¿Ãøpµë¯ÿ÷þÿ×ÿúŠýþ×ÿ¯ývëÂÿÿÂíwK‡úúX~î» ë¶‚“U°¾õða.Ø`¿×µõà -Úÿ붽¬; °×þ]°[ƒ à ²‹?öÿíÿ}íþ‡ûþÂál/æ`x,ØP EI endstream endobj 247 0 obj <>stream 0 0 0 0 105 154 d1 105 0 0 154 0 0 cm BI /IM true /W 105 /H 154 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xi¬……‚øX-a`—á, E‚øQÒá`‚‚ᄠ¬Z…Á„‚ apaÁa‚ ‚„Z‚ „  -t Ap´ 8R0êF€ð„°ŠÀ)¸k†™Ø@ ìLgbñ5Ãü>EØ” ä3vDƒfÇ$$=È*¬á F¬. ap@°‚áa‚ ‚  ,., ¸XA`k„ ,X\ °ApZ  „. , X\ ´ÂÐ(ùìªÁ3 ³ºQØ€Øv4;‰®ûîðyö®C/zy mă"ÔX,æ+ x.£ò†Pp EI endstream endobj 248 0 obj <>stream 0 0 0 0 139 45 d1 139 0 0 45 0 0 cm BI /IM true /W 139 /H 45 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ËœàÌŒà³VŸõþ@ðÌŸùÁ½\à¸>@ð¦9ÌOg)ýd|"£Ye¯ ØhÁd57œ ¡È4oòöF@§È&Óä{OÎȉ¶Œ#¿ï±Àñ X+xh*@xeÀ<²P†¡Ãh¤Áš¢ ‹:àWö|2€ EI endstream endobj 249 0 obj <>stream 0 0 0 0 139 113 d1 139 0 0 113 0 0 cm BI /IM true /W 139 /H 113 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡‘›9ÁiÀœf@ðe'äA©ÃXZ@ðj,<2”¤ „¾@ðÂ\âl|ç¼È3휫ø,‚žÃ‚¶ÈÈ6m>COi2 ;ü#¾Û†‡‚ÃÑØášôLÃIò¶ œZW ½oAÑ(@˜|‰’ðˆP½`¸OªÞK†uÑNªé%é¯I/ ½} ’ôºþ—Ö¾h%ÿÿ …KëAÿøT£ú×ÿ¯^Â^¿ú_ðÐ^—…ípé}v°—k°Â ìúÛ pÂ\2 ¤ÕX2 ‰|WµØa{ ÿ¯aaÚá°^ /û`¼0·EAW†U ßä¶?ÿûð¶|  EI endstream endobj 250 0 obj <>stream 0 0 0 0 47 68 d1 47 0 0 68 0 0 cm BI /IM true /W 47 /H 68 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¶ *²(!M$b&P? Jˆ) “œ) ª5†lÿÿÿÿÿÿ!¶ÿ•Y È&’1(…%DŠÉ€ÎƒÕÃ4@ EI endstream endobj 251 0 obj <>stream 0 0 0 190 47 258 d1 47 0 0 68 0 190 cm BI /IM true /W 47 /H 68 /BPC 1 /D[1 0] /F/CCF /DP<> ID & c!°Ÿ…ÀÜE(…󂕈èmGþh?Rk— ¸ÿÿÿÿÿÿþC6¼€r øY ÁdRˆ_8 ùQH΀žhšåÃl@ EI endstream endobj 252 0 obj <> stream 91 0 0 0 0 0 d1 endstream endobj 253 0 obj <>stream 0 0 0 0 167 164 d1 167 0 0 164 0 0 cm BI /IM true /W 167 /H 164 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x.F€¢@ðå‚‚‚„ÿAáÊ´â ´ÚÑGÄá…ûµû´Fù Í¢¡ÚAPÄ0·hnÐA¾=Á=¤pÖäÕ0}¸&þƒàÚMíÐ~ÞÚL=¸O‡§Ø«Ýþöƒí7‡öí?ÞþÓöÃíü;Û|7ÿÛá;áýý¿úwßÃû~tOðÿ·û~°ïAþáûýþÿþï÷ûýÿü?à í|ÿ…ßzÿÿÿíÿzÿµÿü=p×ÿû]ëþÂÿ¶‚ÿzíxkþÚ]…Ã×®Ýv¼5ÛAo]…ÛK°¼Xl.õ¶\ðÁvK`ÂXzØ2£["A˜%¿b¶°ÖÖÂý…ƒ[X`¶àÖ,,,/È déà EI endstream endobj 254 0 obj <> endobj 258 0 obj <>stream 0 0 0 108 141 282 d1 141 0 0 174 0 108 cm BI /IM true /W 141 /H 174 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x’ m‰?Ó‹ÿÿÿÿäÕ/ÿðÂkôqp~"?ÿÿÿÿä ß \< Óÿý;ÿßÿðÿþÿÿÿÿÿÿëÿ Âÿÿ¥ásKð—õPª«‚“T¶ÎÉdÿÿÿ xýëýïùÃ7Ãáÿ§ýÿÿÿÿÿÿÿÿýáx_ÿúõõô¿Í,ÂüW «ª…&¨-…û;Uò†Pÿÿÿÿÿÿÿû]a¨€ EI endstream endobj 259 0 obj <>stream 0 0 0 0 17 136 d1 17 0 0 136 0 0 cm BI /IM true /W 17 /H 136 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ÑÂþ!ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ“\/à  EI endstream endobj 260 0 obj <> endobj 264 0 obj <> endobj 268 0 obj <> endobj 272 0 obj <>stream 0 0 0 0 121 93 d1 121 0 0 93 0 0 cm BI /IM true /W 121 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡–HÀ‰åðDÀ2ˆÐd3D„@ôÁ„Ðz =4ýBziòMMp¾ž ß ÀƒÒD¸Ÿûéˆ }Ðo¦ úhÃ_÷O°ž¿§Þþ|?õÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿâ?ÿä0<ÿÿüš¤×øað EI endstream endobj 273 0 obj <>stream 0 0 0 182 121 280 d1 121 0 0 98 0 182 cm BI /IM true /W 121 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x+žtžŸÿÿÿ‚ÂÁ|,àÐ’ á`°°²ððƒ¦‹¨°¼\"P>ÍazÁø_Á…‚#ÁD(\ì0T wà¤wp wà¤v€VÃÖ ÃÃPƒCGáƒ>ƒœ0ø~ ‹Òjaþ;@ðˆ<> endobj 278 0 obj <>stream 0 0 0 174 135 316 d1 135 0 0 142 0 174 cm BI /IM true /W 135 /H 142 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xdR~@ðÖ<3Jà°¿æ°¸g+ø½ü?÷ÿßÿÿÿÿÿÿÿÿÿÿÿ¬,ȃ%aÁµ@²†˜àÒ% xe ùÃadà¸\áI$ÔùŸZÜHnr {A_uÈmlv‹!«´r [G!—º°ÈlÞ¼‚û«ÎÐy ´r[F<š£±µÎênv€Sç|ìpZÿ)`ÊÈ\ªáyÁ~J€ðÙþE@ðÊälŽRá§È0<9¬_ò@ \/^—ÿøA£‹ÿ×ýzð¿ëׯá…,MP@‚Ä ä`h<3aá— Árif­ @ EI endstream endobj 279 0 obj <>stream 0 0 0 0 113 66 d1 113 0 0 66 0 0 cm BI /IM true /W 113 /H 66 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹à<h8¿ÿÿÿÿÿ…nÿU ®P†u¥ý~¿Âÿ×úÿÿÿÿù5J¿Ã ñj  EI endstream endobj 280 0 obj <>stream 0 0 0 0 113 84 d1 113 0 0 84 0 0 cm BI /IM true /W 113 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Ð °/ø°ƒÂ‚OAþžÂ}è«Gÿ@…‡„K_@ƒz@ßý>‚o è'è0ú}/Iõ¾„¾Ÿ_§Öét¯ðzô½ º\/Kþº]Ô.« õézIkð—KøQKIaia%ô –ˆ„ ‚êJ‚_PT“Uk„ÂÁ¦ üX(€ EI endstream endobj 281 0 obj <>stream 0 0 0 167 171 294 d1 171 0 0 127 0 167 cm BI /IM true /W 171 /H 127 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±ÀÖ8ƒ(Zh0œCM?ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿû_Þ¿ÿþÑõÿÃõÿÿÚÿû -ÿí¨ÿÚï_í¥ÿk°Â]®õþÚ]®Al0—ûim¥Ã °ÂXm6¯^à { |0¾Ã x`Ááá{*Âö@ÇàÁxaI¯„ ôXˆa~@ð.Q<3@²†p EI endstream endobj 282 0 obj <>stream 0 0 0 148 123 263 d1 123 0 0 115 0 148 cm BI /IM true /W 123 /H 115 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±Ø€Ô„vD88pù5Aá˜GÄqGÄqGÄqGÿÿÿþñðoƒ ÷¾Þo~íïøoûß÷ï÷áþÿýþÿÿ¿ÿÿÿÿÿ×ëÿÿð½ëü/×ô¿ô¿ ×ékú ^°–ºá,áa,á°F}”iEB… ‚“TΈ € EI endstream endobj 283 0 obj <>stream 0 0 0 0 168 86 d1 168 0 0 86 0 0 cm BI /IM true /W 168 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & z" } NµeÞdw§äv!«³Gba§<?ÂOÈš!hâ8Ž#ˆ }ìyEXÊ—ÀÀÿE8 z …Z@ðÕèá¤%©Á [ DT x)ëá< RƒÐúEA>@ð¢ŸPOä—¨ Wä žˆ- ?‚"¯ø/ȉ~A”Kð_Èm ~ŠÏäh¾CHKì†h’ø/¹âÕÙWäl |‚ {dQ$f ĉà£ÉP\2(ƒBÂ"@x5ð@’É àˆ¨k‰á­ê¢ RRŒ‚à™ˆ°)Ôb¤Õk à. kö°ÂÁ‚à ìÀküƒnÁäw¦A—y'ZÈ…¾  EI endstream endobj 284 0 obj <>stream 0 0 0 149 123 264 d1 123 0 0 115 0 149 cm BI /IM true /W 123 /H 115 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡¨ Ó´˜N á-ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆ-ÿÿýàxl¢œX@´½ip´ºÂþ—_ ¿^¿­¬/õÿ¯ð¿ÿãëÿÿÿûäÕÿÿ‡¿ÿ‡þÿoÿoø{þ߆ûßa÷ÞÃØ<>ÃÙ†Ì죷·àðÖCSeà EI endstream endobj 285 0 obj <>stream 0 0 0 0 186 105 d1 186 0 0 105 0 0 cm BI /IM true /W 186 /H 105 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ ‹ðN°°X]`‚ \XAp°‚ÁÂè,.°‚ÁÂè,\ Â ¸, Â„ Âà‚ÂÂÁÐX\ ,à°‚Á×,à°‚Â Ð, ºÁ Â ¸X °‚Âà‚Ð.,Âà‚ÂÂÐX °¸A`‚à°‚Ð, h. !BàªMp¶  EI endstream endobj 286 0 obj <> endobj 290 0 obj <>stream 0 0 0 112 124 195 d1 124 0 0 83 0 112 cm BI /IM true /W 124 /H 83 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±à<áà¤Tg ¬7üXAàá9¢ üÿÐ~Ÿ§Ð'ͪ hâüý B ú)€ü/è“ÐA¿„þ‚ú[ð~“Oé~“úÃø_„ƒý~“úW×è/×ëá'ëõú_A~¿_ }~¿I|/¥ú¯ ¾—éüB.—פº^«„A›ÂøA„½ ½%×Ô._ýu]WL.«þ MVƒ½0·ÉÃ,@ EI endstream endobj 291 0 obj <>stream 0 0 0 244 65 277 d1 65 0 0 33 0 244 cm BI /IM true /W 65 /H 33 /BPC 1 /D[1 0] /F/CCF /DP<> ID & n Aþ½È³X ÖŸúa-¾ºh/¿ôkKÂס?$`x®¶ºý­‚Úà `¿ ,Pf k EI endstream endobj 292 0 obj <> stream 116 0 0 0 0 0 d1 endstream endobj 293 0 obj <>stream 0 0 0 0 55 33 d1 55 0 0 33 0 0 cm BI /IM true /W 55 /H 33 /BPC 1 /D[1 0] /F/CCF /DP<> ID &  — !'á=Á==O  ë\—ø.‚á}t¼/L/‘Ö?¡­ªfÞ¤Õ!‚ÿÇa`Ô@ EI endstream endobj 294 0 obj <> endobj 298 0 obj <>stream 0 0 0 91 121 191 d1 121 0 0 100 0 91 cm BI /IM true /W 121 /H 100 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦`Ó =4âÓÿÿÇÿä0<30YÃ@LáƒÂà—Rj‘ئÑз‚àÁZ)Ä.EC<ƒ0¶Ad[È)”à‰@idP5 ˆ˜mB¯ `Ë*c"kÁò 2üÈ*àðȸkA’€Òƒä ÅpdX2²T äŠrå8>^<7 œ8²ÂùÅÁò† d ;< ÿÀðiÿÿäÕ&¶šÿ €€ EI endstream endobj 299 0 obj <>stream 0 0 0 100 121 186 d1 121 0 0 86 0 100 cm BI /IM true /W 121 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±ÀÄ d ?8°]? X/K tGÅ_ÁB"Ö XZ K…ÁÐ\/ pzè. uáéx\]Âð—®‚à—^.—…ÁÐ\/ pzè. uáéx\]Âð—¬B× p`U…„«ák¬/„Ô*“Tƒ\á… EI endstream endobj 300 0 obj <> endobj 304 0 obj <> endobj 308 0 obj <>stream 0 0 0 0 135 146 d1 135 0 0 146 0 0 cm BI /IM true /W 135 /H 146 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x<H E†P'…ÿÃ>‰ ã!àþßßÿÿ÷ÿÿÿò‚Žäÿ x=\âädùp>AdoÊ@ÚÈä@ùANáëþH0¿ðÎxµßÿÿ®ÿÿÿÿÿÿÿ×…ÿäFr Š9 0)ã Ò%þƒÈe !°³\/¤œküæxü‚žÃWÝ~Ck`ä5v‚:H5n®C/ur 7«çhäu ‚ûGÈ]£ä·W‰ÚW— ®MQÝ@­ó´ŸÎø ?üìpZùKÿ•A@ð/ù*Ã7" xidl l¤Ão ÀðdüÖ¾HÁg …ð¿ÿÿù5A|@ EI endstream endobj 309 0 obj <>stream 0 0 0 164 91 267 d1 91 0 0 103 0 164 cm BI /IM true /W 91 /H 103 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xÉÂB„ôõÈfeÿ.tð¾ _ |)¯è«Â î§èO§.ð‚ëÒôºéW Õ}p”/ú xJ5Ö.°‚Èë8RUIöC\O!¤Sd3¤Õ2 x2[ÿƒ%³\1}þÃÙÜ/)@ý’PÙÿd,2Ü2T {"­†L¦ —L¢ ð`³È`Í„ ¥Õp]*áz ~z Õ}E.–ºX/ ",%¦ vÔ“U࿸Ð_áà¾Óãµû[   EI endstream endobj 310 0 obj <>stream 0 0 0 107 62 132 d1 62 0 0 25 0 107 cm BI /IM true /W 62 /H 25 /BPC 1 /D[1 0] /F/CCF /DP<> ID & Ôj0“DÊ@‚Œ'‚ Ð}ŒÑ¨;Âêœ \ ¼.t¸_ ´Õrjkü4ÂŬ0  EI endstream endobj 311 0 obj <>stream 0 0 0 201 23 224 d1 23 0 0 23 0 201 cm BI /IM true /W 23 /H 23 /BPC 1 /D[1 0] /F/CCF /DP<> ID &£3žƒý?‹ÿ&©~×ì-¬(€ EI endstream endobj 312 0 obj <> stream 39 0 0 0 0 0 d1 endstream endobj 313 0 obj <>stream 0 0 0 0 117 78 d1 117 0 0 78 0 0 cm BI /IM true /W 117 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID &  ØeA“ù(ƒÂ§úÞ«…¾Ôº$OÁ§ÖCüú ‚g’ôž¾„V?ª ýkdîÈš¥k“]×ivm}-ëa ·Kü6Ã:ôˆÆ õáÐDémH+‡Ô†Ò{„ˆkºD4Œzî‘‘-Â!š-Ôr¼Q ¸rTëè‡Yò*_›cì|š•°¼Yù¥ŠÈe¥ùæ^Aƒ/•Óä:Ï‘V<´¯EdÂÑU|…ï%`x‚E€ð|ŠàAÁAV†aƒY5È`xk}™á´  EI endstream endobj 314 0 obj <> endobj 318 0 obj <>stream 0 0 0 0 155 15 d1 155 0 0 15 0 0 cm BI /IM true /W 155 /H 15 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦eYÁÓø¿Éª_µð EI endstream endobj 319 0 obj <>stream 0 0 0 0 113 31 d1 113 0 0 31 0 0 cm BI /IM true /W 113 /H 31 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡–tÅP ‚œòÌ0@ðM=4ÿÂúiá}¯úù/úü _…úÃZL/…#«QÿC]4ÖÌ$Õ=&© aøŽÂÁ¨€ EI endstream endobj 320 0 obj <>stream 0 0 0 0 127 86 d1 127 0 0 86 0 0 cm BI /IM true /W 127 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÖkÁ$3`ƒÂøA×> „@ÂM§ü&žè?EZ8ëÎ'øá±ßõ¸z ‡ôý8}Øf{Ó‹Öýô﯅oÂÿñ_ý~¯ÿ¯^¿ü/ÂþõôµïY5]/¯†¡,>½ëÚIv«¿ º l0¡.¯h ]•a–‚[õÈT˜d1¹)b[[[[ /Ã[ƒ a‚ü,,†šžA°§ ÈOà EI endstream endobj 321 0 obj <>stream 0 0 0 212 85 301 d1 85 0 0 89 0 212 cm BI /IM true /W 85 /H 89 /BPC 1 /D[1 0] /F/CCF /DP<> ID &±VŸ„X_Ó­k úZÅ_¨G…­k_ ZÑ´½p‚é¥ÒõÐ\%×¥××K„^—K×K„^—¯].‚áz]/]z\/At½bµð´A¨"ÐUÂ…­k_áh5UA¯“T‡…†@ EI endstream endobj 322 0 obj <>stream 0 0 0 0 128 88 d1 128 0 0 88 0 0 cm BI /IM true /W 128 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x)?ÓÂþºë® úë®_Âë…Âëø"­t…ô‚_^ð@¼/„¼ø^^@°KÂùo¾ È+y ¢Ÿ!¨ ä<†Å¿‚ò{Ï/ ð\Ap\+ OùU¼&¨–÷‘p<^ÃðÍ`xãÿÿÿþ@ðm‚úÿÿö¿ðdæ  EI endstream endobj 323 0 obj <>stream 0 0 0 0 127 86 d1 127 0 0 86 0 0 cm BI /IM true /W 127 /H 86 /BPC 1 /D[1 0] /F/CCF /DP<> ID & nUƒ,‚±VAµS!ª—øAáÁ„᧠ðOE->E×Ñ1:©oDLÌa~‰€ñ!¡&‚Ð@ü„4¤´á×¼%@ü·Õ>•}+_áAáô–¾½úû®?øKø_ÿ^5ÿÿ§úÿøiÿý…»AoÿÚRj¬5ìóµâ„¸m¯õ†ÃÛK¸`¿&…»µ¸kv¿ö¶˜X;[Ma„_à ,C ,à•ü@ EI endstream endobj 324 0 obj <>stream 0 0 0 0 127 88 d1 127 0 0 88 0 0 cm BI /IM true /W 127 /H 88 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔN†É ²ø ðƒ!ªŒdF¦xMÓO ‚A ÿÓ½4ùVŽ*zöÂoàˆ.Ÿàƒ ô‡#¯ ›šß ÐAúz¤ð›ûIõûè=?LÓáá‡õÿûýBøûNÿ×ÿÿÿÿÿýíWäÕzÿîúÿ Báíòuû_Û ikÚL5Û[ ~þÃJK†¬ŒØ,{UÁ‘°°õìPkÚÿi­ªØL,4 -¦¿ÃLÐa`Â!ªŒ0‡äH€€ EI endstream endobj 325 0 obj <> endobj 329 0 obj <>stream 0 0 0 0 132 101 d1 132 0 0 101 0 0 cm BI /IM true /W 132 /H 101 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¦l¸@ðœ_ÿÿÿÌX|?ð¾èĘg$ÄÈ0Ëè" c8&ôƒð›áÒ~›×öú~¹5ICá¨_ðàÁã¿õÿÿÿÿ×ûÿáx\0ÿ^ÿK¿´½vÂðioö–Ø^ / °Ê@ηö@‚®+ö¶Ã[_°X5† _<*¼áŠà EI endstream endobj 330 0 obj <> endobj 334 0 obj <>stream 0 0 0 104 87 202 d1 87 0 0 98 0 104 cm BI /IM true /W 87 /H 98 /BPC 1 /D[1 0] /F/CCF /DP<> ID & xp´ÿ@<ÿ yWäÔH,È) HmHiªù Ä©ûCœ‹½eìfw~‰˜š+ÄySòX 2(òL%8AädH|šäT5 ×% ×®A3ìíƒÂÈ¥‚80ò ‹wØ%Ê1hQÔO‡È4(ÈeÈlü‚âÙU‘A2´ˆeÿè•P|Š†®4È6ÁeX2Êp(¼¬Š†´–O•0/&¹X94gyìr.õÆç ßcù Ä© 5Y  I!i€? ΢@ò®@ðÿÿµû_ EI endstream endobj 335 0 obj <> stream 44 0 0 0 0 0 d1 endstream endobj 336 0 obj <>stream 0 0 0 102 121 195 d1 121 0 0 93 0 102 cm BI /IM true /W 121 /H 93 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ _ä ?‹?Óÿðððþ + ƒPÂö† ÂÓ ~ 5&¨úAƒ_à ðØX< Á¢_ÄC× 4X0Â_ /°ÐMa†àð°Á„¶Â †¸0iaˆX5°°×àÂÃ[ ¸X\% ºÐY¼$C_ðƒPƒð‚âÒO „º …ép‚õÒÄü†ƒOÿÿüš¤×øa@ EI endstream endobj 337 0 obj <> endobj 341 0 obj <>stream 0 0 0 115 141 205 d1 141 0 0 90 0 115 cm BI /IM true /W 141 /H 90 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x6”ˆ"œ6AÂOÿA÷§§„ÿôB õøDeô?I¾Ÿ é^¯×«è/ z^¡úô½|Ò‡'×¹ƒ¸A. ðK ׯ_ð^¼/^ þ”€µ&©AwÂ_ÇÂÿü/ÿZÿë×þ—ëýa]ýoµùÁf™Ášà EI endstream endobj 342 0 obj <> endobj 346 0 obj <> endobj 350 0 obj <> endobj 354 0 obj <>stream 0 0 0 196 141 300 d1 141 0 0 104 0 196 cm BI /IM true /W 141 /H 104 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨Êoü_ÿüš¥Ï£ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž#ˆâ8Ž.ÿÿÿÿÿˆˆˆˆˆˆˆˆˆˆˆÿÿÿÿÿþ@ðÍòÃÂýtïßÿü?Ãÿûÿÿÿÿÿÿ¯ü/ü/þ¾ÿ4» ñ]B®ª MRØ_³²@Ù xeÿÿÿÿÿÿÿÿµÖ€€ EI endstream endobj 355 0 obj <>stream 0 0 0 0 95 139 d1 95 0 0 139 0 0 cm BI /IM true /W 95 /H 139 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ÔfFŽC*² iò Á‚pR ÁBÒ rAH4 Qp@‚)Ã]\*ê´¤—øA%ªõ]BÔ/ýV«ÿUþ«ÿ ¿ÿÿÿÿÿÿÿ‡îÿÿÝÿ»ÿÝî¸í·þøwÝîûmÿ¸~á÷{¾mÿ¶ÞÛ÷l7»á߇}Þï¶ßû‡îw»á†ßû¿wþÛîþáÿ»ÿÿwÿÿÿÿÿÿÿáWú­Wþ¡¨_ô’ÿI.aWUÂ@—Pµ\$–!BYiIÔ,$ h þ Aƒ{5ƒX,3@Ú4 EI endstream endobj 356 0 obj <> endobj 360 0 obj <> endobj 364 0 obj <> endobj 368 0 obj <> endobj 372 0 obj <>stream 0 0 0 0 192 39 d1 192 0 0 39 0 0 cm BI /IM true /W 192 /H 39 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ðd¡ç@ÿþ!§ÿÿÿÿÿÿÿþMRÿÁ‚€€ EI endstream endobj 373 0 obj <>stream 0 0 0 0 192 38 d1 192 0 0 38 0 0 cm BI /IM true /W 192 /H 38 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬ÉeÁø¿ù GÄqGÄqGÄqGÄqGÄqGÄqGňˆˆˆˆˆˆˆˆˆˆˆˆˆ?ÿÿÿÿÿÿùuù5IëÿÁ@@ EI endstream endobj 374 0 obj <> endobj 378 0 obj <>stream 0 0 0 0 74 84 d1 74 0 0 84 0 0 cm BI /IM true /W 74 /H 84 /BPC 1 /D[1 0] /F/CCF /DP<> ID & °f$=<‚‹Aà·þ ¸[×ÂøAN»Ê  ^‚Ç š<¼ žºB>_]W ¤ÿ¤½c]*X%VÓ Ú3!¦¢Á?È“]ÎUÁ¡\CïÛþTÂvKA‡d\ á‘ ÍÃ*ÃKú%Ã_F°Tä€eÂÐ.«Az®¤ªõz¯Aid^Á]B_V˜JM~.2 *ø_[Áu x_ì!ÚÃP EI endstream endobj 379 0 obj <>stream 0 0 0 0 106 81 d1 106 0 0 81 0 0 cm BI /IM true /W 106 /H 81 /BPC 1 /D[1 0] /F/CCF /DP<> ID & x4üàc\á ¾@ðÁ<ᲧäE9ÂÜ:–AH“ ¬±ÂÈ6’ä52 )x"¶ ŠÈÊ 4B!a§Bƒ^º% ©•.E@âZ®— Úå8«@’‚×á.•pU¥ô_ªÂ_ ë ¥N² Úë„ÿ Ø«!¦ÿÖŽÈf vAAV2…ì¥>ICÿ`¹_`°Á6EÀƃ %§äÕ5d3¨d5!³JÛÅ.0¾[D´ØU´-¢ 5ƒ< Ác ‚à  EI endstream endobj 380 0 obj <>stream 0 0 0 0 74 74 d1 74 0 0 74 0 0 cm BI /IM true /W 74 /H 74 /BPC 1 /D[1 0] /F/CCF /DP<> ID & yý`² -`«KáaAª ¸A% ‚\/I„—×IuÑz¯ÒôPÿõJý}W[ÒoXzW×Âô¯ zÛW&½/×x_Ká{¥ØkÞ¸t«x_ªøJ·K߯Kô^«á— u]V”ú ºf–×Aiu¡u Mu EI endstream endobj 381 0 obj <> endobj 385 0 obj <> endobj 389 0 obj <> endobj 393 0 obj <> endobj 9 0 obj <>/FontBBox[0 -264 192 218]/FontMatrix[1 0 0 1 0 0]/FirstChar 0/LastChar 229/Widths[ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 0 0 0 0 0 0 0 0 0 0 37 0 0 0 0 47 0 0 0 0 94 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 48 0 0 0 0 0 0 0 0 45 0 0 0 0 32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 52 0 0 0 0 0 0 59 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 38 0 0 0 0 0 0 0 28 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 91 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 116 0 0 0 0 0 0 0 39 0 0 0 0 0 0 0 0 0 0 44 0 0 0 0 0 0 0 0 0] >> endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 394 0000000000 65535 f 0000043040 00000 n 0000116838 00000 n 0000042681 00000 n 0000043088 00000 n 0000036655 00000 n 0000000015 00000 n 0000000486 00000 n 0000115732 00000 n 0000112281 00000 n 0000043157 00000 n 0000043404 00000 n 0000043685 00000 n 0000044024 00000 n 0000044397 00000 n 0000044748 00000 n 0000044964 00000 n 0000045382 00000 n 0000045729 00000 n 0000046089 00000 n 0000046302 00000 n 0000046638 00000 n 0000046987 00000 n 0000047269 00000 n 0000047470 00000 n 0000047776 00000 n 0000048082 00000 n 0000048342 00000 n 0000048621 00000 n 0000048908 00000 n 0000049234 00000 n 0000049417 00000 n 0000049741 00000 n 0000050031 00000 n 0000050506 00000 n 0000050741 00000 n 0000051052 00000 n 0000051310 00000 n 0000051884 00000 n 0000052091 00000 n 0000052121 00000 n 0000052150 00000 n 0000036825 00000 n 0000000505 00000 n 0000001002 00000 n 0000052563 00000 n 0000052859 00000 n 0000053104 00000 n 0000053407 00000 n 0000053750 00000 n 0000054154 00000 n 0000054509 00000 n 0000054688 00000 n 0000055028 00000 n 0000055389 00000 n 0000055667 00000 n 0000036979 00000 n 0000001022 00000 n 0000001895 00000 n 0000055696 00000 n 0000056079 00000 n 0000056448 00000 n 0000056636 00000 n 0000057036 00000 n 0000057292 00000 n 0000057555 00000 n 0000057897 00000 n 0000058188 00000 n 0000037133 00000 n 0000001915 00000 n 0000002461 00000 n 0000058217 00000 n 0000058401 00000 n 0000058733 00000 n 0000058988 00000 n 0000037287 00000 n 0000002481 00000 n 0000003235 00000 n 0000059017 00000 n 0000059296 00000 n 0000059642 00000 n 0000059991 00000 n 0000060190 00000 n 0000060254 00000 n 0000060461 00000 n 0000060727 00000 n 0000037441 00000 n 0000003255 00000 n 0000004312 00000 n 0000060756 00000 n 0000061061 00000 n 0000061372 00000 n 0000061717 00000 n 0000061937 00000 n 0000062329 00000 n 0000062645 00000 n 0000062975 00000 n 0000063256 00000 n 0000063320 00000 n 0000063725 00000 n 0000064042 00000 n 0000064346 00000 n 0000064674 00000 n 0000064739 00000 n 0000065042 00000 n 0000037596 00000 n 0000004332 00000 n 0000004931 00000 n 0000065072 00000 n 0000065827 00000 n 0000066082 00000 n 0000037753 00000 n 0000004952 00000 n 0000005745 00000 n 0000066112 00000 n 0000066322 00000 n 0000066387 00000 n 0000066667 00000 n 0000066971 00000 n 0000067281 00000 n 0000067540 00000 n 0000067806 00000 n 0000068098 00000 n 0000068492 00000 n 0000068842 00000 n 0000069354 00000 n 0000069686 00000 n 0000070030 00000 n 0000070375 00000 n 0000070684 00000 n 0000071030 00000 n 0000071439 00000 n 0000071757 00000 n 0000072079 00000 n 0000072493 00000 n 0000072685 00000 n 0000072750 00000 n 0000073104 00000 n 0000073426 00000 n 0000073812 00000 n 0000074130 00000 n 0000074318 00000 n 0000074608 00000 n 0000074911 00000 n 0000075133 00000 n 0000075198 00000 n 0000075450 00000 n 0000075648 00000 n 0000075882 00000 n 0000076118 00000 n 0000076183 00000 n 0000076525 00000 n 0000076817 00000 n 0000077115 00000 n 0000077416 00000 n 0000077699 00000 n 0000077998 00000 n 0000078425 00000 n 0000078820 00000 n 0000079059 00000 n 0000079321 00000 n 0000079619 00000 n 0000079927 00000 n 0000080181 00000 n 0000080377 00000 n 0000080442 00000 n 0000080732 00000 n 0000080949 00000 n 0000081333 00000 n 0000081649 00000 n 0000081679 00000 n 0000037910 00000 n 0000005766 00000 n 0000006570 00000 n 0000081962 00000 n 0000082189 00000 n 0000082254 00000 n 0000082492 00000 n 0000082780 00000 n 0000083044 00000 n 0000083369 00000 n 0000083626 00000 n 0000083917 00000 n 0000084230 00000 n 0000084466 00000 n 0000084807 00000 n 0000085080 00000 n 0000085416 00000 n 0000085742 00000 n 0000085969 00000 n 0000086303 00000 n 0000086603 00000 n 0000086935 00000 n 0000087377 00000 n 0000087782 00000 n 0000088071 00000 n 0000088415 00000 n 0000088631 00000 n 0000088936 00000 n 0000038067 00000 n 0000006591 00000 n 0000007441 00000 n 0000088966 00000 n 0000089299 00000 n 0000089758 00000 n 0000090019 00000 n 0000090439 00000 n 0000090849 00000 n 0000090914 00000 n 0000091201 00000 n 0000091487 00000 n 0000038224 00000 n 0000007462 00000 n 0000010058 00000 n 0000091517 00000 n 0000091741 00000 n 0000092118 00000 n 0000092430 00000 n 0000092694 00000 n 0000038381 00000 n 0000010080 00000 n 0000011999 00000 n 0000092724 00000 n 0000093002 00000 n 0000093067 00000 n 0000093403 00000 n 0000038538 00000 n 0000012021 00000 n 0000012919 00000 n 0000093433 00000 n 0000038687 00000 n 0000012940 00000 n 0000013981 00000 n 0000093463 00000 n 0000093661 00000 n 0000093931 00000 n 0000094200 00000 n 0000094421 00000 n 0000094816 00000 n 0000095021 00000 n 0000038844 00000 n 0000014002 00000 n 0000015039 00000 n 0000095051 00000 n 0000095426 00000 n 0000095848 00000 n 0000096302 00000 n 0000096669 00000 n 0000097113 00000 n 0000097419 00000 n 0000097852 00000 n 0000098093 00000 n 0000098341 00000 n 0000098406 00000 n 0000098864 00000 n 0000039001 00000 n 0000015060 00000 n 0000015860 00000 n 0000098894 00000 n 0000099235 00000 n 0000099433 00000 n 0000039158 00000 n 0000015881 00000 n 0000016737 00000 n 0000099463 00000 n 0000039307 00000 n 0000016758 00000 n 0000017489 00000 n 0000099493 00000 n 0000039456 00000 n 0000017510 00000 n 0000018316 00000 n 0000099523 00000 n 0000099819 00000 n 0000100141 00000 n 0000039613 00000 n 0000018337 00000 n 0000019111 00000 n 0000100171 00000 n 0000100609 00000 n 0000100824 00000 n 0000101125 00000 n 0000101470 00000 n 0000101782 00000 n 0000102252 00000 n 0000102558 00000 n 0000102888 00000 n 0000039770 00000 n 0000019132 00000 n 0000019801 00000 n 0000102918 00000 n 0000103256 00000 n 0000103482 00000 n 0000103548 00000 n 0000103764 00000 n 0000039927 00000 n 0000019822 00000 n 0000020615 00000 n 0000103794 00000 n 0000104157 00000 n 0000104460 00000 n 0000040084 00000 n 0000020636 00000 n 0000021505 00000 n 0000104490 00000 n 0000040233 00000 n 0000021526 00000 n 0000022721 00000 n 0000104520 00000 n 0000104960 00000 n 0000105339 00000 n 0000105563 00000 n 0000105756 00000 n 0000105821 00000 n 0000106207 00000 n 0000040390 00000 n 0000022743 00000 n 0000023718 00000 n 0000106237 00000 n 0000106422 00000 n 0000106664 00000 n 0000107008 00000 n 0000107283 00000 n 0000107591 00000 n 0000107943 00000 n 0000108307 00000 n 0000040547 00000 n 0000023739 00000 n 0000024702 00000 n 0000108337 00000 n 0000108643 00000 n 0000040704 00000 n 0000024723 00000 n 0000025474 00000 n 0000108673 00000 n 0000109065 00000 n 0000109130 00000 n 0000109451 00000 n 0000040861 00000 n 0000025495 00000 n 0000026526 00000 n 0000109481 00000 n 0000109781 00000 n 0000041018 00000 n 0000026547 00000 n 0000027363 00000 n 0000109811 00000 n 0000041167 00000 n 0000027384 00000 n 0000028847 00000 n 0000109841 00000 n 0000041316 00000 n 0000028869 00000 n 0000029654 00000 n 0000109871 00000 n 0000110176 00000 n 0000110565 00000 n 0000041473 00000 n 0000029675 00000 n 0000030625 00000 n 0000110595 00000 n 0000041622 00000 n 0000030646 00000 n 0000031610 00000 n 0000110625 00000 n 0000041771 00000 n 0000031631 00000 n 0000032086 00000 n 0000110655 00000 n 0000041920 00000 n 0000032107 00000 n 0000033090 00000 n 0000110685 00000 n 0000110885 00000 n 0000111132 00000 n 0000042077 00000 n 0000033111 00000 n 0000034414 00000 n 0000111162 00000 n 0000111490 00000 n 0000111872 00000 n 0000112161 00000 n 0000042234 00000 n 0000034436 00000 n 0000035711 00000 n 0000112191 00000 n 0000042383 00000 n 0000035733 00000 n 0000036380 00000 n 0000112221 00000 n 0000042532 00000 n 0000036401 00000 n 0000036634 00000 n 0000112251 00000 n trailer << /Size 394 /Root 1 0 R /Info 2 0 R >> startxref 116888 %%EOF gcl-2.7.1/ansi-tests/doc/PaxHeaders/lisp.bib0000644000000000000000000000013214542551762015643 xustar0030 mtime=1703597042.984022401 30 atime=1744294960.733790243 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/doc/lisp.bib0000644000175000017500000000643114542551762015245 0ustar00cammcamm@booklet{X3J13:94, title = "Common {Lisp} {HyperSpec}", author = "K. M. Pitman", howpublished = "http://www.lispworks.com/reference/HyperSpec/Front/index.htm", note = "A hyperlinked form of ANSI/INCITS document 226-1994. Translated in 1996 and updated in 2005." } @article{McKeeman:98, title = {Differential Testing for Software}, author = {W. M. McKeeman}, journal = {Digital Technical Journal}, volume = {10}, number = {1}, year = {1998}, pages = {100--107} } @article{DuranNtafos:84, title = {An Evaluation of Random Testing}, author = {J. W. Duran and S. Ntafos}, journal = {IEEE TSE}, volume = {SE-10}, year = {1984}, pages = {438--444}, publisher = {IEEE Press} } @inproceedings{DuranNtafos:81, author = {Joe W. Duran and Simeon Ntafos}, title = {A report on random testing}, booktitle = {ICSE '81: Proceedings of the 5th international conference on Software engineering}, year = {1981}, pages = {179--183}, location = {San Diego, California, United States}, publisher = {IEEE Press} } @misc{KanerBondMcGee:04, author={C. Kaner, W. P. Bond, P. McGee}, title={High Volume Test Automation}, howpublished={At http://testingeducation.org/a/hvta.pdf}, year={2004}, month={May}, note={Keynote address presented at the International Conference on Software Testing, Analysis, and Review (STAR East), Orlando, FL} } @article{Waters:91a, author = {Richard C. Waters}, title = {Supporting the regression testing of Lisp programs}, journal = {SIGPLAN Lisp Pointers}, volume = {IV}, number = {2}, year = {1991}, pages = {47--53}, publisher = {ACM Press}, address = {New York, NY, USA}, } @article{HildZeller:02a, author={Andreas Zeller and Ralf Hildebrandt}, title={Simplifying and Isolating Failure-Inducing Input}, journal={IEEE Transactions on Software Engineering}, volume={28}, number={2}, month={Feb}, year={2002}, pages={183--200}, } @inproceedings {BachSchroeder:04, author={James Bach and Patrick J. Schroeder}, title={Pairwise Testing: A Best Practice That Isn't}, booktitle={Proc. 22nd Annual Pacific Northwest Software Quality Conference}, year={2004}, note={See http://www.pnsqc.org/proceedings/pnsqc2004.pdf}, } @inproceedings {Slutz:98, author={Don R. Slutz}, title={Massive Stochastic Testing of {SQL}}, booktitle={Proc. 24th International Conference on Very Large Database Systems (VLDB'98)}, year={1998}, month={Aug.}, pages={618-622}, } @misc{Lindig:05, author={Christian Lindig}, title={Random Testing the Translation of {C} Function Calls}, month={Feb.}, year={2005}, howpublished={At http://www.st.cs.uni-sb.de/~lindig/src/quest/quest.pdf}, } @book{Myers:79, author={Glenford J. Myers}, title={The Art of Software Testing}, publisher={John Wiley \& Sons}, year={1979}, } @article{MillerFredriksenSo:90, author = {Barton P. Miller and Louis Fredriksen and Bryan So}, title = {An empirical study of the reliability of UNIX utilities}, journal = {Commun. ACM}, volume = {33}, number = {12}, year = {1990}, issn = {0001-0782}, pages = {32--44}, doi = {http://doi.acm.org/10.1145/96267.96279}, publisher = {ACM Press}, address = {New York, NY, USA}, } @misc{Faigon:05, author={Ariel Faigon}, title={Testing for Zero Bugs}, year={2005}, howpublished={At http://www.yendor.com/testing/}, } gcl-2.7.1/ansi-tests/doc/PaxHeaders/ilc2005.tex0000644000000000000000000000013214542551762016016 xustar0030 mtime=1703597042.984022401 30 atime=1744294960.733790243 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/doc/ilc2005.tex0000644000175000017500000006644514542551762015433 0ustar00cammcamm\documentclass[11pt]{article} % \setlength{\oddsidemargin}{0in} % \setlength{\evensidemargin}{0in} % \setlength{\footskip}{1in} % \setlength{\textwidth}{6.5in} \usepackage[letterpaper,textwidth=6.7in,textheight=8.7in]{geometry} \usepackage{graphics} \usepackage{url} \usepackage{times} %\usepackage[british]{babel} % \usepackage{theorem} \setlength{\topmargin}{.35in} \newtheorem{theorem}{Theorem} \pagestyle{empty} \begin{document} \title{The GCL ANSI Common Lisp Test Suite} \author{Paul F. Dietz\footnote{Motorola Global Software Group, 1303 E. Algonquin Road, Annex 2, Schaumburg, IL 60196. paul.f.dietz@motorola.com}} \date{} \maketitle \thispagestyle{empty} \begin{abstract} I describe the conformance test suite for ANSI Common Lisp distributed as part of GNU Common Lisp (GCL). The test suite includes more than 20,000 individual tests, as well as random test generators for exercising specific parts of Common Lisp implementations, and has revealed many conformance bugs in all implementations on which it has been run. \end{abstract} \section{Introduction} One of the strengths of Common Lisp is the existence of a large, detailed standard specifying the behavior of conforming implementations. The value of the standard to users is enhanced when they can be confident that implementations that purport to conform actually do. In the 1990s I found substantial numbers of conformance bugs in many Lisp implementations. As a result, I decided to build a comprehensive functional test suite for Common Lisp. The goals of the effort were, in no particular order: \begin{itemize} \item To thoroughly familiarize myself with the standard. \item To provide a tool to locate conformance problems in CL implementations, both commercial and free. \item To enable implementors to improve CL implementations while maintaining conformance. \item To explore the standard itself for ambiguities, unintended consequences, and other problems. \item To explore different testing strategies. \end{itemize} I deliberately did not design the test suite to measure or rank conformance of Lisp implementations. For this reason, I will not here report the overall score of any implementation. I decided to locate the test suite in the GCL development tree for two reasons. First, its development team had a goal of making GCL more ANSI compliant, and tests would assist there. Secondly, the GCL CVS tree is easily publicly accessible\footnote{See \url{http://savannah.gnu.org/projects/gcl/}}, so any developers or users of Common Lisp implementations would have easy access to it. The test suite was constructed over the period from 1998 to 2005, with most of the work done in 2002 to 2004. As of 24 May 2005, the test suite contains over 20,000 tests. The test suite is based on a version of the ANSI Common Lisp specification (ANSI/INCITS 226-1994, formerly ANSI X3.226-1994) that was made publicly available by Harlequin (now LispWorks) in hyperlinked form in 1996 \cite{X3J13:94}. Table \ref{lispimpltab} contains a list of Lisp implementations on which I am aware the test suite has been run. \begin{table} \begin{center} \begin{tabular}{lr} Implementation & Hardware Platforms \\ \hline GNU Common Lisp & All debian platforms \\ GNU CLISP & x86 \\ CMUCL & x86, Sparc \\ SBCL & x86, x86-64, Sparc, MIPS, Alpha, PowerPC \\ Allegro CL (6.2, 7) & x86, Sparc, PowerPC \\ LispWorks (4.3) & x86 \\ OpenMCL & PowerPC \\ ABCL & x86 (JVM) \\ ECL & x86 \\ \end{tabular} \end{center} \caption{\label{lispimpltab} Implementations Tested} \end{table} \section {Infrastructure} The test suite uses Waters' RT package \cite{Waters:91a}. This package provides a simple interface for defining tests. In its original form, tests are defined with a name (typically a symbol or string), a form to be evaluated, and zero or more expected values. The test passes if the form evaluates to the specified number of values, and those values are as specified. See figure \ref{examplefig} for an example from the test suite: \begin{figure} \begin{verbatim} (deftest let.17 (let ((x :bad)) (declare (special x)) (let ((x :good)) ;; lexical binding (let ((y x)) (declare (special x)) ;; free declaration y))) :good) \end{verbatim} \caption{\label{examplefig} Example of a test} \end{figure} As the test suite evolved RT was extended. Features added include: \begin{itemize} \item Error conditions raised by tests may be trapped. \item Tests may optionally be executed by wrapping the form to be evaluated in a lambda form, compiling it, and calling the compiled code. This makes sense for testing Lisp itself, but would not be useful for testing Lisp applications. \item A subset of the tests can be run repeatedly, in random order, a style of testing called \emph{Repeated Random Regression} by Kaner, Bond and McGee \cite{KanerBondMcGee:04}\footnote{This was previously called `Extended Random Regression'; McGee renamed it to avoid the confusing acronym.} \item Notes may be attached to tests, and these notes used to turn off groups of tests. \item Tests can be marked as being expected to fail. Unexpected failures are reported separately. \end{itemize} \section {Functional Tests} The bulk of the test suite consists of functional tests derived from specific parts of the ANSI specification. Typically, for each standardized operator there is a file \emph{operator}.lsp containing tests for that operator. This provides a crude form of traceability. There are exceptions to this naming convention, and many tests that test more than one operator are located somewhat arbitrarily. Table \ref{tab:testsize} shows the number and size of tests for each section of the ANSI specification. \begin{table} \begin{center} \begin{tabular}{|l|r|r|} \hline Section of CLHS & Size (Bytes) & Number of Tests \\ \hline \hline Arrays & 212623 & 1109 \\ Characters & 38655 & 256 \\ Conditions & 71250 & 658 \\ Cons & 264208 & 1816 \\ Data \& Control Flow & 185973 & 1217 \\ Environment & 51110 & 206 \\ Eval/Compile & 41638 & 234 \\ Files & 26375 & 87 \\ Hash Tables & 38752 & 158 \\ Iteration & 98339 & 767 \\ Numbers & 290991 & 1382 \\ Objects & 283549 & 774 \\ Packages & 162203 & 493 \\ Pathnames & 47100 & 215 \\ Printer & 454314 & 2364 \\ Reader & 101662 & 663 \\ Sequences & 562210 & 3219 \\ Streams & 165956 & 796 \\ Strings & 83982 & 415 \\ Structures & 46271 & 1366 \\ Symbols & 106063 & 1141 \\ System Construction & 16909 & 77 \\ Types & 104804 & 599 \\ Misc & 291883 & 679 \\ \hline Infrastructure & 115090 & \\ Random Testers & 190575 & \\ \hline Total & 4052485 & 20702 \\ \hline \end{tabular} \end{center} \caption{\label{tab:testsize} Sizes of Parts of the Test Suite} \end{table} Individual tests vary widely in power. Some are as simple as a test that {\tt (CAR NIL)} is {\tt NIL}. Others are more involved. For example, {\tt TYPES.9} checks that {\tt SUBTYPEP} is transitive on a large collection of built-in types. The time required to run the test suite depends on the implementation, but it is not excessive on modern hardware. SBCL 0.9.0.41 on a machine with 2 GHz 64 bit AMD processor, for example, runs the test suite in under eight minutes. Error tests have been written where the error behavior is specified by the standard. This includes specifications in the `Exceptional Situations' sections for operator dictionary entries, as well as tests for calls to functions with too few or too many arguments, keyword parameter errors, and violations of the first paragraph of CLHS section 14.1.2.3. When type errors are specified or when the CLHS requires that some operator have a well-defined meaning on any Lisp value, the tests iterate over a set of precomputed Lisp objects called the `universe' that contains representatives of all standardized Lisp classes. In some cases a subset of this universe is used, for efficiency reasons. There are some rules that perform random input testing. This testing technique is described more fully in the next section. Other tests are themselves deterministic, but are the product of one of the suite's high volume random test harnesses. The `Misc' entry in table \ref{tab:testsize} refers to these randomly generated tests. Each of these tests caused a failure in at least one implementation. Inevitably, bugs have appeared in the test suite. Running the test suite on multiple implementations (see table \ref{lispimpltab}) exposes most problems. If a test fails in most of them, it is likely (but not certain) that the test is flawed. Feedback from implementors has also been invaluable, and is deeply appreciated. In some cases, when it has not been possible to agree on the proper interpretation of the standard, I've added a note to the set of disputed tests so they can be disabled as a group. This is in keeping with the purpose of the test suite -- to help implementors, not judge implementations. \section {Random Testing} Random testing (more properly, random-input testing) is a standard technique in the testing of hardware systems. However, it has been the subject of controversy in the software testing community for more than two decades. Myers \cite{Myers:79} called it ``Probably the poorest ... methodology of all''. This assessment presumes that the cost of executing tests and checking their results for validity dominates the cost of constructing the tests. If test inputs can be constructed and results checked automatically, it may be very cost-effective to generate and execute many lower quality tests. Kaner et al. call this High Volume Automated Testing \cite{KanerBondMcGee:04}. Duran and Ntafos \cite{DuranNtafos:81} report favorably on the ability of random testing to find relatively subtle bugs without a great deal of effort. Random testing has been used to test Unix utilities (so-called `fuzz testing') \cite{MillerFredriksenSo:90}, database systems \cite{Slutz:98}, and C compilers \cite{McKeeman:98,Lindig:05,Faigon:05}. Bach and Schroeder \cite{BachSchroeder:04} report that random input testing compares well with the ability of the popular All-Pairs testing technique at actually finding bugs. Random input testing provides a powerful means of testing algebraic properties of systems. Common Lisp has many instances where such properties can be checked, and the test suite tests many of them. Random testing is used to test numeric operators, type operators, the compiler, some sequence operators, and the readability of objects printed in `print readably' mode. One criticism of random testing is its irreproducibility. With care, this needn't be a problem. If a random failure is sufficiently frequent, it can be reproduced with high probability by simply running a randomized test again. Tests can also be designed so that on failure, they print sufficient information so that a non-randomized test can be constructed exercising the bug. Most of the randomized tests in the test suite have this property. \subsection {Compiler Tests} \label{sec:compilertests} Efficiency of compiled code has long been one of Common Lisp's strengths. Implementations have been touted as in some cases approaching the speed of statically typed languages. Achieving this efficiency places strong demands on Lisp compilers. A sufficiently smart compiler needs a sufficiently smart test suite. Compilers (and Lisp compilers in particular) are an ideal target for random input testing. Inputs may have many parts that interact in the compiler in unpredictable ways. Because the language has a well-defined semantics, it is easy to generate related, but different, forms that should yield the same result (thereby providing a test oracle.) The Random Tester performs the following steps. For some input parameters $n$ and $s$ (each positive integers): \begin{enumerate} \item Produce a list of $n$ symbols that will be the parameters of a lambda expression. These parameters will have integer values. \item Produce a list of $n$ finite integer subrange types. These will be the types of the lambda parameters. The endpoints of these types are not uniformly distributed, but instead follow an approximately exponential distribution, preferring small integers over larger ones. Integers close in absolute value to integer powers of 2 are also overrepresented. \item Generate a random conforming Lisp form of `size' approximately $s$ containing (mostly) integer-valued forms. The parameters from step 1 occur as free variables. \item From this form, construct two lambda forms. In the first, the lambda parameters are declared to have their integer types, and random {\tt OPTIMIZE} settings are included. In the second, a different set of {\tt OPTIMIZE} settings is declared, and all the standardized Lisp functions that occur in the form are declared {\tt NOTINLINE}. The goal here is to attempt to make optimizations work differently on the two forms. \item For each lambda form, its value on each set of inputs is computed. This is done either by compiling the lambda form and calling it on the inputs, or by evaling forms in which the lambda form is the {\tt CAR} and the argument list the {\tt CDR}. \item A failure occurs if any call to the compiler or evaluator signals an error, or if the two lambda forms yield different results on any of the inputs. \end{enumerate} This procedure very quickly -- within seconds -- found failures in every Lisp implementation on which it was tried. Failures included assertion failures in the compiler, type errors, differing return values, code that caused segmentation faults, and in some cases code that crashed the Lisps entirely. Most of the 679 `Misc' tests in table \ref{tab:testsize} were produced by this tester; each represents a failure in one or more implementations. Generating failing tests was easy, but minimizing them was tedious and time consuming. I therefore wrote a pruner that repeatedly tries to simplify a failing random form, replacing integer-valued subforms with simpler ones, until no substitution preserving failure exists. In most cases, this greatly reduced the size of the failing form. Others have previously observed that bug-exposing random inputs can often be automatically simplified \cite{HildZeller:02a,McKeeman:98}. The desire to be able to automatically simplify the failing forms constrained the tester; I will discuss this problem later in section \ref{sec:future}. \begin{table} \begin{center} \begin{tabular}{|l|l|l|} \hline Sourceforge Bug \# & Type of Bug & Description \\ \hline 813119 & C & Simplification of conditional forms \\ 842910 & C & Simplification of conditional forms \\ 842912 & R & Incorrect generated code \\ 842913 & R & Incorrect generated code \\ 858011 & C & Compiler didn't handle implicit block in {\tt FLET} \\ 858658 & R & Incorrect code for {\tt UNWIND-PROTECT} and multiple values \\ 860052 & C & Involving {\tt RETURN-FROM} and {\tt MULTIPLE-VALUE-PROG1}. \\ 864220 & C & Integer tags in tagbody forms. \\ 864479 & C & Compiler bug in stack analysis. \\ 866282 & V & Incorrect value computed due to erroneous side effect \\ & & analysis in compiler on special variables \\ 874859 & R & Stack mixup causing catch tag to be returned. \\ 889037 & V & Bug involving nested {\tt LABELS}, {\tt UNWIND-PROTECT}, {\tt DOTIMES} forms. \\ 890138 & R & Incorrect bytecodes for {\tt CASE}, crashing the Lisp. \\ 1167991 & C & Simplification of conditional forms. \\ \hline \end{tabular} Legend: \begin{tabular}{ll} C & Condition thrown by the compiler (assert or type check failure.) \\ R & Condition thrown at runtime (incorrectly compiled code). \\ V & Incorrect value returned by compiled code. \\ \end{tabular} \end{center} \caption{\label{clispbugs} Compiler bugs found in GNU CLISP by Random Tester} \end{table} Table \ref{clispbugs} contains a list of the fourteen compiler bugs detected by the random tester in GNU CLISP. Roughly 200 million iterations of the random tester were executed to find these bugs, using a single 1.2 GHz Athlon XP+ workstation running intermittently over a period of months. All these bugs have been fixed (in CVS) and CLISP now fails only when the random forms produce bignum values that exceed CLISP's internal limit. The greatest obstacle to using the random tester is the presence of unfixed, high probability bugs. If an implementation has such a bug, it will generate many useless hits that will conceal lower probability bugs. \subsection {Types and Compilation} Type inference and type-based specialization of built-in operators is a vital part of any high performance Lisp compiler for stock hardware, so it makes sense to focus testing effort on it. The test suite contains a facility for generating random inputs for operators and compiling them with appropriate randomly generated type annotations, then checking if the result matches that from an unoptimized version of the operator. As an example, the operator {\tt ISQRT} had this bug in one commercial implementation: \begin{verbatim} (compile nil '(lambda (x) (declare (type (member 4 -1) x) (optimize speed (safety 1))) (isqrt x))) ==> Error: -1 is illegal argument to isqrt \end{verbatim} Amusingly, the bug occurs only when the negative integer is the second item in the {\tt MEMBER} list. The test that found this bug is succinctly defined via a macro: \begin{verbatim} (def-type-prop-test isqrt 'isqrt '((integer 0)) 1) \end{verbatim} The function to be compiled can be generated in such a way that it stores the result value into an array specialized to a type that contains the expected value. This is intended to allow the result value to remain unboxed. The general random testing framework of section \ref{sec:compilertests} is also useful for testing type-based compiler optimizations, with two drawbacks: it currently only handles integer operators, and it is less efficient than the more focused tests. Even so, it was used to improve unboxed arithmetic in several implementations (SBCL, CMUCL, GCL, ABCL). \subsection {{\tt SUBTYPEP} Testing} The test suite uses the algebraic properties of the {\tt SUBTYPEP} function in both deterministic and randomized tests. For example, if {\tt T1} is known to be a subtype of {\tt T2}, we can also check: \begin{verbatim} (subtypep '(not t2) '(not t1)) (subtypep '(and t1 (not t2)) nil) (subtypep '(or (not t1) t2) t) \end{verbatim} The generator/pruner approach of the compiler random tester was applied to testing {\tt SUBTYPEP}. Random types were generated and, if one was a subtype of the other, the three alternative formulas were also tested. If any return the two values (false, true), a failure has been found. Christophe Rhodes used feedback from this tester to fix logic and performance bugs in SBCL's {\tt SUBTYPEP} implementation. The handling of {\tt CONS} types is particularly interesting, since deciding the subtype relationship in the presence of cons types is NP-hard. At least one implementation's {\tt SUBTYPEP} will run wild on moderately complicated cons types, consuming large amounts of memory before aborting. \subsection {Repeated Random Regression} As mentioned earlier, RRR is a technique for executing tests in an extended random sequence, in order to flush out interaction bugs and slow corruption problems. As an experiment, RT was extended to support RRR on subsets of the tests. The main result was to find many unwanted dependencies in the test suite, particularly among the package tests. These dependencies had not surfaced when the tests had been run in their normal order. After fixing these problems, RRR did find one CLOS bug in CLISP, involving interaction between generic functions and class redefinitions. The bug was localized by bisecting the set of tests being run until a minimal core had been found, then minimizing the sequence of invocations of those tests. If more bugs of this kind are found it may be worthwhile to add a delta debugging \cite{HildZeller:02a} facility to perform automatic test minimization. In Lisps that support preemptively scheduled threads, it would be interesting to use RRR with subsets of the tests that lack global side effects. The tests would be run in two or more threads at once in order to find thread safety problems. \section {Issues with the ANSI Common Lisp Specification} Building the test suite involved going over the standard in detail. Many points were unclear, ambiguous, or contradictory; some parts of the standard proved difficult to test in a portable way. This section describes some of these findings. See `Proposed ANSI Revisions and Clarifications' on \url{http://www.cliki.net/} for a more complete list that includes issues arising from the test suite. \subsection {Testability} Some parts of the standard proved difficult to test in a completely conforming way. The specification of pathnames, for example, was difficult to test. The suite has assumed that UNIX-like filenames are legal as physical pathnames. Floating point operators presented problems. The standard does not specify the accuracy of floating point computations, even if it does specify a minimum precision for each of the standardized float types. \footnote{The standard does specify a feature indicating the implementation purports to conform to the IEEE Standard for Binary Floating Point Arithmetic (ANSI/IEEE Std 754-1985); this suite does not test this.} Some implementations have accuracy that varies depending on the details of compilation; in particular, boxed values may be constrained to 64 bits while unboxed values in machine registers may have additional `hidden' bits. These differences make differential testing challenging. The Objects chapter contains interfaces that are intended to be used with the Metaobject Protocol (MOP). Since the MOP is not part of the standard, some of these cannot be tested. For example, there is apparently no conforming way to obtain an instance of class {\tt METHOD-COMBINATION}, or to produce any subclass of {\tt GENERIC-FUNCTION} except for {\tt STANDARD-GENERIC-FUNCTION}. \subsection {Unintended Consequences} There seem to be many issues associated with Common Lisp's type system. One example is the {\tt TYPE-OF} function. According to the standard, this function has the property that \begin{quote} For any object that is an element of some built-in type: [\ldots] the type returned is a recognizable subtype of that built-in type. \end{quote} A \emph{built-in} type is defined to be \begin{quote} built-in type {\it n}. one of the types in Figure 4-2. \end{quote} Figure 4-2 of the standard contains {\tt UNSIGNED-BYTE}, the type of nonnegative integers. These constraints imply that {\tt TYPE-OF} can never return {\tt FIXNUM} or {\tt BIGNUM} for any nonnegative integer, since neither of those types is a subtype of {\tt UNSIGNED-BYTE}. A more serious set of problems involves {\tt UPGRADED-ARRAY-ELEMENT-TYPE}. \footnote{I ignore the issue that, strictly speaking, {\tt UPGRADED-ARRAY-ELEMENT-TYPE} is either an identity function or is not computable, since as defined it must work on {\tt SATISFIES} types.} This function (from types to types) is specified to satisfy these two axioms for all types $T_1$ and $T_2$: \begin{displaymath} T_1 \subseteq UAET(T_1) \end{displaymath} and \begin{displaymath} T_1 \subseteq T_2 \Longrightarrow UAET(T_1) \subseteq UAET(T_2) \end{displaymath} A type $T_1$ is a \emph{specialized array element type} if $T_1 = UAET(T_1)$. These axioms imply: \begin{theorem} If two types $T_1$ and $T_2$ are specialized array element types, then so is $T_1 \cap T_2$. \end{theorem} This theorem has a number of unpleasant consequences. For example, if {\tt (UNSIGNED-BYTE 16)} and {\tt (SIGNED-BYTE 16)} are specialized array element types, then so must be {\tt (UNSIGNED-BYTE 15)}. Even worse, since {\tt BIT} and {\tt CHARACTER} are required to be specialized array element types, and since they are disjoint, then {\tt NIL}, the empty type, must also be a specialized array element type. Topping all this off, note that \begin{quote} A string is a specialized vector whose elements are of type character or a subtype of type character. (CLHS page for {\tt STRING}) \end{quote} Since {\tt NIL} is a subtype of {\tt CHARACTER}, a vector with array element type {\tt NIL} is a string. It is impossible for a conforming implementation to have only a single representation of strings.\footnote{But since `nil strings' can never be accessed, it's acceptable in non-safe code to just assume string accesses are to some other string representation. The SBCL implementors took advantage of this when using nil strings as a stepping stone to Unicode support.} \section {Directions For Future Work} \label{sec:future} The test suite still has a few areas that are not sufficiently tested. Setf expanders need more testing, as do logical pathnames and file compilation. Floating point functions are inadequately tested. As mentioned earlier, it isn't clear what precision is expected of these functions, but perhaps tests can be written that check if the error is too large (in some sufficiently useful sense.) The random compiler tester, as implemented, is constrained to generate forms that remain conforming as they are simplified. This limits the use of certain operators that do not take the entire set of integers as their arguments. For example, {\tt ISQRT} appears only in forms like {\tt (ISQRT (ABS ...))}, and this pattern is preserved during pruning. The forms also make very limited use of non-numeric types. More sophisticated random tester could avoid these limitations. One approach would be to randomly generate trees from which Lisp forms could be produced, but that also carry along information that would enable pruning to be done more intelligently. Another approach would be to check each pruned form for validity on the set of chosen random inputs by doing a trial run with all operators replaced by special versions that always check for illegal behaviors. I intend to explore both options. The test suite has been written mostly as a `black box' suite (aside from the randomly generated Misc tests). It would be interesting to add more implementation knowledge, with tests that, while conforming, will be more useful if the Lisp has been implemented in a particular way. The type propagation tester is an example of this kind of `gray box' testing. It would be interesting to determine the level of coverage achieved by the test suite in various implementations. The coverage is probably not very good, since the suite cannot contain tests of nonstandardized error situations, but this should be confirmed, and compared against the coverage obtained from running typical applications. Internal coverage could also provide feedback for nudging the random tester toward testing relatively untested parts of the compiler, say by using an evolutionary algorithm on the parameters governing the construction of random forms. \section {Acknowledgments} I would like to thank Camm Maguire, the head of the GCL development team, for allowing the GCL ANSI test suite to be a part of that project. I also would like to thank users of the test suite who have returned feedback, including Camm, Christophe Rhodes, Sam Steingold, Bruno Haible, Duane Rettig, Raymond Toy, Dan Barlow, Juan Jos\'{e} Garc\'{i}a-Ripoll, Brian Mastenbrook and many others. \nocite{X3J13:94} \nocite{McKeeman:98} \nocite{DuranNtafos:81} \nocite{KanerBondMcGee:04} \nocite{Waters:91a} \nocite{HildZeller:02a} \nocite{BachSchroeder:04} \nocite{Slutz:98} \nocite{Lindig:05} \nocite{Myers:79} \bibliography{lisp} \bibliographystyle{plain} \end{document} gcl-2.7.1/ansi-tests/doc/PaxHeaders/ilc2005.pdf0000644000000000000000000000013214542551762015767 xustar0030 mtime=1703597042.984022401 30 atime=1744294960.733790243 30 ctime=1744351535.690907353 gcl-2.7.1/ansi-tests/doc/ilc2005.pdf0000644000175000017500000036170114542551762015375 0ustar00cammcamm%PDF-1.3 %Çì¢ 6 0 obj <> stream xœ¥ZY“ã¶Nü8¿BvÕˆƒ“ü”õúšªµãx'qªâ¬èô“ÿ³=®¾ºƒá©Ê•buwåî£+šóŒèU.yFá‡ãÕçw‡ò‹»ß®8͈Ìíew»«Ï¿{ûnZÔ™âÂ/¾ùñý­]"ynpõm{<¶]ÏuÆ™ÆåwUš!2­”¿øÎ.™ŒKNü…e?ØEÆ3¯{?VÃd샯(ÍŒ”ÌîcMÁ& ¦¯9Éx>]üÓôòL(Ã$Þ_Œµ]äŒzû¿µK2˹a9.enÉh­ü­_Wåðçôê7à/x¥wúÚþçàÓU/7“÷þ‚Fš•ÉLÎò™³™V˜-•À«ßlú¡+¶ƒ»‰±ô¦5Õ$zµ¦y¦'K&g«Œ(Ž_ve¿íª‹Xžê­\)ìE„€mÛæ¾íŽE³~”2SŒû­èøÉGšãjïÏX&¹¸ ÁÇs!͘Ê(aê‚dJvF=ÜÛ½«À#ÕfúAfÌù8”»i•dÚÆãÚOf0x¡öfœŠÎmpE¨ß^{?­Q[ÿ²ï~ü'¾HPC/ì]s6ln2ÉX4ùW›¿~‘aÖ”ýÖ1•( 4üœƒy ~¦~®šm=B§gC¸B|mWbš|=Š·žG'1rM™®6™f9 ßU!ŠÁ¾Õn,jŒ#g©Ùý5"A)!ç€Ð†<”uí­È¥:¿ÐÄPuE³kÓæX¦ƒG‰Å}Ù”]1´Ýô Á!’áÄãZÀ^4‘1ši—5“›DÆ)çžbþpK†Rê^vÛª¯šýd ‡g„_úS¹­>Ûz#-"Îz ™¦ŠÎF`ïhSÜdr!HFA?žêòX6C1Tm㜮”ø`€ÛÐ?JI¿x@LñÖ8”(ûRå ÿ¸°ý¢Æôâ“ÄÇçˆp‚„ŠÆÅG÷DNiàìsb„ÍÛµq¯Sð>¿4î{´Ÿ™ÀñUƒŽ£&dPáqU™!Ï<„ÅÆ°°mçlà.˜wöáÚ¦=¡Š«j‚šÎ”ý”+7eÙø eÁc“!{˘‰œEö†2°¶oº”¶S>Ò·Í0á–Ù ¨®Ý[»/|®^MIc¦â³À蜪ÕîÑbºþïM`¦Ø† *¾ök¾(@Zð=te³.«Àcšê'ž‘Ð9·b@žCêˆ ï\Ÿôâ+0KAFðý¥ DDYáaÍ-ÙU8TÂí•uÑ!çCF¹¾|û®Š 3 ºŒ¯êȵ¢Ûaý¢‘k'^¸DÎ:ÑôÙYÀÏ¡Àd‡LðøX9ê²u¿¹®…‚xÀSAåd2OS _ ™FhxíYZLÀT )´ôoÊdMˆPùèD¡õ EÏŒz¤>崡ňäñc_:J‡:,I0u :es°³CÕÉヘœ@‰ÑboI¡füx‘f¶Ès:Í ¿71¼ÿÙìñ?+½ƒ‹Y®„Úkc&ħèJIëYqv3TLAp»Së´ H*Õ¼™L-³¸ð5&^ òêyýˆØf<˜¼k'„¬AýJPvÛà´\5̓“¨1ÄOg:Á»uœ'>¾oGWµàJ¯ìÇ…ËP9Í!@´ùg7ãqƒÐVÜó -§/öJhÿŠÍ¾}ý¾ˆ[©üž¹ÒþÂc†ÌÏÄò¸¹„ý¨Œì·”P§"Èß8;Dºd²” »²ëáÚá r^B Óh9oKm‚BØ9íРÜéKì޸ࠪÞ! ûYàØm{FÀ‰zq¡÷5âa,›|5ÁÑz%¸7xÛÖä1 4»(¸ÃAèFEø›ºB¡^„Kõ‘3Ý6F,„æXTpOÕD©©Šís^§~2ö¯Ð¯qú„ÌyÓpªq2Âc"3qA^4E5W ž] ÍJ‹L¾â¸©öP”ªÒ!\æÖJ_IÁÐÆ`-–4…2¸±/?Œ¶Éqw‚tL°ˆtÈ—²CxÐX¹|®>¦ zøá`Hé5\öŠxì*¯áTìÍî¡þ9mÍtšDVøÙ M…°ž-À¨ðë{…Ó¶TÚž*¤½ £Ú ß•uµ±Ã¥+2²tWíP-²‡¦.we_íoçúòxq¢n’OÕM’Œ)¡x,‹~DçZÚŽú¸Ci"âÅ]ÑüŽD›§D;cÿœÀnÎõ <Ä{"‘¹ÉC–d®&©6ÃI»IªØA‡+òYï1°õÜÇ—t°Ù¶™²ÄÎ碠]h5ªz¡*úˆÍ‚Éä+íìe¾ñbz9Ž ‹´—̼DÖβl¥‹qí·~;±ý™ó-ˆ:˜Ö(䰶Њ̣Ô¾œÉWõ *¿ì’Îh¦'ŒZpQÒ%&P'jê"J‚¥>lñ©x(eaé(Ç®AÛ’¨í¥pÔíéyˆfT %<,Ú‰_&ÛzÀˆ(¥ghÐOüê ëò‚Û§†w}[u½këløyà¯Ê –!ZÉvŸÞÏï¬,Ž.élžóYÛp(|­IráöBXì÷l3„ùbžž ‹ß=gÛ‘eHŒZò¦cÌ‚$cÃ’NgŠ¶å„¶ qŽ½-Õ‚8L>]`ê%¦'Ÿ”NjÚèÚÞù³èû %A ÑêÓ?ÌØêã×ß—@«;œ¸ÌdÅõ%WEdK¶€ìdoÿõEì _B´Ýï(fóx^±kñ\iöšPçÖ3ÏWôlŸ“Â3f/¸^d¸Û¥ah"z–F½L K$MîÅ£OŽ¨ÌR¯ÒèÕE—|þœÃ¤°dQµÞlgÜ_²å+ñ–t{ñ”ÄšT³æ›í#¨êåÓ‹…YJ1(;?g™åô¦èK?«Ïã¥xªz9­¶WE°¸á4ç„@køhUÊA ؅–Öé0°®ZE¸“üŸ­Jíª“ûõ×é7·?¾½½› ­¢VùøŸË×χð\eĈ4¶*;WAÔ=0‘ȘDQþÛ"Ê=ó×/¦R(ìY_T¼áH(™c~šça±óß8«ñ¶éŒ5~2ÚNé<†é™`U'#.»ƒÍ#¦£Šzýû¢«Ë£# ‘ÛO?7~â™Ë%­MÚlþâ•J„WõÎaö¡§Û†Ã#v]¹ÎWÄc‘tøžè*Oëü)ší¿h/ÉX]~Iÿ1®"Ûcïßÿºü…ôUóÓÜ…¹Šwòü@˜º4K§-3²™>ç|0X£‚¥rA·Ï°“(òœbI†ˆÈ 3RŽ_\˜ô”e¡cw‰5ŽÏ™e>MZ‚·Dæÿ7Ãû/@fãðÈŒVü' ßÜ­þa¿¾4°[›dµ¶Ÿ~@=²Ÿ"Qb¿ÒöSͯn¯nnX`)¯n~YÑ«›ïí¿¾úé-ü¹ýzõ—«onÝ£–>ä\ší)û¢1xpó õ|¨Ès®ÓÑž&Ö cçÓÅ?´CÛµõälhÔrâwu»Áf/‡uîcõ¾½w¯ý: æ¥ô¬š‡ïF»v<ù¿¥œp¯ eøîé› µ¬¤Ê“Ë›zß6HìGUáÓ›ŸÛbwáà:÷‰ý¦i|ÿNuè¨ÿp˜Ó\s7vírJ+>z¿=ãq:å°œ1vzœò šö×Î^J¥òι}‡D°õ×å„š< N0ALcÝg;ûéߎ‡lë”$ÄϬ ”’SüÖJ5PüíWy‘Îã̧oF-wcÜžJìܛؓ…/‘Ãpúòæ¦/>MS²}3fm·¿9uíoåvèoöÛú& Üþó? ©endstream endobj 7 0 obj 3577 endobj 46 0 obj <> stream xœ­Y]sܶmý¸¿‚o‘g$Š€pž,WI”Z‰*ÉÍC”™rw¹ë]rMr-©¿>Àŵ´,·ÏD,yq?Ï9?%YJ’Lÿÿ‹ÍìÓìSBÌšû³Ø$'׳ãKZÀJª2E’ëÕ̾@ÂUJóD¨"eEr½™œm¶ëjS5C9Ômóúúß3šñ”ž¿^Î~*»å½YVi.8Ç岫ô"i–K†‹ërXµÝ¦×?^'ÿïXÆÁœÙþ(OÁ)Î(˜ò<Í ÄÉÙìøì<º]5;þ-!³ãŸôN.ÞÁŸ³¿%™ž[ÿM¤En›Hü僉C¤Lx—ßµ› ;g)幋ï}ÝoM€Œ¥L \}»^cÔ"——Õ¼. FRɼ‰mœ#ÊIš'G„¥\˜Ÿ§Ýyvua–y–Joê¡Öˆ”)!,6óîüû÷æ\¤²ˆÞ84«à’ÎüÕ¶ìÖ’(R^ÐØÒÕ‰5D2ȦyÚ¬‰ÜüÀ”“‰x»m"8?»¸rË*ã¹Oèö®´ë4Í”ü¢5ž(Iáò|_uïÐyp:S±óPÛ÷nÞvÖŽ„VðõÂ(¡†ÁöÍDa㤩 Þ?yóÚ¾×wu\F¥wô‹v·È’¹Æ÷ôçz‰Ñj”õ9Àú üík×ÐK*0PÝ@V˜FJr·]¹¨0åQ ”Ì"‡~Ž”Õ«‡~ì±.[Ÿ:ïB‚Ïšýö­+ÀrI@añ@µ]}[7vœAÆÒ³Öm‡8Î*t€Ù3ËŠ/†iˆH;oX+JË}=Ü9aü1¯ÇÙ”› ]QÁð¸Õ¹6À"ZÊÐxûVúÇͼµòXaa¾µêò©‚)ƒtß¼>D¯ ñ AËÐãYåÈ’J‚ƒÓLz»s›è‚°—Å“P|¶¬K¢¥r½ƒaZZ‡@ÅÀ-›%ê½"ó9ÿOe[&T„Æ·¡B@ÆÇ´±imå´¼ ®‰h¢÷‘ÿ¡QxÐ:Ág\®°7‹TŸð€?ÑÙ!ŸH³lË¡¤$è\¯kxAÜÚ€f¹VHôiiX k!åä9ï!ávoFÎÕ•°w{¦òM¤)ò•Í•æ‹P²f·™Wæ0‚Å)™î…ª?DT-B'‡NÈ| wmïJ+ÃGÓØ,Š•—Fý1:åúú}w]Щ›É‚¸1¹ªªàž{þ•£_èÜ3ø^Œ¢À½n›àgúS]뉆9:™®ºÖµGÔu“ÕœnPCo¬6×µ$#X}Û#D(ü­Æm„£ØKº·]ÆĈР¶a@U¾‰‰ïœªgŠ?•ù¡j–®`†•‚ªt N˜Jy±Ë¥uÕžû\Üu³Xï–6ÛÇo£oÜ Ð‘þÐC"¡"3—”‰½Q€öyBõ… 5OŸvm¯ñ”,ZÛþhÚ1#>²®¬ûàfè©ù£Ë|Tôˆ.³PÉMùèd^èÏQK]¹ÝbŸ ˆA¼8x}@°7_Ó‡¼AZJsþꣲ÷·ÝêyåcÉõ`<×$Ö-U‹£ª5Ó“ìÂûÁâ½ÎÊ#€:É ›Œ"]+ò”®õfOé:¡þåܱD­A3Ïu³¿Ii¡NP•¹ ×åf¾,ñõ"Ę þBdÑn¶õÚ s-ÕèN¡q_F#è\b…# ÒrÊ M DXÏÃVDÚvcd8Í°>ñ‹vY9êçá–+Òã’Gmõ‰‡ @ àrÆ ¯šÞ)ÁHŒ:f؃Ô ‘¸ ͱ Ž«õÊ“j¸Ç›ïån@èSGBzmwë%n$¨7­Cz:1ófÀ!kµ3z•Â²¸ lAS€$ŠëÇ À<s$ï`jÖ   ¾}ZH÷Rh!PŒyø-&*£~6úݼÇŠ,ÍÉSí3Ðty¶1–F­µ@)PÀ¼ùg}^yàn×`Dx°«¶•Y– á,qh)2Nzµ;^E(ÔÁ@Y5B ¬[Z­§¡á»Z¥ÑØO-úáqí$€ ÁN&kÔðèè™ö7v,.4VtºÄà4Ë£—>4@pTÎe媜¹í¬ˆÿHà”ïtž¶Ëb> stream xœ½\ÛŽÛ8]Ìc…Ÿ³À´Â›xÙ·$“l˜K6Ý‹Å󢶕X3¶Ü‘äd{¾~‹on[£ é†Z«NU¢H\ /þg.·W¯>.HÉd!Í•k¿`!Ë‚É…@BêŸpÛ‹›«g7?/†n__=û÷_={£ÿ{ñö%ü¸ùqñ—«W7‹³˜{¦eÁõ£hÌ£à/_÷(l ºËíâÅÝÕ³wð¡B!…wï¯Æyà–¬(ù‚+Q¨ÅÝöêûÛz94»öow¿_Æ(‡ûîVWßïÞëk‚Jb¯½üéÍ­¾úêîÔˆ¤¨àùç@¤*À^ñ$š?k‹à&@-Úß¾ñ8Ôýo›†L™—0;-ÁìÙoïëΘ¸S²òŒÙïô¥²PR!çºúéi1J±žÎœiM‘œ+ª ò­žE6û7®pùµ°æŒ$_{îy×UgŒï 72 ×0e14‚ 'ôËtÏ !p3W14Œ‘ú2aç›"†J»!71¸,J3×몫–CÝ¥p#38 fdp) £’—e32cúÚÙHÉx1Ö/8c_›{æð2¾b#1víªÑE6…™Ñybx“%0#32ÏŒ€Œ—23pMQ£D_­ãæPƒá‚JGRdÆe*É!0ÂAg¬ïY‘š©$š¯–8%cÌ6E *È%49H>=Å«¡2z–$èÙ¿ZeH JÚKÀŸ¡Ûm¬zWÄ«÷×›¹›„ ÷€Ï TË=™gລh TŠ’$°'32×-EÈpJ·4×}¸ºHNáZ1šÞ uW¹Õê/0#38“WV„NIJÏ,qyfdFf˜ÁEŒLð”Ä2×3ôØH,Œ;î«é)#34ÓJc#p ÄÈ Í´Ò€)‚†©<“Ë<3f›b#—x½URê¸ÿëýïõòܻόÌÐ<36ºd))#34“2„Œ¡ ‘ Pçàš"†~©—¿ó-±‚ÁÌðmx©æUÇòêC’îÈŒÖpÓ.æ„ „U’ÜÐ|y И:ƒËse®)®à’^ ñ-!_ªIª ë¶Ú&q%3Z¯D<\&0JX"É Ì3Å#øLßå‰2ÖQ–P¨L‘‚ŽÜÛ®i‡ñµþX‘š«66V2ŠÏduÏ‹ÌÐœ‰ ÊSÊÍ `Ì`R’ (T&d!F©õ®®V)ÄÈÌ툠a„9OèisC3 Cªç ¥e®)^Çùõ)ãeAˆÝõq_·Ë”J’œ¡T’] ª#e¹=74“3èá(Á Jæ›â×ïÞòs£Ä…ÕíÐÕÕ6…™¡ùj°a^ªs;7<32Cs½KM¨„1spMƒ‰òz”QY`Ç‹¦ý‹ÌÈŒöÔ¼ðÐ$Uç–<+2ó¥Äc)Ús¬)RPöÕ[ç:ð’9Vì—þK*%™Ñ¹…óãD$¬‚åFæ+I@†)OI3€Mqƒ ‹$ #7·÷»M 12Có•$`È£s2Ï3#34ß—DÐ0;CYÏŒÀ¦˜Ä%²UÂgÇ~¨·f` ûÐõÎ4“P’^·äÆmò b1p¬_&°&32ý—p# o[æÀšà Uà¹ü½,…ÑlXœxaûøRvrC5Ù(aňI”°ê‘š~ÕÁ*UBó2ÓI„’hl)°šýÙÏM¿L`Df\nkkŒ(,eB½É Q ÍŠ‹VÌÀ5u”Ï7c4„5´än#ðMû¾«z§z¸–¡ÙÛÊD ã©„õ“9Цèñÿ?Ê»z»K¨FÜŽÿwU»Új&ÔHtÎUœºO;j“{Æë £Y`…Ê”-fs My}Æ£&“•ßjë<Õ%ïIHûŠé„4Ù Õ&&™‘RÄ NÊ*ô„Éšd†Æ0XKX€:MØ2Ø$éËúÞšTQÌ®Ml:4»Q!é ò÷ã]Ïú¼qo72‚SÙâÉÙÝèÖSq? –Å~œS‡µ-Ô•§£\hO{âï»Ý7ƒù8˜¤\Àß(ãD›äZsQ£†_ ÅÍÍÔŸæÂÍæõ¾5Ýß=\B*c‚³Åá‰ä§¸Vª()”Åk½Y„_{C‡yÝóÂÌŸnÙoþ0Óú=29´ÕI÷©DÃügo6íU ®[B»ÛØèÙ”ˆ3ã½?0 aï‹Á‚P°¸`Uwõe‰½Ñ>s& ë•;¸×EñpßlÿP/›ïŒÈÖ‡ ÂÑýÇ0¸ÑÓÌY.:'ôü—ÛóqUУáÌÌBÿùšÁ‡´ ³ðÄ^ÞLJfYm6'4@Ê›ö} |k¿ëœ•‚'ëj¹¶³@,TÝ bј¬”#çìdô^ÑñiLï¦ñ£Â”Gµx¼Moã‡ø«Fš ¦ûôwS%=H3"==¸¥§ÞÙÎQŠz+¯›V±éŽ? üª¦mÚfBªPô$ãH˜ÐISëj°¡,‹žcG«BoØ»õh©kƱÙßyÿ¡;qêìS³òÉRI¯/"ç/»ýjô Ô=Odk#‰§ù’H…<ÐU˺ºo6Í`èÆ„öŽçrH·;ÏHfaĪsy—H?s ŠxDíÿ.ë°—ée,”¥‹àYÓAâ/ƒÃÛjkݪ‹«òšw9.¼aˆá"$ 죣Õ~°á…B€ð°£ñð€mÕ:!§>Ž<§‘e©HlÇ`' ¾p©8&S2æÄv磭 ÕžÓÚ’#Tði[[pê0˜<9!#…üÜÄŸàf)jÌfõÄ›£ßmk;¡(°>»€`ñW‡TÝ}dêš1m´÷±,Ò4p8Îi È'a~d´³î Oúµ Èþ fo=OOi(œÛð-"Úðž;Áõ‘!{û-)à;¥Žãˆ„€±ó©<Ê(0Ut”œM>`Ǿï£/—‹äøËeäq?;¾A N;.E‚èc>,ü¦]5ND·YíDz âGo±xÊQUøt$Jªî1TLó3ä8_áPè[›öxž£Ã¨"ísí,…j1²h'¦s–±qÀ¤ª·~eaè¾Ù>Œ¼¤àXèrâ^[ûpTû¼¢:È_.%@IDeÍ°ðeYÆC¬WEÈÊîâë€Õ÷²Ýq°žªK•öó§lâ–†8¼ûÏÛW·…:e7Ð8ܸ\×Ë?œ‘T`NšóoÿõBôöÔ8%Ø0è [ ‚1ˆó¡±’œ)­{ ŸS¬­£Šú»7Uç`È™jë,!üg—»Í&$6‰7¨ŸM£H kßl†ë‘/׶ ‡"~ úuJacZ‘í['&ƒªk|i‹øØÕ÷MgK!DA$°'Jøðéö­ÍkQ³rrCQàâdc‰·UýP·«Þb€ÀçO½BÅQ7r0œÉYú8zåuŽ`q9Ñ8Çók†QÊ–p‰> stream xœ­\YÜÈ‘ä7ýŠ~Óè¢y$¯ÇyŒÖ³¶gz×’±YÙUœa‘%Òôü5ö÷ndfdFd1«ÔŒy€ÍÊ#Ž/¾8¨Owq”ÜÅê?ü{zýéõ§»D?³ÿkOwß>¼þÃiO¢:®“»‡§×æÉ]!¢ê®¨‹¨JïN¯ÿ£{Õ6K7óï~~-²(¯’ ^|Øßõ,I£4—ͳå(õÃ2Šã2Ç¿ûµ•gµJÓ«¿æu”Uu‚ý©[V³ÅýÇ8ªì³lÝÞY•uZâ_žÆIïSDiåöÏrj󗬎jz}ßé…šéY_£Œ*¸7þMËÔÉù^ÿ*ŠÒýª™ñ‚]ð‹ìõÒ4Êê"»ñæ"çE?N³(‰s±9¹ˆKûnÛô½}7¯Ü»Ë¨žíD ‹ìn—d‘f•uh¹Z2áÔò¥[Žx´t'\Æ·- ·í“VV%iõ‹~-ŽJÒž8‰ªœnZïÔ“¨¢¼pZy6{€ÆãŠkÚî{XO  £‘FEæÔð‹6‹(-˜Îô[QÁ=›ƒƒ¬KwÈqÚ£5 ²’s35'¹H}QpÑÉi'´„,8söt1»úçnì™oä wšñ) 2ô"Jh‘WÓ¼è§uT‘¶ÔSs>ýgeTgBë?/®®ÿöÏßÿ¤ƒ»¥Ð‡ô²¨îN‰ˆ’¬8Ò§O@áN?Jýƒ´â‡ZžÏúiå¹{jd†o§¹ÈŽímcán;ŸeÛ½’{Ü2Ï’C6öÅ|…ãX8|÷I~Z»IüÒv˱±bOè.óx27Ì£’ž^ÀJB«õ †Ùñg²VÁ­¼¸ˆòŒ+±1^ ^µ+*xÙíå«ÁÈ(¤²«œd3tÃA‹.Vx`i” êÌ@…Î`Ñc':bŶûs7Ÿ+Ø…ñ ‰pÐô«Ôn‘ŠT,6ª(H„{°(½Û-JŠÒ*‰ëÞŸ·dÀ>ò›¥QkÎ%ýö<Év<ןˆ£TÜÊøø3x’1%/gvK…Ýf‘´†œ pv¢P@Çõþq:Ä¥$)Ä­KÏò Š=.˜ØñDÙ¶ã°4Kõg¦“„Û΀®€VbãÔé6´¯ gYV]p‚ž5&&×ÿ¼Z6Ó¾ûÍÙp»Ý˜p™ãµ}3ÏrÖP”$Sä~7lõÎÜ´ÈœüÚf6çVÞKv§¤Ô¡Â>š×G´“Tù®Ó¿bâdÝÍúé¼V Ò”âd"˜Ñ2XÕƒp³®ë ë,÷÷x‡¬Úp†¿ÛN>mƒè«¶“C‹`\ÒÍ1x’Í ¡K‹|W¬%iÁ÷p”Áa¥œè Á:»¹SH¡ Ú¡ïÚ£Bšâõ2 ·tçBþITW5j.N0\)°GÜÉ辯r&½'¤~,B7]¿"ªxÒ éá6†÷ܳÐAdèéÙ¿}·;{y2ô1d0¯L‹ã;ü­Ž‰Î¢;eÏk¼Ϫ´ŽíÙž°±· üí+¤ÛKUèªcûVs>KcŠÜ9ûpb«Ë€‹³ ×yVååXÊñ# –ué´ñã:0ÊÁ®Ø¬]ÑÅØÚÌâôÚ[ÈI¿K¿×~éÎÆ߀òûy*4xTpäù!‚˜J-/ô8'ö <ùð{„÷š +™ÿz‘™AÊlõ4Î6€³“^Ãn'ã’Š©NËï¬ó%ÙeP2wqrôèq؉æí‹®¬ÅÈoø¨.¯`÷WÁð-9V·lÉÒÏWûîûâŠ4hž’W~0þRi²j%„¡ÒËt†ÑÅúu+'•, úŒÀò³R¢l“u—ü`Ìbk¢T¢^)`ÙšW­~× •%+¨í#4ï„èàŸ¤Ü?6í/åïi2 ‹mÎÀ±œ"§¤ãˆõ9¸'‘Ö¦ŸG¼'#­k¿½± 1«ä"Iõ³då)÷+VItõ£ŒJöRž¶!äÄvº aíT3ŽQè<Ã:†…/–¸°$‰±N$YûÌ©l©XÜ2ñÜßÚnQ§µ­¢˜Œ,•Ûœ@=ý$ÌÝ£ƒ*FÓ1Þ{œ±9LÒ»¤Úb ¨7E6¯ ˜r6,7K8>wpQ¬E´æcÎÁ‹ítÛœ×T/Êh½1‘.gA(S „«ýÞÕX†€ˆÇs9¼Ä`)•HrÔøé]Ñ„…Yswˆd)7‡=dð¶lâGž40^8Ûsˆm-4ãü9¥¶XÈ*!z:µ<ºßÒ‚p*å{öT¬H×X˜½¬™¢€£ˆÓ¸ž#´‘Š¸4Kô»0!Ââ^¡Úµ<Û„ÓÛèJÝ>˜Ó¬“Š©ˆÝYq3§ –Y†P‡¸†ê(8þŸÑ ¿Dˆ•eF ãCƒgÃürþK ^ñçu°U–:\P­±?ü˜æwŠ ÁΪ™µKâ DGÈ -ãz±œ³´‹ýè(¨ÂÁðÞ¸,7Qà²u¶«r ÷aÀ¸*«ë‹¥ú¥~nF‡,uºû@…D¢¼0(ä¼ †:çU½ëÎGü8ˆ{cÔÏyªî :ßp+ž¥Y ³÷ʘóûõ’"½l^ÔÕ®”Žƒ²q@Ì8¤³û/[û Ê@IE…ùyÞ»/R±ÅÒM_ðß[˜ù"·XvµZí󅀶^YYCØÀÁ|Õ…j-CˆŒÕV†9A–ªO#FV‘¸ŠE¸ýŒð´%ËW'~¬ñiù‚ÐÚºìyáÚ7ƒœà­O§uè}0ŠjrÔVe(Ç*ouÍÄf‚ŠßÂ]\ã“õ1ªâŠ‡g{Ù6{[H|„|ò‡g¬bdª…êlé}e43Mÿck¬—à%’ÆP*-eûìÿ ™’M®EÉ%Ò뎟GÆl ƒ%£Q¡e¤¤ƒ“\Žã~ìǃ^¿ˆÁ”.ƒ Ó9œûŸ •U‹Yðd1M×úg…áZ QgfªS±žLº(”µ‡Zv)Á2ï²€p¹’Z›´%ÜiBœ.”´< ]Y*ªÄJÅÄ{*JÑ-鯹Ú£l±5”çp“nBa3J=ö®¶àD()éöè1ð{Æ Nt$FÔŠvì‡yðËÅ ¨2/ÓÚZiAJ‘Ñ®Ö>f[A‰)ïygY¨.~ð\’åž,¯ÐoF,/¨š×ºÉfãŽG¦³có þX]設᫇Á­V4‚+š˜e•‘²8».ã èŒò~m98#«6pp895Ϩžêöƒàn+ 1J…ïL— „W®ãù¤º (ŠšœýzŽ3zÇe%¶<«¥è î ÌÁ½ÕdŽWo|¹Óºž>±„[“*œïô#>ã2Ø‹®9%ÿ´‚£¡›e¼ÍàÕ—YÆýŸÍ€—šsm(Ö6½hÁƒdk›¯U$x™Æµ+ÙÓïm·Á«eÿÙ•[±ÝÕ¥C}c ]"áåó#òši˜¢·ª©xŸ’ÑÚ•ÿaÊÉY©*Þ^ˆýã:a˜®£*Ý€ªçÈÿµ4O£õAV5yŸ]ºiJ‰ö$Ïã´àY T24F—‹Ëö9CÜq²Q9‹y½Ëžë[0̹Ó6³%ˆ»ñ6½+¨ñÈz@°HÌ3଱i0¦E^¹Pźº“ìq`@aJ"‡Îj±ByÑ{\z¹µªó;7³…þ2*i•&Ù PIºžÖÊy˜$Ö.½Žó^š¹Ã4æ%Ã0C=uˆ³K„R`ŒŽò;@,Þ¯º&÷`’•YÒv†Ts†ùv@q,/é÷ÿ=t¿¢ {³ê°  ;~~¾#ò)T'ÌIõãÓúÛoÛH†}ƒÙdÅÈÞ—W¿'ëæ2›¥yl쌄ÈTÝ‚ëò6•œé J>÷>‰Y©Ñî ú´.ÁU^ßšÓëŒYjqîzäî~»ÿ}q{±ÒwnŒ˜×ëîÉ®íîbû–A¼Zgaöµo©×ÈêèA¨û©=N£Ü»éÅ’3¹ŠvIüu´süZ ÚÒÇx¡ñ Á9€oýœ|›Éñz–1Ù‰Z]6ÊëšëŸÕÄâm/«‰ù ™ojWjb¼ª6ž×ÞŒ¦ªÚ­ðMßïþŠ^ DÄ™V7b­/2½:P‚h¨CÛ´Ëjù Ø>«´XÛ ¼~Z°Šñ O¥‡L´~yp®&W˦Ϧ~à{Ççnïf±xFd ›÷¶Ïãöê@°žÖ·b¥35is낵B“iWÛôù85’RsƤSh³©&ƒ³›ó¼N¦Ù>ÓÞŽ§“‰öiìvøM›z,¼pfÃà ªýâu7¨Â\‹'‡d›j_Ø#ÀóÚªÍ"ÊL" R|¶)ÅûE¥k™Ï=Rv‹q^}ŸHQ¬Xg¡Šµ—zSFžð©&Oœ©/Î’1X§mæädh@y•$eˆìDžB¤Ûá?p‹E}6wœ Î÷ ÀÝ'cØYÅËfv€‡ëÛ¨Þê¾ù‹P?Á†OD+6iQ±dQ1.RaŸÀ8‘³î3®î0„>­qý÷œ÷hx1ÝÁþ°•éUƒ¼ßRí—võ 5¡_7Þ­\»AÍ‹»Á P”;Æ×/|ãã€av¾ ì„ò±ØÓv8“ Ù¨•£HlJì²Ê¬nlC+ð«eÍ pÞš´—S›PjáQYMñ‡[cn>¿í²q$ó\'0Pœ­8X`ÛeDÔ×~¸~Š´˜µàíª8~¥úaàtz @ ü ªvYéAýÁ4ì¯ß2Ö )Djw|0ñ©ÊDæ¦Q€¡ñƒ$¿Ø¥¦ýC o~âÇ'§nÁ»"ú vr–è[`)¨VÖb¥Z³®~Īp ®æ-@ƒÈñåH’_±c©VªøOµÞØ€B9ûŒreECpD9–#&r9üw¹ÙœOþÞ¶4ºËÔ*ó›÷^F;Z¥çýS?GtŸ3LJ+nCHÜYÔháØ´G׬۸!ÿÒç,1I)yÙ'4Ÿ1/¼¥ÚÉü¬Ã.#è(}3Öæ€uÕhHÜO¾º¯¾R§Ð϶ÕòoÁÂdð%_LÙÂ>–tƒ8}ƒ¶ªÊS= ht™è,¹€¬s?cX›Ï6!u 7e_Çy_öamÒXhÅóŸoÐ× š} 0æS3¹Ì„režÑ©ƒÓ§vjl>´ãÅÏIn@¿í©Â~Êiô[¯œ[ó2é›3ª>;yž}Æ+é~Y¸ä)•›gßüŸá]«ªˆ¦*;çôÑ»uaÉLcGX¤u®_‘óYŠ¥±ŸÀ&$̃tårR;à¡/ËöJÞ#£z_áýÓü;:õmº yï\‹]Ux q±ÿl¦ÿüú_ûd#fà|«O[°÷”à_ü­¡ûmpFÊ›¨s`˜(öpðÂ;¾²Ä:œ'©þ û!…úäÀÏ)YŠÐ<Ï®çDÿVꯆP'¬1HgdY¸ES ¿tF ϵû'} $£÷p÷·×ê¿ÿ«?´endstream endobj 61 0 obj 4927 endobj 67 0 obj <> stream xœ•[[ܶÜ>í¯Ø·$è®,JÔ­}rÝ$] q\g[­ D«Ñ‘ƺxmÿþÞ’‡<‡#ÎŒIÀÕPä¹|ç;½¿Œ#q«ð¿ÍîâýÅûK¡×ìšÝåŸo/ž¿IJX‰ª¸—·÷æâ2—Qy™WyT&—·»‹o§vW÷s×LWßÝþ÷B–‘Hã ž¼Ý\|ÛÍj­ŒÒ¢™]›ÔZåU) \këé“ZMDTTyŠ«ó Öàü×Ú¾ë¹UI«()»ÇØna}£O‘ÂS÷—;µ”EBVv—eÆË naÖ6ݽ^„#$…=Â};¶ýlöŒ£\¦¹ýÃ0îôE’"*ÊLÚ#?Öfë’_dz–íFo"@ÒŠâSךåDF‚o¢¯'²(/ÝI¦z×â£lç±–­~c’GY!íñÞªMÆöNK5-£œä´Xe”H·û‡nÓõjýZfi$“ìòZÀ¥þk­þPD™¬b»ËÜNæ¢HÚgëfÛFo¿Ó;•‘Ì3™ê²\?pk®–€ýêðWoê~3ì´õÄQ,œxnÞª²romG½C±“ؾBd¥•»­•%H‡^x?l·ƒ=íò„"H²(¦;Á÷S¤×ÁÞèt?¬O7裉$ŠÉ¬¦õ–GB¸M»~olÞ•'tz5ÃõMž¿¸ÔžgõZý¨Fù_^Á¿•ûýN?yÄWeš)1wYß;“QÎöþýɽó$’%ßú-øqóˆ—íXI퇩›;ÔZ^9 ~0Lr¦_ƒ‚YZ×Ïíµ±Ì\D²*¹==€¨Þ~÷G-vØþ–$öo"Âå,uðñz6KcÑ#&®×/Þvhây”3¿?*>‘ƒÅ_æ)˜æyÕˆ¢Œbp3z|ú´»¶ža•Šä©ÛnцZ½kéÒÉÊré|À7µLpØ6w;Ni“€êÝÝF¯ƒ™¥©Ó«~XÓëÇ= ÕÔ ½Ö‰¬«Üߦý 6ɾà€öî×2-¢ôÍLâ±6ñ¥­—g,­Ð‡ä–†‚ÿ·>ù`‹ÜIïÃ*¤ÔÛ¥50q]È(-+mŠ ÉS€.}STQ¥Šóµ)&Å—™bÿΪâËL1W‚g?ë;# ›”ÓiQS¸Zîƺh‘Yœž?í[‡§Y ™A  Ê@Ù¨Œ¿,ÖfžT3O(lê·áMÊÜíê,<>ó{fã2ª(t“uê«p:ÛÀgl3•Ü6Û~³@Š&PeQ;u'J?ÑdÕQœ¢;ÁQ)xÔ£=¿$=ôüVÎÒw*\n5; «Ý16`icw‡Ì&!«\,·J”Ù»—åV"Êé"]Q´Þ ã˜Ñ¨p$Æ-Àaõ¨qIÛÖ{ 3»ð>s—â1qÅ  =º®FøˆË(ÿg*:!€¯+4PAv È,qDîÒL„{Ý´«¤=Mõ£ EQeääkè ¡Ùˆ„ØÛÚ-¡ ¢È=2ã®wCÇÌϳÙÎTc~Óõ¹ê»iØ.³E¾J8h Tu˜¬`ßÆx&fz[qN¨ëûîmbÁ‚ä^ ÜVÃ4·‰ÁfeæžOÖñ0¦8[o'kà,L©VÇVN°ØvcbK»Ø‚‡K±åG–%úæ” a“*¶.?:úK&Ãn†^¡6  À?uÓ^ß*á”D=®We$“l¿MÝçöt2öΕG£[Z‚:/ágQvž§¦•†ý8äGêy¸Ù\w½uÙŠ»ìÛowÃ4o?™Aöé›Ø¡K¥*Å°‹×Œ  ÆB”-oÐÆÀ2bá¤gÜ0U<—FËþŽÒ7eÊî ÷£Q'°íÒÏcÐSò[±6ã¡i–A«dáeZ;Áýغ³Ñ›ähìê»­åG Ü/Vy¡"HiUéGdÀŒ°2Ãʦ„/M+Ïö®ða–ƒªÏ—F% Ñ#wꘟŠÂ]h0ÜÌÁ¹‡Çr3bL]R)Ó®ßôhîyˆZ”D-ž“©,$©N”žõ"ö±C¬HrJ¼Ú‘·Ñ¦m .3ã–Œ— D‰¬NsiaŒ|)MRߨá6Ýh1á " ^,á÷ÎÒ5Û±&‘U¸JnAXöüMs82VÐy}{óóÍ¿¾G–órÉÔÎ3…IË`B’oA¥…®o¶ËÑZ–À9ànúµ…“²ÙS V‹…¬"*GrðVIRAÕjM±á.(tV Á,â@\ MðàÜ£F'…–ñŠ›'4ÀêŒ t"§6y…>šJ‚L£dpu‘³j2H³˜™„\lšaƒzÜ@°Ñûd¥*bÙ÷² ÆR‹û¥oÕ›ð4†%âð—K8¼Téäšú0F<$‹š9ƒÈ#.[ ×UjeÊ!·>T%ÐÕ’àéÕ/·7¯~ºyÖ"åƆÁm«x‹˜>†ÚV"#TõÇõª­þÊŒ*¡:o=Ïín?#¼–¬bÎ) íêw„öM˜à –Fû¹ÛuŸk§^UP"Ròd~Qx½w-÷9CZÀä™ü`ý>ÎV!óîX@2e Éì#©Ô…¢‚ÓÁ,G dJ•žuºêçÇ2` ¸9ø™½InUjN&.—è` +ª"xªŠ•ÔÊàHù”ùY½®´Nˆ…,r: ôªfØíKµ!š±¼øIG’pÒÁ7qÖÙº3»YÛ©‚¼å'T¨7z¸1ëD¨ct[ËN!|3Îbk •_[ð(«S3xa$Ê+`‘ƒ_›&¼$eú8Š'—"?ÔUâ9¬a4p…»JreW.g‰ÊdGk˜Ç3äÙ“-ÞKNÿ¨MSò ŠÃfV£xzìÐÐ*ÞZ8W:!kyh%RJê«ÍkìC/_¼ ¡4Ø`A8‡š,€+ªÔú6tvžj©—:u¶fõ°ì0øôÒÕ<#àÇÎÎ^óò/Á³Cä`g7(&TÍ ÅòŠ½@)2;Ðþ®Ø3[Ým <^f©£´!$‚—o –WªÔíLkM1GìO(5–(5–ˆ”<Ý嵉µ_0 77  ¹³tà\¤_éK=›§)ïnLÝC_ck`4Inš(†ïÞ4ŽfˆÜ—XA]™×åŒ „ÎÉåYžºþÑhw´É 9ƒçžÍ N®¥ þ ~mï4Y.ygZ«ÎbHfãñÉy‹IX‡!TH"*Pñ4Ba&º‡Ô1’»‹F,RïÇ¡i7hý2çÌ5X\2P[pý~éšwŽÄ0 úŸ¹LÅØÔ„4¤ &8“¾Ø„©<¹Çý°`WòòüQ¿¶&Ì¢Hˆgu–³`9AÁXën¿mDjê¨)èÚçhªàÎàâ ¤­1K fcE)Ì`Ö ŸXsñk c‡ %)¹CHž/3¸ÉÌd©=‚úåõ4µ£½¤jÜ÷8«N,®ú+^=‚ƒ XKE´Yãª@Þ¨RÀš„i¼B~V@·<æî–)T¼=¶ó2öëõ#5éÉv#n†e~^¹ªF•ç™2 ›z™ŒR%*æBÆU&(F{ö—©!UüªQàe6,ÿ#â—pŠ†ðU2.즞\?*wu¤‡§aš±žñÖ7BBÆI•CÚ²Þ„jâŒX#Ù1 ŽŒÝð"Éσ¡1  1=@=S°c8‚]Ì‹ oÁæq~û¹›šoÐèXµV Æ`#²Ë ºx¨2«Ê¨>]Êó¨@áÉfÔ^]woúÈÆ—!ëbsO6·Èy´A6ês=Wó'´þ”bK¾X×u%&i¨ø˜ú –æSêÄÄõ`‘t7Œ®•ÁnŒ©)\ÓËž°cb›* ô.—ŸùçwÚOtúýÌ ´{°cpF9öÇH¼ I@x¢ëš0yt½*wØ;©„{=z èt꜌ãAŠÜ Ë„¤,ÍܬU5w;‹ ‚5 A‹j.Ùþ9øsaÁslïQÁ—q›§q˜1+V¥[à Í1eýý¸ôpà‘î‚h¶Þª¹Bl–¡!Ù¨Pl´-¼ù=›°vRfØÝÛy¼¢ò;rþ Ï\ÂÂ5ï³D°:“ªÀm¶ucK Ö_N—俼¹/dÝŒi¹ã“yÝ[ÑG”•Ôî:uÊRA—׉ímäÍù¼ÀÑ`‹ÐÈúì½›t$§€Ms7/.JÕíÎ6×ÆÁÎàiófB“Jc“]€Ví"6kµ£x•e~è½BŒŽ¹Ýº~ïJŽ`¶•òœŽ­ ªŸ‘¬Â¯#}|¶UÜ$ÐÒMÏL™´dí¯™ßcPÆb¥ÄŠé¿(ÿ·¹c3_7ìÅGªöc»6ì ÖPh’SÉáN™*:®|gäèO¥°.ûd?\·¤7{ÓjZkpE$‰ymzÁ ™¼À)I4 椅_!Ûc$Ÿâ±²`ÅÐz™‡DDUå0Ã5ÉО¹†6cì!ï¿E‚Þ'‰5a,ã)`þŸí†5¥‚s›vêF;)ȪnoY5/4鈖*¶¬ë5,À…îž’h<0¯¢Lœ7> ç%yæU 6lºØu×c 6[½PaetN%ŸÔ@ÄÀ 9•ËRiŠ”'o€Û.ÒX@ÁÒá0‡ òÝ¡LXé@åHB£AœÛÆâ²Z9–Bb¬{åÆ¢J.\«ç8Ê(²¤*gqdú¢ Ìj¡,^¹$"_Õvý<æ~Xƹ5Îç¿ë ÈR™fLèÔ9ïéÏ 7„tok—¬+ÏþéŽÑˆ™îÕh\]"üøêï62“í¿üéæ××kƒ6¤O!ÙW½–‡Gãm`s©B-®ç$Ž,YëtÖkívã ÍæmWrêë‚×¹ qYÈfB)8»üÌûD#ĪY¬¯)ð© {ØgnòA–¼ÿíðXž4¡+DAÆü—‰è%£²8.–2¼Vn- ³ONÀ‘Ñ4Ùw%?þõ3J$¦£¾˜·FiÀ„ŠC\Ñÿ|ý ¦Špkv¢z$¡’T ßNw)ÕñÂhn×ͳëÕ²3sýÊiK]©í};vÃQ8§Èì0ƒU,wE8NTòRÝ ì1xh®l–fÇ‹RÉßuæ¿Š4qÀ¼CšÍfÈž}Äû¤TÉwĈ1Š·6¼¦íËüjfíã+”ºjVHÁ«fST…_²}ª—òüLÏÈÂ*Ÿ¼í…¨°Å>»xDä\Á"¾‡q òŒ„íÙ1¿ëú%°Ï‘ÖôŽ1Rv“05mkËñ,Tkƒ/‰ýNŽNÄÄFÁÁz3¢NKÕ¨m~‡c ÊýÄŽ l:‡ÁÍ@$6àã³úÔ ÙFc³Šàà–®[»^AÚSZY…AŸ%ஹhƒ{›’™Ñ¯|Ä̤’‚éÒ¯ò‹&8#e”}ô±{xD§TÝTt¬¾š9k#V£ÎžœÝ¸àD„@Í×7÷t7ÿZB͸xÅÍP“„ ౶NÆö¦ÅY¿%PD a›6À/N ÖÎeŸä|l×û’”ÍHï0sòƉýßej·­aÉÀVÙ[vÆ/²½0|8`¦M‹^”ñ†íÖ¶Hv?a<ò†²õG(‘¨ÿùн L¨ÖLJ@õËëDçêQi¼š –…›Ž1úŠ ™ºî'}w“¥Ä'ºp» òRó_g4‡×%¤f¹úÆ+ô2Ÿñc_ȯÐw½ní¢Çy£¿ÁéÕ]º¾«±!“©¡úcß6]½ÅÙ1ä ¥<9y°Øn;_w¶ÉTÒg0Ã^™â0Në£:|a_:ÕëÈü¡›q/á_líë‘M,®Ê7ì´':Ø9¥‹k¼~~[£¬3UrÀ?Ù~ªé†ø”ÞK|>2w?د6˜EOóм³¡—‚Ûc=nžp¹¢Ïë±½ZßÜ|‹áÏâÙᦌ}¤ž(´ÝØŒ•Ú~²} ÖåuE>,?4Ëx ]±Æv{¿vuL ¶äÚϬF±Ö ÉÚ)ÊòÉYû)wÉ«Ób?ôÚR^Ê\ñÉ^L8ƒdTË@ã éûÛË¿]¨þ—‡š¹endstream endobj 68 0 obj 4673 endobj 73 0 obj <> stream xœÅ\moÛF>ô£…ûPˆîÉ pÄŽÚ3`'®-·8À_(Š¶y‘H…¤âø~ýÍr_)­Z-{P+j9;ûÌ3ÏÌ®úå8 Ðq(þ©¿ÙêèËÑ—cšD$ˆº‘ ’ãˆÆA’Ça”ˆ¿ðÔéùÑÛóËã¶ÞäGo?FGoÿ%þszuÎ?ÿíhz~ü«˜ ¾Þ̓ƒ)#ÊÚÍDƒðu3¡ÎPý'[ŸÎŽÞ^ãFrt<»?’«@0¿°šG§Ç³ÕÑÉMµ©³ü¾ªšýçˆâ€$H˜5[<äb ‘ó«±Ó̓Ä0 õàßÅÐtæ[bIüW, Áô ‰Ü•Í„U,H"xVú¼–KJ‚õÕ}7†‚˜l/Ó¿&Œ)W›>êš0/³Þn}È›¬.ÖmQ•ûíc,ä®CìÛƒïˆcD¾a&úÚHy=¾„¸óX‚BüûÛ.PN˜kÚÙ÷!6¶U˜  ¤Ôµê¦X­—ÅYªA†S” íhdêhɪrQˆÇÓesJú# –Uó}¨²Î=øŠà±ññ€F_sÀ×Èv|YÓ†àkd« ¾¬Uÿ|°Î=øŠy-¾_ŒÜ €×ÈfxË® kd£ ºŒQçeVÕužµJÍ„ØQ3e^§m¾è>bîGYµÈ`è€ÕìÁ2ºÆbŽZ‘ Ù."kÚl•A‘µjT°œ=0½*þŽ #œq"aÄ’¡0Ù.#kÚT7²UFŽUÕj],sYZ‘€3+¨,ŠEùcWHစŒªáV–,<áa¤†Ór±ì`ED…B™ï²hVtß Q3÷|YeŸ»¹£ Áfî¢K¶o¯YسØ&ÚŸ/¦³>À“{Œé_@„ˆkG,€à‘í2¶¦ !‘­2¶V½@„ší0 ‹ˆÕc^˜1·â¾ýøûùÇ“«ëO³éÙL>ß7‰SPk±žB@•í”šÁÕfÙk€K_e!ÊC=”.7ù™x€‡÷ ¡¿€›CDª ‰Â щ#ÛemMÂÍ#[em­:ïèÅÄw€cª‘å×¢|ð!š„A6¾žÎn¯?N~¾þtéƒsLƒHó°óN„tàÖry{1;¿º˜N~{q;ˆ/pH+ÈÌru­zs¡eïO¿ìŽ!Ÿ9QÀŽôƒqqÀþøã‚ñ8½ýÃ’Ä0>¨:< <Û.Žiâbl«t\8V—­ì‘ Maàö E Æ‘i›>4ªŒ‰ÉRgôu<9¯ÏUÇAB‰V7]ù>€‡8bŠFï1ðš˜!¬ôǶËК6€#[eèXµW4ÏwèYvéñ"‹5ƒ?dÛùM›*I,¾Î,§Ëç¦À±€qÈFo ±Ö¯ðÉa0¶YƲßÀod£ üŒQ/Þ]u T¥"@n%pÞØS™-6úøÉIõmµ‹×¼®«2¯6žÃZÑ ýNGvç÷RÍ çøî^­â;À>ÀÅ{€ SýAñlÀøǧ2:`ª×BácFã€Éæ‘fíìþûRcæÒ 2OËîxŸÜšuž² NpÀ±I¤pÖE:_©zþokPBG¯z¬ :R1MØä:²]†Ü¬iêù±­2ìf­º1‰P)›D¸*¾mÖ¨B@±ÎÒM£ÊÁTmYÚf*ŸF¶Å2O©ÄÐÃoèç’Á–óê¼ÝÔe¾’ŒpÜÀbþê{¯,p5UåHÂCìÈvÀZÓ†¤ã‘­2€µVÙû&Ü’GZÖîýZ½Ì•=5=³Ö‹÷§Ó‹_ýL¸ûÜßTâ`€‡ú‘ /`3Þ)…B¶WY>|š_N½æÑ$`øõ%Ö›»'¨PDÆ/±B(U‰ÅCÐ=‚jd»LPYÓ†d‘­2Ae­zAäΟÛ\tv¥òŒB­žÒÚ={3õaò#WßÈ`Å‘íÐfuÚ<êxå®jne¶` wÌ{.Šf=Ô8w¨C^¶QNÒmBQÌù€Ã¶±íê@©cÚ¶ÁÈFu˜&Ä1j„[%CàuÀ:÷Ü°£ —œÀe°‹âš¤$‹\¹„ÄÆ%y¹x×E ‘5'T,’Ý=̓81 öL;p—+ÚÇZʾ8@¶iýT*yˆb³3ógUå0+uÄ÷täV¡D-AܤM“×­:$E6÷IÆê_ílÕ%PŒæí¹Æ СQ´lH@#ŽLÓ¨Xnê<¸ûI|4ÁQGlÚS×#y*íˆB×Sõ¦l‹U®­B¿‘¤H~Ùy˜A¤Xƒ”3ªÉ†­3ùßýÈʼn0W‹ Q÷Ào»Ë;´i’Ø®±Vÿ»§y ÑNѼÇ|i<â0`cD©@8ï>õ\ 5ò®9äÝ._l5&ºÞטlÔ¦:פï«<ûŒ9]H_Wà—·ªJÃöÄóìâüæJ•þ42ß÷EÐuZ.ª•Î¥ÌhUå÷‚PÃÝš&$‚­c\FÜ„‹Cc„ºÿ¢25 l}YÛ·-"{W¡\oÚF)ñ„›qûä\Ç^‹ù«Z* 83`RGg°UŽA Ê!}C'¶ò•r#Ä–þÂSÑÊÚ•ˆ5sƼ^×Õº.Ryüá’$½eÉ0¢b*³ñýË@âX;[ÑÌ„‚WA͸ ‘–eÕv™ª‘Jˆ i¬Õ¥"(Jú¥W‰Ý):’â! Šì» ZçÍfÙêêß0+QÍKÅGÄÍxbgQœ#Òñ×r1q»ži¹[ÒoÊj ôTüW:ˆÅ€æ>/`'óºQ ‰ÅbŒy¾ûù½õ‘-ät an+M2 ‰¸AãîÄ{¦ÔsßJº·õ °o)(ŽüB;MÈ‹¾wmÛ);{|w~óëµ·DK²¬ñ˜:w"¬[dÛQŒÚ {áÜ$¶éÅwnR•ž†5Ü*¯u’Qø‚qŠPaù*/%ºßùV;!b ¼Ÿ` `SÙJ1z7cârkY,u[Žøñîd™®æ‹t÷ù»“o25÷¿qw²È³eZ{Þpgb6%ÆÃw'«|5—ÜÈÀÔÈì0UÞ mÐNï­Ê\(Ô¨‹¼»Z…Ãéñ¯s“ {5é}Þ>+ƒ ;ë%ÀËÅ?™´¡PŠcÔ½ Ê>%š/RQæ¶B¾m}OT¯ŽÿøÇ?w×4­ëª~·;×)ªpÏâ5椦b¹Ìvz^M뇀Îî©b½¢í0™€z 8".¾Þ¯ºF¦¢ðØõõ+ ¶ NX¶í9 ¢*Ë62s‘Ï-‡•òÝ`Žm&ÒLß+Ž½¯Wºw; ȺQØ8+}Ì*†bá¡P/»°Çü¡ï˜?±·¯Ô&ö^íµ±ÉEIÕ-^ÜA±é¿Ui¸·xï=9íN‹¡÷šËéåéôÚ·õ"/Ú×.‹¦ ´XµÄ9S¦sw-¨ %E¸»2ÿA;ÜØØ#æ^ÍÀ»ÑÒst³É2Pò­Q 2ÛºÈЊ™ºWC¿énJ%˜s)n•fuåçhp7)ÞŦèE~?L9BÉs%©Õ?tÍo•3¸'rûìö㎮¿ëàªÀƒ(·Ð5õIJ±ñ7x¬#GË ‘#Õ7às¥Fúéù…ãŒÞÊ_(Q”ÀˆÝ–¶ïDdûª9²U£/x**Ì" =µï‘ÃoOr(vܘ>ï¾ÞQÈÆ„¼qœ1fÔfÂFêG ˆßS¡±®N¥h0ë- :Ä;ú³·i]Ë…aæõêu"C[Üb↶֫ý×ú6ÞTN{Á!¿’ºlÓ¢l<(óyÎ'Ba) Pÿ³σÁ™bСCI;»–É1.à`vYÄ`¹Ph ]D{]³\V»ÉéI1\¿Üy$½ReÏÕÞvK܈0“®R8ýü´)çÕ7õ.ç¼:ŠœP(Š8ã.Bgˆcª$<›gð¤Ù §,Ž\fIGw¼±û…û:•=‰[æ:¯·UýYlh“™*˜`J+L 7>£=- ÅF}šLäH›tÙT Ø¡Íâ›&¿ßÈ5‡®Oui¹÷¸÷.¸K+ó´Qu"àƒ™%öú~¨È^­‚8¿G'®æeíTØäΔ¦€6uOvѦ’dçâmQ§:uÛÒóižfŸ›w:mNÓe„l D¬A窔6ØŽ…щ=Ëäo@…,çÖÇ÷Tó´UÞ¨l’XØûõÎIŽKôÛ´8«ôâqÝw!釬Pò‹)œ4‘ê†qä„ïØgUÕª«ÂDPF}E–mÃ…ÈAÀNvó!žQ>ýª8‚Û ÏuñïÆNÕùLt ìŽk÷xî…M›]jÔVöõ°b¬^ÌA9-»Ã`8ðÆ z$>q$þ^ZS+„±‰"b•·E¦T&µàPR£gW“[l$/¥è 9¿×#èüwÿó[çÞœž]¼Ñp·ìvy«Æ”¹¸êîÿ/ê3ˆ›·½‡©T?ûí5¼Bl7ƒ/v•¢zr‚»S+I‡D>Çî£Â…4ÖK½¹=ýûjz囘ˆH;ªkäÀw %檞áÀuÊiŠM™ˆ\–leâ\¼Î®v4F³)Zý‹çn M'xä+2Õ›.òy*ˆÞ¿Ù]¡ùóº-ÌÁ0·M“oèJÎy_ß}g0@¼màméñÈs§ÎéàÍ«Ö£„y›×«¢„²P®¶ ;1 H»µ¦LÝZêBA´.êzäBmoûg¼—¬•©:¨±(½Û.åÂ톂fÞ|‰FüÅ:ósiÔ¶YÍs å»®ê«<Ò¸ÙÌM§­'V+ïÂú{:ÃÞ…a[ïÚLÿZÁ“N"6m–¸ØWò¦÷c†®ëÞ¥õî Xüûºc)zendstream endobj 74 0 obj 3752 endobj 80 0 obj <> stream xœ•[ÛŽÛÈ &oóz[°8$»yË>­Àëuff‘q€P5b–"e^vvöëSÍ®îª&9²¶AQ}©:uêTuëËÆ÷‚¯þà¿ÅéúËõ—M0=3ÿ§Íۇ뛻H=ñ2? 6‡ký…`“Á£xg±—†›‡Óõ«Ï¯úq7<ŸËóë‡ÿ^Ç‘'à …Wöׯ¾ûüªiõ\d^FŸáç×êi{A˜„_{;øüZ¿¿ âÌËÂÍ6ž”Ó‡_™>oökªgAæÅQj&§¹C/ÊbÁVªç†çI`Ÿ7Um–”f^”¤Óš¢ø[ÖÔvËyøôlµõ¥¡ÖÍ7è‡7waÊ· ²Ð Ãl³ C³À‡c9}ß÷|?1s=–MÙåCÛÝœ»þ«ÞHÔÚ­Ýòó¹kóâ¨>‘¡—ea‚Ÿ´‡É¢—%i`Ö£' b/Lí$E{:Wµ\^BCtàªö4™¶•ÈÈ Söƒ~¶Ñó§i}^’ÂFÍúúiÂÐó3ëWXs]•‘ç§"6㶸dÁ– sUÍ£6£‹ð ûòýÏoþùéý§5ƒGʃv[žz%ò˜–ygwº•R‚O…›iaäe„Ù§²Ó>“^@°AŸéýI5LòfúBàE‘ýB59jBl`,Ù6ÚQ©“£¾Õ¼ôš± b=™’Ñ$Î÷WAÒÂÓ×Ç‘Yçmʌ͵úõáØ•ÆV Y0¯GM>T d«_—NšH½@f¾qå¡íNc­­Øëäuçäußb˜qFQxÞ{ë¡oÍs{ÐH$ ÍDÞL›„h%¾zÖëSK¶Tc7½‚+Š k$_[<á˜IbÇl—{FËÀ£Àîj´ø„9Œu?¿:h(À ƒu_jõøÄ¿ÝX~~ýÆ€œbÑq£O†ò$sM^Õ#ÚÞöÛGhâ…´Ï]Yj“/Ö ‡vl´€3/#nïwÇ®ê‡ö¬íù^È‚÷Øîõþ„2;ùØë T;%þ>”å~—¿,éîÐi €uqp«c1˜AÆP ›)Ì÷R ¨«ß¦g€¡À>«ÛǪ@| ræF˜+¤,p.;…ó¼)ôæOoî fäñј<¡DT5´,ƒšû·ï>àd›|7=R˜û5òâgA‰|·ÜJîÍêt®ËSÙ úm39BL'b6= ÉG°N¹@ú°èY®[è£À“ä…w?}¼_[ž LB!§zAD¥!êÌg&=çÝPÀ>]=E>$™ˆb²j:wi’ TÆ·&­Ð™.îË¢ÚãA¥´CC‘—’A\Z‰Ö»²ž,Û«³f0p2÷S\4‹¤p=Ã6J\.˜=K‰;D³bÐѪYC³ ‘fí?my§™ ³Á“ƒ0έ˼p>Ÿd‘ÉŸ‰—ÒF\ÔM@O "û/=cÜwQe„‰MžªºF û„/qHüIl¯î1·Jzµm–Û=Ó)q¡·•®à\|+5WW… Q¤ÄùÂ5sÄ¿Á%‰ÉÔÛã Á„I›CòÆñ!ÓªËåæ' õ¡G8Çr®;/e{+Om7íK¤^F9dWûiû<·ä»¶Sáåi_€•Ø¢p"áƒæ“ ±…~[zÉa6rWžKk)È»0ƒ“ ”J0±o%ù©ï¦kê­T¢+Í\—ÆfQ7‹Zxcn™Q‹:ï{t‰OžíÊ}yÕTÓH\bÈüÔ°¡Ê•9ç‚ÅYŸàev2RÝy]ýŽR1äªe÷¼ôã®êËÂH0÷õÕVd)”§C×ZŸ9Cþ®4‘8fÀv芃ª^òÄJ ‘Ê4H5ÎÁVª;I@7|ãÄë>ÉÄí>M8‚÷F]³xZMõ»)ŽTÍc]FF hR£4Ñé¼uázøƒ§È-œU2¹<æpl-!1S³¼ã´ýtçƒöÉøq•Mæ-¨‰¼Ã•E‘α½5Öÿ¥jLß.¤â<דƒ¢†ét2&ß™ÔÉš ŽSUeÙ²ç”?£7%ïGbÔ°Êu%AŸŽU­(ù /lѲ7àcS­”]û²rd&Y†Ÿ «K./i òÖ¿‚c–׿'ròÄW:·EUWÃ3JŒ,\Šá¬‚HTά˜ËÇ¡='ú•/_­à<‹yQÿo –ƒÚŒûõÖ¤{I+øPõgM:1·ÖpÌC»$W»³\qîÊòtÆcÕ× gÍu§‚ÕÒÏU8}q,÷c$¬N^«ve¾×)^Y‰ž4"3µŸà‚ônÇÚàŸõi,JY¿Ž51OŠpî¾4²0öFg$·©Ž xGj8.—Àké¥óv”=PhJ‡˜‰ Y:ä™#ùškìջͱǺÝét ´MD%}µ7ÕPFc”MªB·= ÈŠVq'b¥œ_]ñeç±M¬92"K´Vu±ÆØ…s¡”5aÆ FÙiÂ4û„Pò£í?żM3¦S-¸E×ÖIšZ±Î²?ˆ%,¹ôTÇÎAŒZœá#Ö¬É%ò”ã/§?qsF A!cÝŒRUúo¶BÁ{z?2`Š³ÂÛ¾Ç4 ^÷ãtJœúѬ8W¡ÇÆJ?|¼¿5Ÿ&V/·§“–°1dÒ,2 Q,†G™•¶÷粨®tVÇ͸½ÄT+îþ^›¾óv¬jsbà€:Õ//ÌŒÒMX\Cõ‹J—U°ß¬á ¶©å¨yÁ’ÇcK•;Zi—Œ»FÂÜ«Õœ˜óy·Go²C"^=š!öåWµ‡•eˆ±ƒ1Éø Œ3l Ñç™?'TÕBR—ºy®ú³V®Ê"ÔÊÍO»êqlGHÔÙB¤ñ­Ÿ¹íÿfèò}U m÷üý4ªpŽŒÚ“!FìªÍÑc§ìe¥KOGDµ‚¹ÑU£ŸŽˆ : kþÝ/5ؾ2ó'$® ÓÁr ë5¶®S÷¦ÈPçÖ5ìzD*Vúü&ËjäMifý´N]ˆKS•Ù2sJ&A-Áì'…6Õùìl ³È™ ^i #Ô] {C€ 'f"@'~óõ¨²kxÿ7ÊàÛ ¥QK€2[ suÅ ¼xgÌ /7¨×íb!˨:ú 妧åP/Ñ£jQ0¬Þ€ìgš(JÔq|°âŸÀºr8n‘3uˆÉC§ÉOxØ ¸éÄ ØKGŒ¹2Š)í$õï/õîÕ£¼…üBJóPÀ²kCÔtŒiù¤ê—ã«W²r ƒSiD;:]g•Ÿ?Þþc‹,*ÕE ÷rIrWu9™}zYòLŠ-ͶÞ3C°"ùQ—z.ɬÙ÷||î«‚÷ CÁå‘Ç´ÇËœÚã/u›tÿ†Ýæ˜túˆ]›kÏú~®ÉÑ좾6cîªk>ì#~¤šðÖƒàEvÙ·¥‘E8õÌ#é ïW¨}qñÂf^c—˜Rz/9¦ÌÁk,ùGfÈØ“ô}kHž"tÛ¸§ó¨¯çè(Uy~qæÏnY­éÊtź™ö6cøµ[kN§7ìZŽµ=rm 1ïSúâHÄoÚŠÊÜqO ù8ã/u»K±¦ŽÖ.u³‹Œ9'È̦¼ƒ°ámuó3ø˜6ñsÓZúàoÕÈðXçDÒvöž…(›Ñè+%ö}¢ PÖ‘H@]¶•–pe>ÐÅivþ¹WWø *Š™ÁG¨¶™õ¹HîišÙÙØ©r¶7š> \$øJ-¾Ûäw¶k^– ½ì¬ŸÝ¾ÿ5J&{s’›d@Ïùʬ81¸|[5¹¾ ¨:ý©í”𠜂¿£QNŸ²‰„ ¿öCW ÇSiN(”¨ è‡>ªp½1Ë„f‘°M¹Á¶²ìV’HBÅ’FŸ_ È3Y‹TæZT¸L ËO1‚61ù[¨&ÝBÌKÕ_á'hž7õçÛá/}endstream endobj 81 0 obj 4225 endobj 84 0 obj <> stream xœ•[ûoÜÆ.ØIÔ é;mӦקÀGsä’ùM’eûKr¥3Z£*ꎒèÜ‘g’g[ùë;Ë}Íò¨“ –½$wç=ß̬ގ€ŒBùGÿœ-wÞnÍü˜-G{ÓÇ'4• S2š^ì¨È(æA2ŠÓ8HèhºÜy¸Ì®¿¾Ù¡4à¡`ðÊt¾óð<—k„I ¯©µYU6me>—#x˜èGmÕ½NƒÐ½ónÜ­mÓ­¦KcsØû«bÑGE ’ˆëåuy^}è–%­vYûf÷}מ½’-Öyw‚ÔíY”›„.³Ù0%ð0ˆCëu·–4Jˆáô²hÚ¼îvf°Kb_ãU&×Ò enM+Óв¤Î‰©#>/Ú¢*³EG–ˆSýìû«b>ÏËš`.¨@â äò˜Ç4HS:ƒ 9ïN¯òFI9 ·™HHûº/ò:/gJ€, BfXf?t¯'AÛ×»mEKâÖmÛB1%÷¥V*mÞ´EyÙ=ßX¹Î®²Å"//á¡bДw¬E±a­c, B'ûãó7ùL™‹šàW ÃîA„UÞ‚y®Yj¹.Jø cˆ²€n¾È´Œ@ë`6æäö*k7­Æ+9±këF}M¥ÂKí•^E$´W†d£‡y›U¬:Ã$AêLíe]µÕ¬2úJyg_ž}«­ 4ñUrZ€ýhŸŽckmŽ Ãì¤ß¤Ž¬BŠ0"1^QVJ®"`îëUV·Zû,²¬VÚÑ#÷¹;hŽÿ-W‹¼cŒIe‘[r‰ C"ÏV _pÚŵÒ4x S¬é²Òñ8&8U\TõR;t$s€%þ½ ñ£B'lº-lJ¡n­:—þ©cDH¬<³ró{ðcЬ²Aß™­Dð"k:îŸD!Κ”ã”tx0}~üd¼|¸79ÚN”¼¢€…†”ã#µK/÷² tªz¤4*¸ —V£Év ¬êj¾ÖL%Aâr•AˆÏ¹VɇÒԒ׬Ï-«¾C+©ôÙCv‘+üÙÁÑÁÉdüôÕÑþtrÜ)…ÄFJƒ" Ó0Ù´VcfùªÕîÆœQ^(Ñô #`‡ÜÆ€ÓéîÑ“Ý“'㎶Ž"—x€ZcnŸ¾Ò^ˆDv´¿¹¦Õì­ÝEÍzÄQ<"Ú ”AôŠe¬¤©ÄOòEæpa$ôªÄ¹Ò¹ ‰Õ> ±üíÚ¦è>ã$…p 8„˜Y›ÜÐP“çK}2!.K €¹!<¸Ô6çAmséºhƒÅRɺõÚ¦©fEÖêì—Ì%”¿PVÛ¯–˪;”s™†ÍN/Šfõ@¿NãÈ»Š4)¢¥½^å›y±¹†Ø» ´S{,¤\ÍG;=Ûí"­FˆEQAl½,´aÐ^Vš¾~y0>~:¨\ƒ÷°ÝźœI¸Ø±À77wg³ªžëHÌ%È$=ÔN$À¥>u@MèÜËÏ‘RÆn+Ícp‡€ =›øñ*kt §nÿÁC!Ô­òº½Ö{DÄA#¯Æ4f€×¥™Sœ¶eKæ †Ã%U„b.’Þê !¼ØqmµGýƒ xºÃóE¾„”Ú1À‰[s³™ QŠ@‚7çŠMTð¬‹E;VÉhM€–&ÿÝf\ýo Ø…”IÌš2Ÿ€£„1°ô?õ!T+έ¬c¤Uçk×y»®u ɤøÈ6âC¢ÊÔY¥Ê:ŸU—eñcv®`ŠÈ¾çù'Fîj˜3fPA­âý8íêÔŽi>R(C¬û”²ˆ 9p'ÙØÃ1• Ì2ê8ƒVí@h‘”™æ@LûÍ/>-.×*u2) +4>¦Já4L¥à¼価8MÁ7šhTç ¡QC´¦„;‡ôJE\·öÓŠò^Nž<～ ¢´/T£m¤ gÕ!Îʪ,M8£Nò—Y[t/Cäv@ÄuJH¯S"Ã{lµÖZ;³ºÌkÕ ª’»ƒ\$ Dè 5ÓÚRýH±\¾C½døk ¡PÍdBÇF:÷BÉ–t)9BÝ/dZ°âU»±‹dÜDµ4|óUÑvˆ@ÙræütòŸ£W‡ƒôvuïÝƹ3÷ÀÄî²—Fö>’ß’˜)JÌw²#¾)+íH¡ÃvÄ鎺6\cû^I]æ…,¶u,@YÙƪc¯Jçêú@n‚ìÇ,ѯٕmØZP1aò¶§Ã…¢ú‘QC'ÂXöcfaW³ŒúœËª¶jtîÒäuQ­ªPG¶É[£^Úû^œðð`ÙèZÔÊSÒ‘ˆ<õ %µjñN«Œù`„…wˆë—¼zùìd÷ Èj÷äd÷uWuúÅñÁ ½12ðƒÃµ£ÍµéxjP§£êõˇ´Q’‚µôø„Ñ‘?¢_á„‹ƒrÊ.•´Þ† \üæT—”áj—¶A-Ä‹ºZj{—Q:Å%Í ö>VºWϾÕa±^ùå;G³ÊgÅ'ºæ”Hd³ãŠâg¥¹¸6ù¡jÔñ ]jßëð%„ëZm†¯ìCQ-}“ÛBâbajº aïŽ:•˜‰ÐXþƒ<“è2`ÝŒçÞ§÷‡ÔhFBLÈnɈ‡xé>¨qóæ)°‡7ÿü³m›ó‚IŒ7ÿîÆ­iÃÖ€ýàïnë³òþ?ýÙYýó/ù‹_Ýûͯ{ï«û¿ÿݶãºñ–ä?å·rBAÐ1¼L¼ãþ }ñõçüÓYýÍ—ßüâÏ÷FúØO}J>ÿì/w „‚˜%»¦¼qaÆBä!êR]¬Hë¢úÆ,ÑÇ潬!}%[?ꉟôóumò" Eºë…"\ìz™Ç•½ò& TÈ\ܬ=8·/ æ „ þ÷õ_±â:^¢Ø{•›W·ªTšJ±dj´âóÚQ xŠy/¿õî|ɉ·º¬q;‘e¦p!®¡ÖÛ-wg·”rU¹¸Ðå€ð€Ø…½ë<ªÎW5ÔðˆÜ˜ã+“CÍ{¥ˆf°­ ùFÆ,@ªq¨çÓ‘|ï`:ú—¼½Ê‹1£®¦ë.gËë”`‘ òçl¹³7Ùy<9µõ:ßyüïÙyü\þµ÷r~LžŒ~²s0Q[ ^gé’¿Q‚«@¾‡&R¥£îô‚AÈ‹cÖ½ÌÖÉ6oÂÒ4U†¥=pa3Òeiúø@?e}äl0êŠÙfkà%Rûf¦€‘¼E½8Ów!f Î-$^åÙ ðGŠhN=¢¡fvõ«½–üÁ‹ƒÃƒ£éXÎä†8¾ ¦L=—]’„ÛËkv¦#ž¡ @fvŵ¢™ËÏjÑXØ‹møŽ „Aw £Ò 1Âztˆ4±20×a™ .îêårµnååˆGke²µÇ{7” *›LutÄ9®»3 ›Y±c«Õ™7uÞd@¢OnV»*GÞ]aÂWê4à§Â1]iR6ú£Øìuº;œ>œé 9&)¾èeÑ3ÿ1‰" 0/Q猷[þÞÚLŸˆuX˜P²a~_ ÍdDh/H<ÐMCfÕfï°F¡å·ÔãnQ‹ß)÷cÄ…ú\Û î´WS…AY¥e³YÞ4¹ºÆ%/ª…ö"{Ñ>Ðá1bö·:m”¸ m±jÍÕy¹€º{~¥€„k¢å¸É.Ìeˆ$"®W37W8ÒÞUà„ˆÄá1+.¯Ún*D‘¥ ÝœZh¦ ôx7¿¸ÁbÑG¬P°pF> stream xœ¥[ÛrÜÆ­Ò£Þò|³]E‚×¼Q²ìȱYd•¬TeˆÝE„V¸ˆa>$_’LÏLÏtÏ.HÇIéAU ˆééËéÓ~¾ˆ£ä"ÖÿðÿæðòóËωyæþk¯î^^Hó‹$‹DV¤wÛ—ö’‹"‹ª‹¢.¢ ^~]|s÷÷—ieE™Á w›—_ÛŽæa‰ª®ñ¡jævè'ýƒ,ê´(ðßéGU$ê$MðÑ`~?)£8M+÷Ú2/æ±È£¬.r÷YófÅeîŽÿÅ<‘ˆká?øI?„;Up˨ŽëDßé*)SøÍúâ*…[eæÕ»½ýd¥U™âïÏjšQ¤¬,ÜW§¥ÍËiÕ•?šÛ®3oWQQøÇ{i.Ÿ€æªÒ}BêG¥5vÝ*«DT‰{ö€·LªÚéHŽÊ~D/éðy/gw6I /›‡yTÐÙý0£@)=œ–­y7JýÃM«ú¹{4êÉàGL1j™$‘(„³ê­š·¨ÇŠä0Rd °>úÇQö5ZÇH@hÿí^©Ón]¸ {}íÚXËÑö»K#H%‰ÿ j´®œ97ºHZWNŸÝ°kiìv•åIT–Õż’Y·8Êyß˃²rÖÞ8 ?j/rVÖ”áñ¡)ËÔ›òÆj"$÷<€?ÀÉÖ@Y•¤%Ç®U ‚3ánaŒ“G3~;[_‡/'NŽvê¿Bg­oöÙ¦¬´maòÂê´ƒÍa"*c¯›Œý4ñnrUÓN ¸;òØ‹Ýš[‚·&UR<ç®döÚ¢ˆrÒÒ°E?+¯¥y¯&ç¬u|n·KDÃ*÷ß¿·JJ2o—eÆ ¸Õ¸—Ç ¥Èb/…6℈ÌNldðáå>r¯0Ò+’øalçY™—…>L¸R“>›½j ²¦`µ?®ÝZ]¦L—óÞAPM"¨qVŒ·f‹y¬ €ÁÿÌ:ëZE„Y;…1ž”>Æ?B8_¦¨œ†ƒÂàüú=@˜ç>D—Imƒ)€ƒÈ\~šT?©èã7FöÔT@ža²cºs¥±?fHæ¸lí?fñÃÆxoU†8<"ZB6pZ»´ù%ÏÀB@4àç‘áp씎iµ1¿Iž¥švBpßy”-B@D,…Š+èõêÕ(m¶”Iòí0&Ô¸@~âo@"XÆÕAZÈŠéõw<¯2Ãá ×3Þ¬)xx¢*âÌëþѺ^1ïS‚i¥Ìk´ÎÚˆ˜¹ö3Äw{«2ðj‘{á»öÐbp‚$Y~"FðùÅ„[F‡íù%5ÎN'"¤£Öø€™ÔEÙ)7%Ǭà¼ã%˜Y~:ײîÙÚÅü{80ƒZ˜”c#ñó†Tèr[LÂïB€û'¤rkuHi$’šûÈÖúx¡”j‘$$_»EGÆa–ÍÈw¿³`]W”EL‰kiDꈻ´¤49)%O¾ooþp·Æ]5 fr]BHˆ‡ ½E«P/ƒÀØ)+N2ºö¾›žûTpáþH¢C†+Koè_ß¼º5‚¦<5G ¤Åɳ«‚ý3/ÒÁÎ ˜§„„ú)Ýx¥ `'î­s€¾2€h “¿ 1*('Zè ‘t³ŒŽÂéŒío}—~!¹«‰BSÁÁ˜"7K¬²› \,ŒÇàúŠßôÅj.e~¨ÆÇsšj€ 9Ž€ø ;P ÊŸR0Øè¯z›±mh GecéJhW ÈÜ;GîZ¹Ÿ†#ØrzŽRå5?ŒeK(e()°œ)gÉbé6HOªœ¤Òœ˜×—3.6´T@3Gs,O{% Тáú“K‚rê_z—÷c*3!ŠÇA6ûóüþ`­ æy²¿E¥”!ïÕ¹ObB¢Ý*Íb$VvAª¾B¦•êáöñ9<͸êæQ)—ðrz¼­YàeAþ°oí !á³—l§#^'§—y0Ýr âk—n–yMVðÂí®xd¾ÀëÈ'Y$2Omäh \!YØBk i1.‚*;ÍÐá¡Ï{{QõòÞ PË ]J¢ã„£2Ì8>ånA0{­f « {ç%a_›ç܆:aw]»ó̪kAŸ0ã2Šz´coCXvEâ"x™Oª¡TLªaÒ¬ÝfíÖ¼´a¦Tx:x:£NZŸ0³ÄÓomßóØ"IJ!6ºvÓΘL˜•¬¿@®ç'¬æœD9f5hqŽÚŒ§4ûaòµ_L€,{ÞöÇevÜÕ<÷¨â"gÓú`M1yž¥æ±µmä(탆zÝâ¡÷+¬Ûo‚'µ Ž£:v²AûA¦ÆËÚM¦£jPÂA¬¦×Éõgl&õ—¤øf$Ö~µÔ§%ù™cû˜—ÈUŠâ´MŽ6!å‘Ç ò¸¶ë\,_t¯î¬açè^í%š$¡žÌ—Ô9–BTþ­~¤‘–Œª1À’4p•š\ÅG^ú<]>v-B»ûÉåÑ’©ä_Ó‚'îñNk7®ôŸº×õpXù„I°æ°+ú7Žd>äÞµSƒÀ³ïëîÕÇo"L\ú˜ÞÞ …}¥ç€?Ὢµv—vËѶŽŒËÀÎ3YÛMn\Áš5,é1ôŸÞ¬+r·Oý@9ÀûJ§6;[ íZÞW<Î7z¢Ù§±å3¨ÞÕ9rÍ-Ô:±…•Ž{*i½’@=:€Ñ*]s£1樮IXÔURž8X0’`ÌQ‚®+!(8+cÝ-sE¨|Õç áó`«ÙLæ(G(?l4jW¦ŽíŠJ×DÊ©‹Ù×bÖW"bŽ¡ë#4›oí9ʧŠuîGkA¡KZ=6*ér=Qd—OžìOG·¦šÊ7dbV^ì]í\@¡/‚¶Û§¶wŒô ùøÛn”Ž:Tñ28+óÀó]5}§šb8`¸*jñßAÅ:GÌÅ“P(tŠ¬hØ(x‚ʪVKYóÍùxN¹¸så:ë;­ñ‰î”¼I§n´|L ^¥'rç ¡b]†fߺdÁ¨ïÚ\„ñ#äL—qõÎ>ãVšûé©ÏT‚Ëä•Qt¢Ì¬UÛ‹£¤QXÙŠLw0æÌ*uÀ^qÖŸÑÔ'-ÿŸÍ7à·Y ~E›M£æiê{°¬éðL/§ä‚î†Á–¾!ïžÚ¾ñ¥O+vâ)ƒ™J&RP|C\›M·:ƒ”4áý£i^!ÇMûOëdeÆ™ˆ蘱8·åÔ΋d¶JÏöÑ9½Ëœ”ü 5G|ë°æ 3íZÝí'Æ¥Ðá‡%¼ØuÐõnu6.ÖY(˜ Ë™RàNóë(ÓŠÐc+q:P ¢ßí—W ÷³Ÿè€²ñ–çƒ9g•P“±6BM]gHbÁ0]3N>Œ9;ÝÍ£ÞXÍ•÷VCm%‰ñ?„]¾Þ5Š‹µ¦*ó0ˆGgVê{qd9áÛ[¥6÷HÆ3M»ùp Y[ è—ÍÎiM·lÏ,°Ÿ øf^wÚÝ ;8+ë#a{" ÏbÌLù jæk£ê¤k ê5:[kò·r—k53lYz»v`ŽÔ4“v€r¹ýÖâ[C‹UÔâ³RíœäDvÂiÊS?|’: ‚صD¶L®ºgUŒ0 «z¾ŸÜ-:¤EîLWÑD"»ÝµãÞØ>Ëù®Âà¦Øño(”(šŠMæP=v.–Šßˆ¥~u çCTš +f6¼4ž­‚L1Ýy…ü1'Ïy{À´ Bœ®£]%±ö‹ôâ P±¨ÌÛ%†&[E»i°ÐÒÎåY¿©³ÌP?n…‹Ç™ÈùV¶4Ò”j‚ÿºð|z‚vÒør<2°ªì?3´×òp@“°ÖÍ;¹[ÚÑÖ!­._ì•Ü`ZO’sn^œûVðëß¿þÃ3£kYx´´ûY,ŽZÿFÒ ;+y¸<‡nRVyË®óE4›/¸ÍøÜ®PÅÏ_áæ§[cmÝÓ"Ý:²jšnP†|ƒ$&³·'«-}eÁ¶Rž¨7‘$°VÒzñå‰i¼þ®š9BðK©£‰ŽœóT°:Êx¾Xbg=çÞüNkê ÷#Ëä¦ùÁDmýþ+9“UñZ,0ÓÃ~À˜ežaÛ¿íÇç×Õ¼Œ½Ïhœ M¸´~?á 8y·l\©…ôgë€wËl8ÿz?¶Ó<­ò˜/¡|Øe°(y2¿•‡ó ßÎ :?'«…ÿÒ+àyVG5Oz’í=î0˜zÊðí"{׬e«©Ô<·¸¢°‹òñ0ô®KÈÆ=wVã|cp87‚ÍAûâòü­omŽ'/èÖ¯äh!Ä›'=wÞnE£•z‹7ÜX¤kú²å±·3ɸù¿Í'àü$®ªâÔì{96(jIu±ùíØ°–ÚyÔäÕ‡ö8tÝ%ꎙÿÕØ¢dßžx'nõ÷ã0˜¸Óŵ†\w“­Ú»–b¦¬—evO¤êj‰RsF]À +l‘™ p4! ŠÒõ”¬‡pú=–’MþŠ’±”ðƒ[ÑÕk‘”/_áÔ*U–ê𺦴öÞºßé‘óØZvný!ô”æ·Í~Ôwô‚ÜCˆq¡µÃÚñ¡Ü¢ÜIù !úGóø u(nw¥eÞ{D@=':ŽH™-üÃV½ß+¸‚žXÅuýùD‚þ|o— n<½eFTïýˆ´“õ>†&Â<ÌÆSijÍ£·(ßôýb+C`8l«èý9TȦ}Ñ ÕXGñ§aœ÷¨ ¦1M%n‡íü c²YË1‚L÷3ˆÃY03C³×CÎê涗PaÇåÔ·Ã&Ã%žÄ³Ó¨®j,Šä[…!ò”ƒÒ~ž¼¾~x0@¦×³ Ì£c?}n"˧tb‹n×ÀûÙ5lZñëÕ÷» }#¦Ì{}\yqú|þb“¢°U8Æg=Ë¢£k—06¶ÅÙ$3mÐÍòÔ¢Bº‚ ïm†ÐwJµ Õ±èq÷]ó=Þ=ã3²×²6ïø3$¸±^͹ñ´‘¨²üÅòA5ž Áç¿K¾W##L«¬ió§v·Çèa=‰ÕZóà²2ßÝ¡¹' 3¹ÌÃý¡› ÝÌHaY݈‡¥6‹‰»®D›ŒÒö ’˜w°’5&÷W÷;”l²³#}8w½Fâ¬ÕÝæzÿ¥ãm 1¬Øb³Åœµu°ï¤Û™d‰Á‡a¸’÷g+DqÊ CBòØóJ#Xn6£šl z¥f簧ѩ âù~ Auã.ˆm4Ó`0ˆ™W|dqÊ¡R®ý›X–ëg°3 8¢Ï³+Gßù¼æšÿNÂÙâ H÷8µØ«…#‹ÓV©¸$6?(ôÖEøÒºÑ$Ÿ©¢¶Š¢¦?¸½C™yÝ÷ÀMÞ[úø럳tó—±Ó-‹KLÓlŸý»-6%­ c!lkŒep‹Þ,÷=E°–þí2Zr¦—ƒØôÆ÷—™óÞ¶e Àκ8?Ír;Ln+•í ß z§Õq°ei8[ñݨõÌà<>¸ÓRWn;„°ûöõí ¢Š’ÁWUbHQø§>ë<J°WVò¨âS4¸;¨äv>)N'ÝíYÀÕ'2±õ•Ð˜Ö… ý;·d ZŠÏó“°ŠPý®í•rÛȧ¬#OhÕá’X¨Ç¹ÃÎ’ó褬ÿ•T­Â3úöÍg¶™ü^£Û%‚&[/I²qØÌŒ+&V‹¿f+Qr3¶vö©·,Hž•|Ùî0iéê“Ž¼;•ºÝáŸ"P³‰BÿT£ë°Ç•yÒW¢‚ùý3Is¥=* ùoL–ŽšápÍúô¹Ðe˜;üúÒGÌR"ä­ÜHôæîâç—úßfmsendstream endobj 126 0 obj 4682 endobj 129 0 obj <> stream xœXËnÛ8Ýç+¼šI„æKÕÛ¦mÚ¤Hc£LÓ…"Ó±¦²äJò¤™É÷Îå›NÜY $I]ÞǹçæÇ#2ÁúÇý­6G?Ž~LˆYóªÍäÕâhzM%¬ d²XÙÈ$LjND!¤“ÅæèøköíÅâ¯#"Å9ƒ#‹åÑñëu_c]¶z‹g¨Dº­‹º]ÖwÈlÄnãºl—ÝƬ3„ ÏÜú¨ÀR{§7X†° Œken.7}ÙM9Ö¹;#¨ð绕9ž!JÀwç¨Ybˆé(íÒj×VþsN+hîvª²iã9ËÍ‚‡³ÑXÉÁë`x=ŽÛ—Óéýý½±#QW¸=4Œ¨Ю­Oõæ)ŸrL'§àçæÈp«w „!sá³¥šºTDø€“ÏéÐWÓ;H•þ­OÉ ²7n]ôœ îV—«Ÿ’˜Á·êÖ-ʸh¢ÎP† ìÓI1ÎÌò)‘@"&§”¢L˜Í¯â*þ°11ríÌ2Í^"w;„î“yY}Ô‹`žˆ`M©MÙÚjpTä¡oj[gŽ(‡WªW-²1ç!¯4¤&ÅA9 øZu½OϽ+C·MI)CÏü¥e¯Œ+ÓëŒíuMŠ"ÔêM}WΆW-lHÌŒªl²x[gÝÖ•ýšHÆù` †²øu·ë[{òiSÄð剽7çö 'øæ˜Ü¼xI0~$87' ç!ñ>¤(¤-<€$£{…ÏþUÙ¶¡M¿²Žkßž BŠèÑeÝ4Ê”‚ ”å\¤Î Di½Á‹nW椄gço{µìëïƒjmÀ ŸS ßS4Døª°Ô¥óÍÌ;ä'0œ™ƒD ›_m¶uïkÅ9â4iÄÝòÁÅ’˜vÜDSnòüAG×zÕÔåmÝÔãƒãVžÅS+ŒIŸP`™Ÿ®y2:7jµ¢ö”SmƒFr…}Ým6;Ûo‘Ä»3[†¤«__BÞ~ŠòhRgÆy Çè#綺åy€‡ãd‘LàqñèÉÐ{רyéسÀæí0ëÓrù úÃ)Ža‘caôàH ³~tõqÑ•„À¼±Ï5‡”½£'š1š#‘$å3ºzÖÛYÚÛÈÖE&íñ¡[·Ž»X&žÐ2ôWÔ ëHü1ƒ7¹W±ß\l‰wó®N|¯Ê€oRä…-³íã8[ºâ@é>"‡f‘Lä¸åaíªÃ$@T!²aŽg13õ`†!%zúëÞ?lU?ߪÊRðs&öNóÌÝ»qnéú諸ʹWfúBÏ%4A8¢¦péódY²ƒ“Éð׎™éO9"2a¶®]I Óºu¥á2@qé‹Š#¢µS@I¥Ç£w J¢çzd™3‘ÌšµÎ¨ï&5†8°ÔÒOšqã–1ù¡Mdômöi~>=ÿôú|17PªÂ¥«ve# ±«)§ÀÜUžz³xFTN+Z7Áõ" ¦À¤oÁ®p%HDTœ ‰LØm—Þ®ÖŠqÒ»„»QIqM3ÄT§¿üÍ8Q×€àD¤]û†)¢íy³ÿ±½¡  wYCmL@úhÐ1GZöÈs¤ 8±®Z—ÀC•×÷y8žÊ)šÊõ0œa7ÿ|ܸ&‘ÎÛƒRjïË«Þ!1VWyí˜ÌrÊǵ›¬H®H$­óí”XK­ð,èÚ•“z@Ćm+åŠA¢·µ˜Ëèß— ˜I¬ýƒ›26åEéE&`ØŸ¼ûELG‚4J;òM9–·å ¼Ôˆ­0FµžcðæøËÅ›W¿òæÅ¡1ô–¼×NžKômy§¬ÊÊé"¥æxÂA3xOf;ûàÓÜku$è ¸}_Grö×5àÎs ú<¡z}¡ïæO²=éæ;0.Ý0ßm·]ïq›á”û½ ƒ>‘¡B½rÓ0‘çw½‚žr:W"ãßb$oÞ@{<"§qÓ ç!òmßÝõåæ°8‡tÁƒóówW³O®5eìÀdî%e¸ŠŠ;èÈZ·‡g÷p.À±Q¿'ºÎãâüËͱ–u<´ †ñM2š‚8c'®5hÌ1àƒ8ÍPØŽÞ£Ez³vÙ«rpÈb¢ÿTá !Ó§»'oà·øÀ¹.›•ËSR÷u³T·02–£U~uO½Ù6õêÁCˆÇaŽÁÕC§ÿKá@’(ÖÏÜÍöq[7»^ÂSW¹o„LçgÝnwãAlè—P¬àùÙÙ™««Œ¡-ž“•ÉG8©# ËÒügdpeÔѤe D(þŸØ=kïêV©þú4߇YúL¤ÒÂŒHö5y¸>ýÏÆžj‡£Ô$îl1ù|¤þYÏ…±endstream endobj 130 0 obj 1833 endobj 5 0 obj <> /Contents 6 0 R >> endobj 45 0 obj <> /Contents 46 0 R >> endobj 55 0 obj <> /Contents 56 0 R >> endobj 59 0 obj <> /Contents 60 0 R >> endobj 66 0 obj <> /Contents 67 0 R >> endobj 72 0 obj <> /Contents 73 0 R >> endobj 79 0 obj <> /Contents 80 0 R >> endobj 83 0 obj <> /Contents 84 0 R >> endobj 124 0 obj <> /Contents 125 0 R >> endobj 128 0 obj <> /Contents 129 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 5 0 R 45 0 R 55 0 R 59 0 R 66 0 R 72 0 R 79 0 R 83 0 R 124 0 R 128 0 R ] /Count 10 >> endobj 1 0 obj <> endobj 4 0 obj <> endobj 16 0 obj <>stream 0 0 0 0 32 35 d1 32 0 0 35 0 0 cm BI /IM true /W 32 /H 35 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡ƒôÿÿÿ>stream 0 0 0 0 42 41 d1 42 0 0 41 0 0 cm BI /IM true /W 42 /H 41 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡‚< ð@ðƒý=< ôÿôÿôÿÿÿÿþ×þ×þÖ[[_† P EI endstream endobj 33 0 obj <>stream 0 0 0 0 25 26 d1 25 0 0 26 0 0 cm BI /IM true /W 25 /H 26 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡Ìßõùß´ôðð¸<ýaˆ…ƒÿ‚øFy„`ßü,=­¬qþÿ¨€ EI endstream endobj 43 0 obj <> endobj 44 0 obj <> endobj 54 0 obj <> endobj 58 0 obj <> endobj 65 0 obj <> endobj 69 0 obj <>stream 0 0 0 -48 60 2 d1 60 0 0 50 0 -48 cm BI /IM true /W 60 /H 50 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¢ Ã0¿Á0ƒì#óõ‡½ÿ ÿ÷¾oïþø{ÿïpû¿ýßþáÈ9¯þ¾÷ÿ¿Þÿ¿óÃ~ø|š®ýßÿ‡ÿoîÿ¿xÏzÛÛûH6—†»b¶a`Á  EI endstream endobj 70 0 obj <>stream 0 0 0 -48 41 2 d1 41 0 0 50 0 -48 cm BI /IM true /W 41 /H 50 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¡IGÁÁ G€‡Ó§Õ¾oƒþýÿÛ¿ÿÚðÁ.> Q®A‚øKô´Ap\è f€ß^CÒÿûßÿ·†Þïë  †b°kh € EI endstream endobj 71 0 obj <> endobj 78 0 obj <> endobj 82 0 obj <> endobj 86 0 obj <>stream 0 0 0 0 75 73 d1 75 0 0 73 0 0 cm BI /IM true /W 75 /H 73 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¬•Fÿòkµ¿þ¿ýÿ¿ýÿ¿ýÿ‡ÿ¿÷ÿ‡ïÿïÿïÿy°ËÊ»‡ü95_á»ÿïÿáü7wÿÿ¶ÿ÷ì=ûaéä0]Àx߀€ EI endstream endobj 87 0 obj <>stream 0 0 0 37 28 90 d1 28 0 0 53 0 37 cm BI /IM true /W 28 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID &«ü„¦Âÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ™Øù5!{÷ÃÀ@ EI endstream endobj 88 0 obj <> stream 76 0 0 0 0 0 d1 endstream endobj 89 0 obj <>stream 0 0 0 37 35 90 d1 35 0 0 53 0 37 cm BI /IM true /W 35 /H 53 /BPC 1 /D[1 0] /F/CCF /DP<> ID òk½÷Ù°ÑØo߆áÛ}†{xaï°öûÛÃ{ðöûÛýûÃðüýü[ÿ^°¡I®¾Â÷[k½m¥°aãÁ…†N  EI endstream endobj 90 0 obj <> stream 66 0 0 0 0 0 d1 endstream endobj 91 0 obj <> stream 70 0 0 0 0 0 d1 endstream endobj 92 0 obj <>stream 0 0 0 3 66 90 d1 66 0 0 87 0 3 cm BI /IM true /W 66 /H 87 /BPC 1 /D[1 0] /F/CCF /DP<> ID &­iÿkÿÿÿòEn[ @]a-Ã_‚4jZè, ºëK_Òá~—ÿ_×ÿýüšþÿöÿ‡·ûí÷Þ{ì=¾C ¨0{*jnA¹oÊ(€€ EI endstream endobj 93 0 obj <> stream 80 0 0 0 0 0 d1 endstream endobj 94 0 obj <>stream 0 0 0 -2 76 76 d1 76 0 0 78 0 -2 cm BI /IM true /W 76 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ¹@2ÈqŸ„œ@õƒÐD1M ß@øA7Ó[öã ÓíïÃï|?{ßßï÷òj¯ÿÿîýÿýáÃÿß÷þïÿßû¿ýÿîÿðÿ‡þïßÿÞ?ýßÿîþŸwØ# å \Ÿýÿ EI endstream endobj 95 0 obj <> stream 113 0 0 0 0 0 d1 endstream endobj 96 0 obj <>stream 0 0 0 -5 75 73 d1 75 0 0 78 0 -5 cm BI /IM true /W 75 /H 78 /BPC 1 /D[1 0] /F/CCF /DP<> ID *ÃBïòjG@j:‹!(Ú÷ûðõ·ÿ¿·ÿÃöÿðþÚÿß· ýýÿÍ‚Žß·ú÷ïýl?¿ü7ïÿ·÷ÿ°ý×ü7ýwíûÿíÿðý¿ü?¶¿ñí~ûÿáÿ}ÿ÷ëx€ EI endstream endobj 97 0 obj <> stream 83 0 0 0 0 0 d1 endstream endobj 98 0 obj <>stream 0 0 0 -2 80 73 d1 80 0 0 75 0 -2 cm BI /IM true /W 80 /H 75 /BPC 1 /D[1 0] /F/CCF /DP<> ID &`CáɨR@îA ŽÁý¿ðíöþû†ýÿîý÷‡ïÝÿ¸ü†‹¾ÿ÷ÿwü{ð÷ÿý¯û§ÇÿÞÉÃ÷ïûÝÿ÷áä1Ÿ÷ÿpÿý‡ÿûïÿÿûü.ÿß]¯!—¤þ  EI endstream endobj 99 0 obj <> stream 81 0 0 0 0 0 d1 endstream endobj 100 0 obj <> stream 85 0 0 0 0 0 d1 endstream endobj 101 0 obj <>stream 0 0 0 -9 25 100 d1 25 0 0 109 0 -9 cm BI /IM true /W 25 /H 109 /BPC 1 /D[1 0] /F/CCF /DP<> ID & ß_KK ¥¯ K_ÂZ_Ö¿ ¿ô¿ ý~½~¿ÿÖ¿ÿÿÿ ¿ÿÿÿÿÿÿÿÿÿÿöÿÿÿïßÿïýïýþöÿöïßíá¿ßo‡¾ÞooÜ@ EI endstream endobj 102 0 obj <> stream 88 0 0 0 0 0 d1 endstream endobj 103 0 obj <> stream 33 0 0 0 0 0 d1 endstream endobj 104 0 obj <> stream 69 0 0 0 0 0 d1 endstream endobj 105 0 obj <>stream 0 0 0 -9 25 100 d1 25 0 0 109 0 -9 cm BI /IM true /W 25 /H 109 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¨ÀlßííðöûÃí÷ûo÷ïðßþßðÿïïÿ÷ïÿÿÿðßÿÿÿÿÿÿÿÿ ÿÿÿZÿÿ_¯_¯ð¿Kÿ Zþ–‚þ´°½ip´´¿¨€ EI endstream endobj 106 0 obj <> stream 46 0 0 0 0 0 d1 endstream endobj 107 0 obj <> stream 107 0 0 0 0 0 d1 endstream endobj 108 0 obj <>stream 0 0 0 32 73 59 d1 73 0 0 27 0 32 cm BI /IM true /W 73 /H 27 /BPC 1 /D[1 0] /F/CCF /DP<> ID &ºÓþÖ?ÿÿÿù÷ÚÚ€€ EI endstream endobj 109 0 obj <>stream 0 0 0 15 97 76 d1 97 0 0 61 0 15 cm BI /IM true /W 97 /H 61 /BPC 1 /D[1 0] /F/CCF /DP<> ID & °x4·û÷øo½ÿa÷··ø}¼û>Ÿ·<$ûØ{ƒá‡²EƒƒÁpZ4 °]Ð]gØz_ÖÖ@û´°¿¥¥Ö‚ýzÂ_Ö¿Ô@ EI endstream endobj 110 0 obj <> stream 142 0 0 0 0 0 d1 endstream endobj 111 0 obj <> stream 82 0 0 0 0 0 d1 endstream endobj 112 0 obj <> stream 84 0 0 0 0 0 d1 endstream endobj 113 0 obj <> stream 89 0 0 0 0 0 d1 endstream endobj 114 0 obj <> stream 50 0 0 0 0 0 d1 endstream endobj 115 0 obj <> stream 117 0 0 0 0 0 d1 endstream endobj 119 0 obj <> stream 72 0 0 0 0 0 d1 endstream endobj 120 0 obj <> stream 74 0 0 0 0 0 d1 endstream endobj 121 0 obj <>stream 0 0 0 7 61 76 d1 61 0 0 69 0 7 cm BI /IM true /W 61 /H 69 /BPC 1 /D[1 0] /F/CCF /DP<> ID &¹€$Ziÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿµÿï\5ÿ°»i¶–KƒØa°a-ëC‚ü0°`²õ€€ EI endstream endobj 122 0 obj <> stream 93 0 0 0 0 0 d1 endstream endobj 123 0 obj <> endobj 127 0 obj <> endobj 131 0 obj <> endobj 12 0 obj <> endobj 11 0 obj <>stream xœe“{LSWÇïzÏNnn‚m— 'ó‰ñ…š‡bT$ˆÂV`Á|/° ì6ŠoÁ½ÂSÀBàñÀæ íAÇ^CÙd8È®ÄÙí(’.m4gVÊôŒ^Vq’œ@N6FÐÅ=ÕÜ2ÁE¢u¶«ë>$‘àìK1#l(RÀ_c~„”¼8»í¤Oî•(À(q+ï–ŽY†k|$ò•ÌîBÂ{ª'f¬R©,+G½Æñ ÇÛøýÛi„]šÜ Š¦ÛçFF}ÐûT[INB„¾:íºQvaTgûi‘%NEý‰pšê†ñ¦²½V’’ëÐ(@$|9<óÕƒéÑŸá3ø‹b.õÎÁGîåVC’êæzuÄKkÜG.%ƒE¶€¦äCí-ã?<0È® çÒÆ·AƒÜ²œ»²N(™¶B2×Ôê±M ”½íÈyÝô[˜_D¿…gè4I÷×t×öÃ9x»m¢ï¾Çëƒá5fLíÎÜ:°ç>åºuÄ7•mfO.pG¥y¯…Ô¡a;ØÓ`´ÁYèVõÌÕÜìB‘3Yï}œÉ¦®^+DÿÀ}ã¨uŒ‡ÿ¸NýÊjFF-0í.5îæç ‰¦ .!Š":ݱä%‚ú®½+XàùU <ð†¿³Üß°7ü|L"%ŠOa·±cÙK„¢!óì ƒÈʧP ›NS/Ö ’h«m¨Z*ª*,fiªä¤áaSÆÅâq8{:.‘ý€Ût—†rkE±Iè*Š!yV52!jpzÜ‹B&ùÆGl(wàhåsZQX W^*tõ_rô+D¡%6ÝRÄಅåƒ-ÁÁ ƒC0ì/v‚Z endstream endobj 132 0 obj 1345 endobj 9 0 obj <> endobj 8 0 obj <>stream xœeUkTSW¾!äžck™6w24E“Ô¶ö¡õ5­…¶Ëªø¨-RÞò°DˆyļIáᆀ‰”Ç€Q¬UñAÛÕVk»:®™…ΪӇ—vuz.½ü˜›ÎÌš³Öýq×9{ûÞoïý}*4„ÌÖÝ 1[bW%©Š”¥/&hŠr‹ƒÇO²vY»\ȽÎÿõƯëDï-[’)&'#¿#¦G)¡@PÚˆÖh %ªü‚2ÅsÉ {ž_µjõÿNÖGEE)öþ{£Ø¦,Uå+Vò/:¥Z£-R—½¦ˆæ£ÕjÕ»Š|µA[PªÈÍËSæÓRrÕÊBÅ•Z¥ÕjtŠç¢ŸWlX·n}¬ªh_y©â·/UÄj¢1Še~¹:·äÿo(ŠÇl)ÖÄFk•¥;ËT‰åI»Š(êEjõG­¥ž¦â©Tµ‹zŽJ¦Þ¢^¢R¨—©¨XŠáé¡B©,ê‚`£ RðSÈ{ÂDá½ÐüPV”&:MçÒ7ÐS(‹5‡±üú1ö¾_ü·጖½F¶JŒJK™Ùˆm^A’!2âMz«õÈ°œ-BpÝë½Ù„ýÜ°}él·Àv¼‡˜°ÝbÞZÍ'èÙat†l•Ða û!@RO²O )~É^—½µàK®ýäñC4—·Xñ6·²Â”Q'Õ“t?Ê8ÔÞïqy›ÚåÓd‰ˆøè“«<Úæƒ`‘B‰Ñ‘rë‰Û­¤RBé'˜ëq&:Œ­ûÄÁÇódÛ¼ð(»BrÄÕZ߸¿Åœ.çê$Ø,©5ØL |(µÑìLŽ£3§ºÂd=>ÐcŸLú–„’gÈ£Û¿y!1»$9[þ5r6$ë ¬IF© ‘â$G¦¿œyƒÃœ0}stfÂÈ€Œæûgÿœ4"`W“HIÆ9ÅoCä+ž5ŒV Õ]Åä*íøÄ~¬d°h$ë½=™¥*sŸvDaNöÅËýðÕeBMÈLÍ"nŽ<#iûóñWá*ôhÚ_Â\ÿ£R{WE€]°v‰aŽD] g:ÈgäS ³º†,Ù躺ʪÇk@ê{ƒ­ 3îòòƃ¯'¤F'¾{+C~éÀð¡ŽRPK³ 5©*u{—^¦ë­ì¶Îb·®nnmlðfbZÀ[×ÍÕáìï«éŒøúãK×Ζ½3"ç¨5GͽÐ'¿zv@µ¡[æûÏ®DœîJ켬'w%Óc€Ïöæo—sévÚ­ñÎ/Kr«Ó Ÿc’~Î=ÿj\né;Y22‹ª]ªŠG¢IªuˆL¨±ÞM€'ÝŽùb!‚íÎÊxŸ¯ö¡ø#vO0߉ø!·Œ³¿‡Žf? ÒÈ/Îm 'k=µ‡¯òHä`n#*ŒÕFs¯’“±ûƒÁ<Õû†ä‘â¹ù?“è P¬M™‘»ÞÓÐ^ßÒžS¶œ3#ˆ¶ÛvÈîC»š­ð&Õ¸D™¤T°ڲ2¦«¬ÿXw×±þ²îbyû¡e¤<Àr'Uñ±ÛÄr?œb"%:šYVVc³#ì`l4º13äÝ¿ß]‘ÙÆÅjC.ìצIhÜÊsûz•-Ö&”â7Ó²¶nˆ¹@ÂÒdeôW ꢙ½Çë‹hƒŽdwŒGôÍÍŸþšô ÷øuùŠK¹Sp_˜;5¡Ï–½_è=x4÷ÒåD% J奄ûj‡Å+ž›';xbØÒ³’j:ËÖ6-g2É]nb†Œh®Öc‡4ÌU ÐT[,6m¹º¢p^áñ‰`ØMn¥©õš! sMèõ3©7NŒíë“MNŠ"QcÝÙÀHÛ^©ýægì?&Äþ@Hš(Éb-‚6[d5¯Š§ü(ªÑÒ70ë> ]†n.÷ÐN²I´x•vr›D=ttûI(àót¹ AyüÈ£!"ÀfkÅ+µ<ÔYÊeò¡âÜð¶Ïuú¬ݪöØ`KÐÃüü,?'àõ.&øý¼Aµ»ÜAƒúS‹)CÎAl1'æ[_âC) æ6ÃdAƒ»µ¹¹·{²cðTW¿ž¼û&Úl Á))ó¡„zsÌaÒ„&‡:§Ïvj#å\>oxG|¤ñ¡ƒ E ÖN“’}ˆ<”weS|êÁød™aVÕ— Ù ±DÆà¯xoKÕóÞfzÛ¡› Izà¡[¸—.½Õ¹ôŠúÍgZ• endstream endobj 133 0 obj 2252 endobj 24 0 obj <> endobj 23 0 obj <>stream xœ}WyTSç¶?sΩZª¤© š`+H¯Ö¡Î·uq@D* c @BBÂlÈÄì'3„!@  ˆ€#jÕçô¬­Wëmmoµ½ÕÖûÚZ»Þ>øñÞzßÛ{ïZï­÷_VÎ>ß9{ïßtÔøq”@ ïò[¿q˦9AqJ™ö½u*E´~árþÂLÎSÀMÇÍpÁâ^=y$´Ow“ºÁ‹)à|t“)@{¤q½J¡‰‹•'{ù~üîœ9sÿùÏÂ+VxEfü~ÅkƒL›èåC~¤Ê*µR–˜ü×zR­PÄEyÅ*2Ôr­WDt´,š¿mO„B–àµ)N§V«R½|׿ëõþ‚ ý㔑)Z¯@•2"ÑË_µÂk»×Yt\Šò_ (ÊgûÚÄ(U´ÿzµlCŒ&v“V˜·;%È/!M¡ ^:nÙÂ÷-^BQïQoS;© Tµ‘šOÍ¢vQ›(oj3µ›ÚBͦ‚(?jõµ•ZLí¡–P ¶S{©Ô:ÊŸZNM¥””;åF‰¨7)1õ5›Ì–O…P×k‚/Æ…Œ»è²ÔåÒøÙã„aíM—1"¦€Æîg»_ÛñZßÁ„UÎOÜ01sÒ”I×^|ýº«ÜÕâúõ›ßøx²Ûdõ+ëð|äÔ´SN·Ç°tªH=ìiâD:~ešBžÀŠÔ1‘»3Vyú§×ôK9ƒÔÖ<)aø…†ù$¿áÚËŽ¤3¢n´Wo\g&åîÓiB×áä„5½ µÁn›`x£SœOG£CMû`Örvw5#ƒ²yݳ‡ÂœL@I²µ š gÓ¥º^wH¡;WVÇ¢”ª7É óþpV!«‡Nf¤bÅ?@þ/8_ˆƒiWî"rpnwbnA N ‚œ‹ãÝZz §Ò„"X|†AÙæƒfV ¹&¦ÔP‡ºY°1¨¤¼ªª’=´7;ªíž]õêÝRœÇ ý¡¸|Rlp0ÑŦjtŠ…æñžË+v†ªb$¢ÁŒ+u‡óh ˜éÂ-8&")+±‹ƒžÀô_ß²Öeˤ¥f„PÄ‘ý É݈=Õâè½±åì"<}öL< Kþê “~Ü~ÿª4£AèÊdµs+ùgÃB˜í%œRŒE¾oãéøgÁT?Išôšó‹¥Gâ«Ax9ž—¼+ íøÀ††¡R2‘¬SìÜ„a³Ã /,ã‡ržêŧkœ¥7ÊY‘îF…Ð΄ëkHkÜ=œ eîäUæ PocÂO+­¡ˆÅãVxao©èžþ¹ïo;¬çÏH¶20EŒrM™}Zrª1±{4ÿ"·^»ÚÑ®•ÕJq>CöŸa+tÓN·o¸õüF2‡—‹q¬†¶¡zÝÙ@v$‘¥£@]ŽҜ̪ʌFôËù0¢An÷HŸ°{L£+55·«â4ÌýœÆT´ÅWü‚[Ëc,ýìðkdX]†½a®8`G‚vz¢!>W…üÐö®Ä¡Ä‹Y÷ÐÏ,DÝ‚q0éL†¬_ÒmïZÍ:A¯¦³äFc:2#]IJU€ã€åiú~ÏÃá8fcˆúìZ}÷eéñæfÛày¥ÓÌG4¥:àÃËÜ„+s“u,ß©"×Á\¹‘BFä"³Í²YQ¿ZšÿâLºÃÂLælH‹~±0þË—d?Ò5?b—€Øä] ©Èÿ.S„1*¯´V×°¢¥Í6{u³çc'žŠ'«ãí=:)äâïìì†Åí·l%j¿"#E£Ä†Ô®ŒãÙùwY(¥sÿ¢;“Ðßj "ÝMYæ‹}°ÏWs`ò£sÇŸÝ–jk…Ø ÅÅ0©áä9Ô†U(JÓ‹TE{YžÆŒRYÓŽìÔ8ݾ&­VÁº©¢éû^,ªGaš´]…¬H¡» (`a_Db/˜‚IEõøª†¾•Û¨#¨11°”«‹v[uï½ ñ›:%­{jסehnÚ’„ƒq¡’·"ö ¾fPÊYWxLH=c´ ®€Ôå3n‰?fP¸ÑšGhÙî`6ªÑmî<X ®Ìåºæ®KŽ!¿ '×$1ëòÈÄ*Z´ÝNg÷µ€¾e[‚µajIŠ<'-aîá ÏXèȶ¹]âùqùîÒÒý¹=ŠH“1,›<°ÑÁø—jÐ v1Cmý•9‡,’Fu¹±Ý-m½RQ÷`\GÈ>™zKˆDt÷+²Ÿy\aÒ“VP\4·»¡o?„àž1_L½ ¸TîmñEü#zNYÃTeQžxâ2¿¹q5ñv•´YÛ¨?“ö¡:J†‚QdCÆ­dVô›q»9^9m׃8pƒ?~;ôÓç½%[éÒÊÛŽµ5Ÿ”>ƒœe6rü`‹½ïâ4tÒpLÕÆ>¢ñû#{ÄäˆK-™ñ¡AI¾‹BíMå–6»ÖÒä –qfñ™FÙ¼yé±!2N<û¡±û ‘@Nî¿øÝËD7÷%¡ñÈ- }7Ÿì5˜×œe\›MH<âdæ—dT£Ë,d1/ »cj1Kxö½†ÎÀ´\>›À]Ljîv×T]xz-SÞ.iÖXÔµÛY-ê†P2/¬Nny‡ èg[¬¯ã}äȨì‰IÛ,Î1‚ýcÄ° VµsŠ3¾ÌTƒC¡ÇýZ£³¦Íy´Õz ¯Æ÷&ÞFL?ÐÐ÷ójuh=;âÏ u&ÓJ^M¿w2+«L¢¦°·•(üïBˆpÒ#Û¸{bTVRW\F©*³–:=Ÿv‡¿½M*MÊŒËY}˜… ž|†ÏàÕ€`ˆïÿ*!Å{°RCû/‰:¸5ˆUá‡ÌÖþ¨»wNûªO¢±¤Ée¥"•±þ¤.ý0@îo%Ö˜ï6ó‰Šv=ƒhž]dæJ3ä(»r²Cd:ÙF^j¨E=,7™Ù™bÑ/áryÄÁŽøÎŽþ¸®pÞÕÒ;†§µ§ÛÜ*A¹0qªè!—ΩÄÄ\”J&');;“h¹±8¥‚´g I(“yâéËWa·ECÛab ôN·Ž$ì±iÿÁU»ö9ÏÉ$êÌOÙDŒŽÒeΊJ+ª@–‚æœó™Ý9ý¯¾?nBl;.ųÿôÇ“)NtÖãÆ©žOO¥ÇœtÊ­‰¶­lœ¬Û ;'q¸ûgy®÷×9Jn¿M¿QNü6¬ˆHH? #8T˜ϯ6 pŸ †ŸjTyFêl¤ðh™¾ì 3Ÿ[J™E烿겞¿J¼w4¯ O´ @K]  ^£µFã’²ôa'³¸ÌX…>g9oä…Öã‰ìQºB…#£ p¨ð(]‡NÃävÄÁó ñ-xÆŸ%|.Fû2²ÖðGýêdV—¦×¢!–#ôj²Þ/&ü«†¹—פ }£Tf‚³#\¿ÚødÚRXu¸ø°£À’ƒôÈlÊ0ñ›øMwn=Þ©e: j3‘l”@ѺŒø‚±½‡”ç•¡3,ÐŒÝñ#žV¯)7 ldÈÊU&zcDyÅæj¼šÜþ­¥áfkçI“eã6“hÌ?ÚSKwç[²Q22ècꢳS q¦¾‚êÔûiwsÚP%²V•ö³¬×2½ùG7ú•¥»oÆ«µ·ÌM9yµªOÇQ )«h+!e-Ó’W’Ûê¾#Ü4L›/ðM¡†ùœ·µ»¢¢¥ÔÃ1†t~ x¦DòJ¨¥» ¬(f´Ñ˜Ì´¸¿7äP#:ÉrßñÆÀ¿üqÍ|ˆ=Hð ˜AÂ)o‰M¦‚‚‚ÃyÈ#+§Ò*…Zæ/«/bW,\½wM¤CÓw²ÍÑY›[c°JÌUe¨Œmj³v]mQûKÖ1xbìþ´M¸25Ž ÊÿÌÁ[WNÛÎ_–Xö6§ŸCý¨ÝÚÓ§krý‚·œ«i-b•©­'¯ž:õe“{“™Þÿ=H_ÃðŽÏAÔïÁ&×bø¹Æ1_Ìá™kä™ËK`™µ±¦Š=²6Õ—×{öÖ%ïÁH£>¦`l™ò¢—cÅ¥|qs=©DlO6`´4Âhñ¥f’»‹ŒÕNaÖÃMÆ\r|>9¾ÔXƒzYE;²qV˜!à’ø찘á“n¼åhºL$6ŠÆ!#'„?Ò`^ΑnZZ¾#÷:øºÀ§üüJ±@˜ÄTWµV9Ëkë´¤„HGÄ Z‘–éK”‚›è`eÖ¡‡,w'sô©àÁíZ'`º §!Z:q½!×›Äà94±Úy_<躃>÷øÏUŸcjß´X¹$::-Nµ†zûî¶Khu¤7ÇV§V¨ˆ´„¥%ìß»RAô6™[Ì Bìè7Ûyî“Gn`Ÿ5@O}s•³‰{®w؇{³7j»Ÿ\>W)Íd¾NìÈ<ÇŠî¶'6<0m½,t§6Ýr<^Ý«´*+Skã>ºû> ‘ŸÓºþÄ.iª#³:ª}s«·ñèµiý/xû®Ù7+HÒd– &ƒ ·ÐæGÀ¿ïðJ²*ÄÜƘ€UD?ð›¿s®2¢_àžÞ0ë&¸Ð¢gÛiüÎ[XFƒ Î ñy~fÙ×¹ àåŸ]à]î´Úé~ ñúø?~ÌéËÈòøNu1ù±»ÃÂv'««EIÂ+k’›¤‘ï¹*ÿVÀk?Ã̗۾Ăv©Ì¢(YQÚüÈÝ5ÍÆEØ ØFwL¯‰“&—}Òëõ?¿µ× endstream endobj 134 0 obj 4137 endobj 21 0 obj <> endobj 20 0 obj <>stream xœeWyT“׶ÿbLΧuhISIi:8t²jk…ÛÖ ‡Z”yJ˜“„¦ Hd,u¬tÐÖVÛÚ½·ímµ÷¶ÞÛ×óÑã[ë}¡÷­÷Ç[+d圳ÏÙ;û7lµpÅáp‹Ü½o÷ö=/„§g'ç¿*ÍNÌѬßèYyŠñá0O,`žä’7ȱ?>ûcïè^Û¼ð¿ÁÝ˱æaŠËáä×¹¤2E^zjZÐÈç^xáÅÿûe½¿¿¿ïaÅÿ®øîHÎOOÍñ]Å~)JΒʲ“s ^÷ `wge¥ñMÍRÈÒò}“’’“<Ç$f%gúîJÏJ—ɤE¾kžóÝ°nÝú ôìÃ…ù¾óõ ’úûú†&§f%æýÿŠ¢VnSä‘&È’SòRóÓv¤‡†ï)Š(ÎJ”g^ðâÚuÖ}L²ÕWñ*ñB!èõ¥:­¢8O—´_øWx9æMÝøüÝ©ØÂÖj.Eë.sÍ-tyý<ɼ2¹Bp’a´B¦Á{Ç]vG££~¤žíèR9©rT:ËÜjk*ì£É÷è‘óÈ9åc±ôƒ}H ‡gÕr?Û¥.´¹^Ù¿Ò̈ôà4¯…mû—Õ“Ì¿Æ8€iîÅ6e.âñ E%¥ÅP*£ÊÝ|Ð þà—µ/|ç¾äµ@Àھ÷öß“ÿ ˜ÿ×£¡ŒÝ8ÐxñßñB¼?¼ó»çÃâó"â%_ C]DQš&Üóá烅}†OݘÚBhÂÞ:Ü'Æ5ó}ù1ÎÀh˜Ã¼ˆý„1[röB($ôæ\TŒè«¯Ðø ¿üC]oÞ@öpÜÑH8±ŠäôØòàOñ§1º{ó2¦ÆÅ%f™Á+…M_;~®@‡Ôþ*MøËðp«pbç[¶©f<¸_Žiþ%WÿÈQ‡.§UÜœkÓµÝîjmŽïÚ¿ï€,.W’_žZó:íŸù ¹Ê‡íÚÒÜìNäoÔ6ÁM_ÅËПÑßts®ÏrÍÌãB‡ÑZkºÓZ/!Fõú½¥ì9½í6*p‘Æ…h`âl·ÉZ¡k7«› v ;œ-=ƒEîôÄœ‚Ñ’¿³ ~ 0U,g«7ÏXñ+n¼¢gŒ6°àø—|ÑÝÃe2oáèfTÌöH±¹Ðâ-k”5ä½v[ÀºÀîä2$r…Bi¨ÈÈÑC1ÙJOe@ }àËø»7¿ìŸô· ÀÌÄŽo3¡Éû@]žšÁ=8Ôm±Ö˜kŒàª¶×˜à8Œ9û»{œCpz+ÚÕô·|òùƒÇ…ƒú¯ S@ÿ0¨I Ù’Dx¯„ôN¶›íãg% øGáåž¡Sý]Êìfqkš-’è°œ´¸ý‰ÞÙÔDº¶R7³Ö­ió‚ìÿÉ A ¾†¯ /Vâ'xZ~uu™¾¦¦DÐÕihA‹¥°°>×çШ€°#·c$—2†Š[ò!KŸ)Jϲ·ÉÅEeíš‹t Ygç›ëëØ¿ChGu;ÛÂ-†žîÊVŸ/>¸ôÉÙüÁýÃB} mVuB·h¬¿çÔžô íb'ÿO–ö9çaé ¶iÖã{ÂñS}-£@ŸíLÝ)!Ñvë4!†?i:¢Ñ`iƒ~K<÷—àÄüýqb|UÓKóÊÃJD²r^ ª¯5BЖòɃL; e!åìù,' 1élžóý¨Ç˜ß=tÀg|æÎÄ¿ ‰EÁŸ¨²UÙÊe¦H Ék(3H@6­Æ|ôSÏ“SâÉ©™îkp¦ä£©}ÒfYg‹òrœÊ+ää uè Ä¨0rÆY± Kž!«IÂsÝ[/K®îº—ŒÀÀ Ñ8Áe›ýRÝÊ6x¿nšY2ขì›]!¸-,‚¿®b!ÔXc4ˆõe†2½.9´)ÚɺƒoÀ›y®ð d3¯ƒß9í.¼èsóLëNÎÏl4„9Bت)ÝTņ:ˆ2–8<¡‚|æ°Ïzô¬Ý®°ia›Ç²é«Ý̬1Ëõ´„5fUNÈAW­«Ô­!6ï•ØjpT9ÀÊZ³&ó‘µfQ*4RmÖz/!cÞu£ÞXnR˜ÊM`³Ýy?Šox÷^3™ûØÝóØšdæ\œïïãÿžä2˜± á¾­ù›Fö1*9úÒÐ\«iÂJýn}rI¶,foÖVØѲӊýqè}†àÓ¦¦¯Ìì‰a9ºehÒÂvš|ˆÈ¶¯ýñf̹9tmTÜ1n=_ÐØ1åŸY]c³R¡cúF=(AeÈ×ÊÖ“<ïM¸@y ì"hk2Ÿ6³9Å«ÐñJ›Öa–›å&Å:ã½;*«¡QGm–cõì®·T¨½Ú¢k‹Â>ä®·-Û¢6±äb±ÛºX)Ö{ÿ@´Ž”zƒ Dfh°6±ìŸÞ­ãÆ·çŠå‚Žsk–ëšã Mü¦Z[-ë¢Õ¬âç"ˆPk+X„i(°¾´ÎÓÌO¨².R™¬Û¥œ¥`ÝÅÐKŒw‡—ë[¼æë9ô‘PpR­,­Pù蓉`º¢WÕQ8œà ú¥mÑîâöŽ£î¶úš†³¤ÚZc3Ý=Ð66Õ!Bdí>eyBra±:2hgÚopð•;\FŠŸjRB5e‡@DÊùø ¼ã»G?‡/E¿üå‹gÂ# ¤ˆ3ÓU™ÊG+¼Çþ1<ð1гC7½·vÓ ÙEBx¥Ìãè<~’ÍêÎܳnv>ãâ3ì«·Ådç¦Äíx5mõü£ÇŸûÛÊ1]…Ó™¶fï×ß—Énæ_Õ~¿Àoöoºgzfú†?½TÖìýŸ0xóîÙ)¼q¦¯ëø©ëúð"À¦üüÊýÃgrÛ"JK¼¿ ìNëÙÚñVÓX ÏhüdAÒÀìÔ€k‰÷²b7sÀÃÝü¾Å·ê³,Yr»uÉRŠú¬<¼A endstream endobj 135 0 obj 4317 endobj 18 0 obj <> endobj 17 0 obj <>stream xœe‘]LSwÆÏ¡Ðs¢¬sšÁ9G3Â\`Q²9è@¦UüZZJgK=m‘•RZDÀ¿X*­´¥”‰|TÐ>hâˆÉâB–‘¹@¼™ïÃÅêŲ‹Ý½yž÷}òüòâXl †ãxB¾âP¾VÖ—Öq½ëÎh}œoÃ¥-˜ǹk=yF¶Ú¤ÓV˜™ôÇŠ223ßÿOÉÎÉÉaTÕÿ:Ì~ §ÓV2Û£ƒU£7²M¥ùS&/º­×ëÊ­¾š­à¥Z­Q¿9;©Ôk.0_êô:–5Z™ô¼ æì¬l¹Î ²pÌ1£AYÉÈ9Ì!æ°F­³þo`F|QfâÌJ†mÃöcÇ1vËÅò02ŠŽÅb,6ƒoÃø1¶˜ÅõÉZ9 À¾aà¼pÜ‹¯HÅjdó†MÇ÷&Å‚ic\ó£æ¬Kf‚’q¤ÅìFAÔÕðMw'ƒE<¸§S‹,ÈZë¬h¾‚j¯Ú›I,ˆ&ÐJW qUhŒŠÄþˆý/ëÇlñY€KË•í*D~¬X‚”¿žLzºëëÚèVBHyíÌmó"Ç‚þṂ‡ );¶ ï ÔËtزð¸ÿ—Yºúv\4ùùl½7aè¤Äy¨ä•Rá('Ž4¸kQ)< ÊYWROrÐã'ä-Ž.4GÂQb2 ·w\¶¹©¶ÛDäP04L'ëÂçNkØ‚sTâü"!áeöA~w¿þP¯D° /¤f!j®8Pr^·µ~í6·X™uð𮃣çWKéŸ !º@ª ‹œ_²RF!' vûÚ¾í@­¨½ùFcŸcª.„È?ŸÌ½|®Ž¤Ñùßh ‡÷‚}uÖ;”¯Ê]Ý]BÄøÝñÖïã“@‹`6J·ö˜ÄòOÊŠ $;),…‘²ùg#ß/ŽR&w•Æf·"™±îÖ Ó+÷£Mv/Ÿ?€`;H€R!5)q™7<•:MMMW¯ ™ýr‡‡†›Äo{§‰·÷Ô>•ß4:òÞlèrx(צ6ÔFúBžfƒ¬œÊ%„ÍÚ3Uå¦RƒU‡JIùƒâ§?MxÍPîSw.ýˆ"¨ßso´Æ—œ¸*Ü•²ú*‡HƒµodvlìW-¤EkMÙø´iÈ÷ã3@Ã.Ø!íÚn©p’O¸:\Ñßm¼î$^<žPݵ=B2-¿†  >%ˆÎ–£.§¡“æcoE¼ž0"çú „$2~¥dûÒà!$U^^é…"¯8¼ ˜Íáp|<0½ñoaØ?W0Ó} endstream endobj 136 0 obj 1007 endobj 31 0 obj <> endobj 30 0 obj <>stream xœcd`ab`ddst÷õqÑÉÌM-Ö ÊÏMÌ«3LÉ(üfü!ÃôC–ù·Íﵿ®ü2`]ðsªÐ÷~Áï-üßk˜‹{ç;çTe¦g”(h„…kjkë D ---’*a2 .©Å™éy j@FYjN~Anj^‰µ‚3PuNNf²BzNeAF±BbJJj H[XbNj¶‚[fNfAA~™‚†³¦‚‘¡_fnRi±Ø­ ~ù– > A©é¥9‰E˜2 ¬†FÆ&¦ B  " ¢ b l@Ÿ3°02¬f4g¬büö«†ïGG÷¬f^šÏøñ!ó÷í?-D{°Ö²OŸ0­¿¿wî¤9ýS»9L©É–ÿÉÞÕ\RÝTÓTÛ‘ØÅQó}Å,v›žê©Ý»9~¼aoîevýÇ¢«ŒßO> endobj 26 0 obj <>stream xœyiXS×ÚöŽ1{o[µ•˜š€M¬uj­³VpžGT&Add&aN ¦Â$Ìó<£8‹óì•3u ó>­B-¿Þýu!¯|êŒÿ²bÔ“àƒw ú]‚ËáDfY6JeŠˆ@ÿ€¨isö:íÿhîÜOþõÍ";;»i>Šß¯LÛäè6mþ'Æ/D* õ ‹Z9m#^xxšˆB9ÍÛ××Ï—½mŸwˆ_ð´-!2™4fÚœM[¼pá¢Ý¡>Ñ‘ÓF;m·Ônšý4'?ÿèïˆÿ¼BgûõŠ°Ã®»6ÄI}wo”ù¹íÙ~Äas„¿ã–ȧ­QÎÛ¢ƒ\¶ÇïÝâ½o§<Ôg¾û§sÇ,ÿ„ëa;¯Ðnþ‡+x­\ؽhÖâÙyKæ,ýhÙ$N 1‘ æÓ 7b±‰°#æ™X@Ì ‰-ÄJb!1“p"¶‹ˆY„3±XLÌ&\ˆíÄb±—ØA,%>"ö;‰eÄÇÄ~žø”˜K¸»ˆ Ärââ±›ØHرÄ*b 1ž%„Ä"ŒXCˆðÃ¥„5ñ1–°!Þ%ÖS‰I„Š°"(‚OÐD 1™Gˆ·ˆ÷ˆ\Â'/ô Îp6qúÇXiኹ—ƾ;öàØ/yN¼Ëän²‹üo*žúVÑŸs÷Í[ÛÞþðížñ3ÆŸœ`;áÂD׉ïX¿sú]»w›'͘9©ÝŠoÕÌ—ðƒ&™¼~ò ÁZÁõ÷ܦŒŸ"2" ˆHÑ<Ñ%´¶³~n3Þ&ϦÁæèÔ¹S·LíŸú×÷ǽ¿íýzñ8ñB±J²Yb‘<ÆÉ{ø䟦Ϝð«r"YÞÉüh¶úòõ¾Œ¹7âüTQÊ8š/ó pQØÚl#7¨s[%L(n?ΡͨUNÝÓU`3=â@ñÛÁf•rC ¾AδRÇà^9qø°@×næ gxŸYpH¯-¸‡²˜«ÂXùŽ$ìD³âÝÓErèf¦ÜcuEúâ£dŽãAÙ=·Hf*ˆˆKÚ—AËaž™QÃD¤`¤QÅ“™4ö”¹há0RfŸÙ(ɦ’ÄøÔ ]Z²äcT(˜«+N5‚B(3z³hòQQ5©¥š¼8H¢ ¡>ÉZw Ä(E@eª –«€$fis䆸ì8@GÅÆF5Eô\?vÎ8-ó™OŒM…Uz‘‰Â'&Æú çÊS¸é)·„™.ÈÕdº._é&A™pÒ¨\Si% 0Q®ÙÊ"ÐFÃêXEQ3 «B¶KìÕqØE¾&Ê-'¡ ÒPA}çyv½GHÜέâÇTr–›"Pã/ŠÃÏtÐÞaxõðËL‡ î›ý#½pçgúû™ÛOÚŒš#’Üè¦À •ÜV‡ïK0Sk²ã*Á43›‚Ù#GyÅ$Ìgnñ&/À•ÑÎâ™ÐTz‹WFæß5™.ŠIdùˆ§d&PÅІ‡±¬­c×qÀ Xü‚ õŒ—½·p.#›ogA+hõò(†S|&KÔRÁÓósÑûˆwhë:ß#U]1éÉø[8þß½t[Ìîu”0oáÝžÃا\øJ+€³OòJ(EF:H´Rင¹B¥d¹ÇhwƉ⩼Ì\èö|­-¤üšd…‡ñù©ùyÓÑäûKᘳ–£-’Tv/Ž€ää­F¡ ´­Ëgðȼ÷àÔàÁ}„+eøˆÆ’ÈÂÆ ÃfIß~?ÃhL%.´›ÅÅÙÙ' rª#­8Õ”hQåûƒ]4zA9­•“½ 8©ë =²‹âËÿ 6S)¼ën œRLz T}Ìß»8ÒÜaSR"Œáź˜ø„X”ze®[ɼƒÀ؆ìrÙ¼Ëo>@cÀü†e'œ.ìøÆïoòÀß.>¡eë7mµ"{àlñêp y —†Û¿…ãàÌs'cw‰›‚MRóºr”CKãÊ c3ñ‚Õ­§0úù¾2Ÿy_Ÿiù€n1hJFX´î×ht4_Sʨu™êBp™†‹¨Ö *mÅ[ßÀ±p&|wóW;{Fìõ”<¤tY{cÔ.lŠàÇ‚†³m÷×"qÝÖm<èÔÖ †£¬t†5AªÃ|mîk½Âv'àUvNÑ‘Üœ~‘†ɤ«Úúˆ¦Ð6òýà8¨ð <è#Ûì0Lï,ƒÔ÷÷ÏC¢Goà¡Kp¦ ðQKûEpTIKiäE²rÕÁ|ÑÁanÃM‚8gmLltd„§ ³* ™MÌ/<ÓH%‹ÖòjÈüÁ Ât§Î å&|¾Á8¨)¦\Š’ò@Í|¯¡öóäè„D¦ªµIÑò „d±–àú˜«à†Ö©{Ï.5m#j"|Ž…svô®ã|éá«ßï@š27v”kÃÊÄ%áEÚR@WšË*ÛAMziF xNôV]hj»®U‡¬þpßÒºy8ªOP©œ¼—T é‘ÍXž¤]›üFaVé•Åà. wPðÔXþ«Zƒ¡Ú\:8ãc‡ˆŠUefE‰¡‘zã©Úao7Ìï¿1V¾Ìwpµ@Jò£qÀ+}h##Ý€wN²!EŸ^Jià|ês`RméJ¨Œ"“}R••:Nšt§b>Œ ërskÅІÄQ¡,]DW“üæ4ø!o¤Ÿ÷7ö»ó•3íT?\Í{éÕÎí§\c-(Öçgº:?ÞS‚ô8œ¼3Ç0ÙDmÕÇ™À9FSM½ÇksóS´…âU¡Îè*Si]sŒ%Ð;,j“›äLÛû¢ýÕrÌ £.ì\bSªaPg¦ü[0þam— b„‚Î5T,f¾XCtžPV Ë ôüõÚ×ú] ’ÈŠ8]JP˜:Ä‚˜¢„îØMûeAà½ï‘ç÷÷Õôœw4–6pé`Ïz=ä ÷eEäƒ`in­ÍËÏ0dè9ݘ‘ ÚA—©±¶¹ÎÔ Žƒú”JUý‰ŒX š“?Ó úëfµ¿ãZ_Ä[âXßWi0ö—äÀoçëZkâBKÄeEÀ—v ðØã}õ¥XÏ Èðä1Ä°#Z"@¤~eߊŸoÛJºî]ëøz”—=ÐT8“Çúðü¨ÁîüNq§wSìíÈ£.«à/¸˜0fÒ¹e$z1Ü%èòÖÓîMsâ9a3{ñÙåÜg©Ó¾£Á?8¼¬ÿk÷@wßÑò!̣ȾøoÐú–‰„ñ *a¥B¹ƒe& –,Sÿ,ÿ'X0¸m5,׌‚{M6¶OwhgRO@©²hŨ²ˆ´ f¾E]a.A»[Sø¥ð¼.à’ §ò4dzzbr¶p"Ðfir0+åEGg‡Û¬rrÝèÜtø™»d(¨5¶4„ˆ<ƒ¥®!Æ ¹8¦:±R}ŽŽG ¤¡ ; ã‘oŸŠÓ+±2•êêjSËl^ºu<²yO›W¤%ÊjP+êj¬8׸¸Rl"ßXo›Ó¬õÞd|)èh(íôñjÿÍäF­Zµ£î÷Þ[ Ë7ièNýì}z…ƒwä1D³‘×GµëÎ:H®oyéÇ€çNjíj¥¡'·rè2LíÚ“Ìø&+SÐ.¬*Ï`fwþ³0½dèuâäD]b²ÖÏÅË=>•æ?Ó$ë’S¬AZfº>æÿx &—7xì¨:Ù,VÆDÄi£èˆ²ö²vþØÄ>gþmS«Nxmuéõ§ø?ì]]àÂSbY”eÌÌ¢ªQŽSR`£V³…Õ ­‰Úž“TÀÆR©zÞA)à3²¨(©´"ª®¾²¢¾.ª2L‚‹LÕmaPw Åªþ9Tý8…ßÌ8c{Cò§F¥j4q6Z€›Ã<šß\|äH^°ðŒ Qxƒý`eŸ3ëpÇï¤Oµ_¾:'DÒÛxlXlN< Ž"P¯‚äÛ›3‹ŠM6˜þSÍÉx'eGWR— ¤¾zü÷Ï]®"ámÉô!ï>pš>ÓÓq©¿Gîß*n ./qÀÕ y£.öÁv3ç/¯áÙ×\è‘î£À‡llåÔÃäBÍïR¦MXÍV{£™Z—‹¡v›†>ð,ÚÿgWØ6ê?wAûÐY–ðµCNfE©ªØêÒS¸Çßž‰<.H!=4ØÕó—h1ÅoŽ£.¥iÁ%P@š¢RidÑ! ¡€ö néa—=F³TÔ±´b%ð Qµê˜ëÝöÎ’ÚZqo/Ï–ÊN?ni+Äì}̓û„õµ·¯]¨Ï™²‹³°¹Ë3!/Ù™Q˜ T )Q¥JÀ-åD!cK¥fù%„%9Æ‹BYbfI®6s^¼†¿õqÈ Àë¢’Ï p””rê‘®$̦îì¶&ûŇÊÜw†¬›€[•ì¨¢)¹íqîŽú3Ðmrê±z®Rhý;¸rî·ÞèWõ䀇4ÄcDªæ¿Í¸'«‘9.w Ÿ°c….9õù›ÛGS‡bÂUº¼êd±¶5¾»Yt”Ì»;tïÀI†=ý›ÌÝÀ™SR-ÉÉ (u‘Ù"!\£âF¨(45à¼y*©öÔ"e¯Anç*"wáXœZ^ D ¼(¯%¯Ú¦¤*Óó´®Ð}/, ÍSåbýÊ3Õà&.Yø5ÒÉÖå‘ää—táîýo²}Ž…}Ä;oˆ”óø)׌sKfeâþ»©@…{Åp ìU©íSp¶5&Ê>;¡œ¡™ïp^öÇùi·Ä?í9§!FXeeþÎy2…/gv_ðûUq )J›¨äâ> Äär2¥^YÝæevô¼õnöQ–ØʪrKEvFN†A’žŸ‘ tmSE×`mØ^ñn Íß—äå« A4_nßçy±¯»üäEqÎþ²˜nЂ߿µƒ®¡Ð‚s’’“©’&Æ:@ÚÒ+ÉÆRÔÝ'ôa'ôf0<ÁÂÞÅŽ´¼åä™´2 ‚ødYB(š=¢¹ðë »I•À$æ₦¬lìÑŠ3qžÍrj0½XÕ»fŒ M$Œ`†šÓ³)–}ÙZ~ñšË,ž"(Ê(Ù !½( {Ùè¨PW´-Boêà´³H-Rÿ®üš7³«V3µšúáÎbUSþËôëNo‘" R%K3R€ŒNdžÌÔþLUÁÂWHõBèn\-É»‘#2#“|´t-Ì6¾=Ldˆ- éC“¡«ð 8Þ\ÛPÒ”)2¡ÅJª!½@‡«-!!:"$E— PǪ,Bi¢A±ÑЉ±qX™O5€uãÁïÐ !"‘]¨69(M¤„3M”4!ǘk0-’Çð¯Ñ´l]–èD@‘œ”N+qh̘FÞ?ɹõÚ³\33]`Ô籃њüxw Êeá¥tÎÀðŠ0Qû²”… “†­ÈÊ+0ª+{K[ÝW€}\(œ5'V¿£L”S¦²\¢aÕÐÛ\6èse2[ ò§€SR’c2^$5QáY¡Yê2Ð)‚>|Ë÷ÂG×pǽbŹÀÚ½ÀHU¶öô}*9ËU¨qQŽÎTÓ´MÌÛ—9מÂØ¿pá¼áÕ‚”,o¥,é ZÆ2Pnf60º+?Ñ[2RB…< ú _Ã1ðCøÎÚïfïvôw‹ÃóBc;¶|t|5šˆ¸î;íöª¬ããNüuÓ$þjË"ÑMNžHÁH”]¸VŠ&¡o„H¿KÏI¬ÈЋËufPª* N³H´È©s‰-+›í„ÓP+šÁŒO.K-eÛņz¼$]NH1)ÚçÁ½#-,Xç3+áÒ‘•<ù ÔAY˜ S&[ºÌÍŸ8?t½ÜsÌfÁõæþ‹à}< óP@dT`p…¼=×™™+6d‰‰:W—,=²÷ˆ$_΃Ê÷þWë±ì¡…ÕÃùÕð€ O¢)‚edP|i«dx)Õh46‰_T#ÿßÎCÿjÖի꘱ð-Ì~Áeœ†×áŽKë(ßàŠˆ5ˆÈ,­]Ò{ Ãótä%@ÃwŸymò†'ˆòŒIö³—Ô¹˜ý¸¨&½Dˆ¼ÐÁóãq|ÇøîÞ¼dïwpÁ‰¼:‹IR^Ò˜ßÊ6T¼ÆÒk\˜;HºJ‘ì”á¯ʶ#Éö]&fV³Öݪ­n<…{°yÒÈ,Ü@H°S£vÆȇ2圭.ÆT ?N½ÌIÛ'A¥¬&%îJùçå\¡¡‰ 2ëÍÄF”ÿ$Ù3,í° ZÔK‚>}cNiqogC?¨fuU Yfd'!å¦ÒŠžukÖ:†»ùKB}4Gt+é-AlÌ’,ÌÝ{f/FÖI: Ù¥I½7ÊŒg€†’Èmä[ÞU Oç•`Ò×ë,ñ?YýÐ9…ïõúà¦^Ì/®”·½É&ß+Ë€óió§s4³› õ½ôZ«›O¡‹&æSÁMt‡tªDm²6=,ýŸ%›«*4ü: /)ঌßÏs0nʲµà$ͼ¢R²’24© :ÿU¢\•’h“´z%n'ŸJÃr#mH©o¨—Ö7u ½)˜„ß5 ÃIò§òã}EI²21ÿ•ÔlL¬´1€ì¬œ}@ý vÐæ·Ã.úŸGþÏ©æ’¸ÉoK©•:D¼è ì†'ÖY›ïAéM—Sø_Á^†Â×ßNµöÜ°þ|ã…Ùˆ³bÛÂæ°Ÿˆù_!Â.:d«õÇ·BÿðÚߢ /ÄŠ‚»û«ü3½ãСk]‡¾¼RÑ3tT|Á“§ð~‹‡üÎZõw_¾Ñë¹ÅIzÈÉOœ’@jO ÷]Æ\·ìaÆeÄŽVÓ Ç êǺ1iƒØ€²_h{™±uð ÷|´Ž5ž1ßüéÁEø.€64´[Ç!z{ñ,dƒ&ÞY‰3=%ݧÄ>h9âNCŸ„ëc…ð,3AbS5‰ÒÈ#j@¯u¿ß>Wr¡¼FRj©.¬ô—ýËÐ*‰/‹…'ý  «Ž¨o¬©®o ¯ •Œêt=­ÏÀØáÃ*ÁlÒ­y?Ÿù˜l€‡xŽd(:ÄC"²qôCûá-8†ŒAÖÖØ20Ðâïæàeç)Þ²Ap‘­.ç6Óü+¼m6;\yx¥±÷˳£ðÀTÞãÀ‹Ï¹Œ¾/PçqR'"”DÂUpÓWßv>D?¬xø¡ËþèÃGÄÁÊà¸Må)®¿¶5ÝôÓsNËW{Ì_¾X‚¶ G^cMï¢rT¢¹¿ü‰>ÿÁÐÿ¦·ARÿß Úá@³ü'¦›¢ÌÿLc…ÿ_­g1ÚÆ|}Á Ö?ö»ÃŽ|æÁ/çAezU"Í¿y)ºÓi‹õr§ëe±†ª#âв8û˺RÐ}ëáãšî£’£Ý5Cà:84¬1¶B^äi¦ùÏn­n?mýdçÙ<ã‚ýÅ¡2exôSª°ûnóe@_í÷´÷WúGDHBC¥Ê­‘´š¥ýáøÕ1Fá÷^ï~ÄcÓÒ€Ù£•Âoÿè/3»Ýk¢O•W^–¶ÊîG^×<?€ŸŸ×^ª»ÔÐvg(±Dø†Øf_aV[¬`ó£5ÙQkŒðœIâ=)t}Ä‘·¶ •áÊ×W(þhÛ{(™„Éð%½üý$pÍsnÚ,¸w¬¡¦}àö—­£S]8ùÈ«%¯}Ž…WìoJˆ~f_P·®j[áZ0|¨¶•í–Ú‡úotÌgO¢jgÎ=æÀG·¸p;󙺒%Xæô†Ž¯„‰eŒ6%ãÍD¤ÍHÇÙI¥d§å5u%«»Å:rj˜CÏݽnulœ¡"T\U€»¥0UB„ßÑÈûOïÔž8.è/?€;òÇ=ûœ*Ñ[å=Ï„ÿšµ±}âÿ×mb¬…Ùg.²á­go7äÿ¬lü‚ø?ʘÿ¥ endstream endobj 138 0 obj 8179 endobj 41 0 obj <> endobj 40 0 obj <>stream xœ}Wy\Wîæõ(  mK"î4ž€(`¢âF@䈀x ¿€€ \#7 ^áP4bðBQ; ›¨!&Ä5è¢cÌFQãºjóÆÝ}3 Ýæ÷sÿãMW½ª÷ÕW_ ÊÂŒR(ƒC}üü‚g;ÏNÒ¤ÄE§!Ú)Äáfâ_̱®~žúü´rçðÁ%6píMÐ †„7(s…"u£nvRrfJÜŠØ4{ÇaNÎÎã¥_&OŸ>Ý>2óå{ïèÔ¸‰öcÉk¢ã“’¢ÓÜígëøø¸åö+â3“cSí#¢¢¢£Œn¡ñÑ«ì}ââã’““ÖØ;Îv²Ÿ2iÒä ¸„HMª}`Rb’}€ý‚èšøˆ”W~¤¨u#<—&- JŽöž“²Â'5voÚBÍÊEþkBâ#&¸Ì˜¨h¤QÔj$5ò¦\¨`j5‘šOùPc¨ÉÔXj!åG9P‹(Ê•r¤B(7*”šKM¥ÆQaÔ;T åEÜSvÔÔ("eAÚKff[ÌæÑæ÷,|-””•  èú3ÕT•0`þ€£c^²ä,Ó,O[±VYV-Öï['Z—X·[ÿ÷œAâ^5‚ °G0‡tQÏþ†jËK«« J39œ‹2 ´y¹åÚZî7ƒÆY:‰að!ªÕ–çåj 2ÕØ ï5´é:p EPˆÌžÁÊY’L’®ŽAx‰¨WâdŸ­ö5h”ñ²Ÿœ%™¨” G9‹×"  E¹nQö¾%$ 6•"¨l™vp§²ˆ¹ÜÓÞˆo…£ŒÞ³ž[éöp؆ºŠí*æà' {uGìŽòú¢ÝéõkªRøæãh)-…ä¥èªoÛ”Àsç«™ö# Ù‚¨âêlHVÿ"¹4‹+E+–¹z82Dd‡‡9Çoá!÷&‚íùóu‡Nq úíµ|¥JWPž¯Ý¸©°P¶,0Õ‹WaÅ{ÝOÀìJ7˜ýt)"´„Û’µM[Å«ªJËk¹;4Ó¬ï­@†:î¯åYADJy þÊÂdxª,3h vwÀêo‡* ×oØ´^Ë-_å¥ ä1Å»wä>Q‰nÈà&°µ¿v~ó€Àw2 D2ÚÁMÁü±ÀÊQIFÀö€ŒäÎÐ0b,iVV“%ƒFƒ CE Œ¢[ù¦œC±Ç"ëçñ¡*/z„«“³ë½°ÕT¨BéÍ’Öt»ëîÝi#8¬}¥,!²r%¾b5,@‚l'úZûB_ŸÙ Ü8<¬/B¶ðSÝÁ†„#<ÒI‰^@õ,Œ G™¥ÕÆ–Sƒ-ݯyáx DÓÌ ÅÉhPUm2à žôkra^ˆ¡à&MK|²é—Ú/ضe: ˜0«PV~áÚ<]a ×o9K'è L+«¬25…/¬FLS˜ú¤Ùn_·nwZ©vËæR^UY^^Y^T–UÍ­Þ¥)OäóK“\ÞU1è?“R€ÛB$ ²eˆp“e®_Ýçe‡•.° «îŽegëþóÍfißE¾j’œ„0B'ù¦šCM*æÁ¾Uû…aäÇVš¹/Q÷áùõi4žy†½™°ÓÃÃÅŃ°³«û'G_aB†˜jÜ}²&èsóú¡‡ N´÷Ð×áþ'd£Wô9½vkšm™Ñ¢·È²Ì¹ý±áÛØ9y-{?¾6¡!“kÈjÐv~Uô©vOî§95)|š*Ô?ÊUÍ”¾ãÓÔ•ÒL@UaùZr6V•›FÎF¾³I¥+èÏbNfµ“žUÞ8såPFcüNnÕΘŠ R×ò¢-šj°¦r]ÍŽaÇÏèºr:1ücõ–ìRmeŸÈwÐÌh£Èç®ËRoè#Ë#Þ2UoDJì!:"{»þÃÞ“NKÈò–ôöp(CU­ß5Ôœáß>ÆïÒ~’QŸ^µÚ4ÛÂe2i‹ôåý.[Ñuÿ6— ˆ´ ÅjÐõňLã7›*UÂ’0WbO„ÜÂ慨–$+Í€IMÇïhùœoWý4­sœ¿¶Wß“\= ÆتY0î¼2o®{˜‡Qoå @Ç: ¬4ÖO´$=óŒèZ4[-%ŽCe÷rDF®Ž- #j7Úõ ç.Ó|[Ãw'„#MÍŒÛ|gdÉââ¬m…²ÑúP_T–kêÓ\šyv8|Q­¿???-²eÒĹC»“&IDFb2D+LK1Í]¸-š”àÇ«/?v’ƒ¯ÆËšœ|œùeØçÏ6´~¥fÒüûtM¬~¬€¨¶­d¦O%k—Á‘ö]ºÔ_‡È8Á¢;ßµßåÄùøŒúEh#³Á£Ú÷M…uÿ6î4à.À RÒ.%³j†]¾®²z[™^ ÈðFv—ÁÝ yÝÒ! KÓm—ɲ œŒ´rÒ4˜“;e"Ɖôrl(àöP˜!Z)Ù&$Óƒ ì€o)3·”í²h²m^@0Ó`¥¼Ø'E¦in܉6MWnË0íD…E¹&Ÿ.ü š«Fb…ÑÏn ‹›7˾MUORŸgB¡‡ÅSd/`Ðc7Ùù…ìånâ·è%¡¼*hœ^m½Ó+G|wè}ÄdI¤Ê :tÉ÷´KÌûy‹Ôë6iù|ÕºòÝ–’ââõ÷»¶æU—O®\ÊyÓÁ;â?þHÄ›SƒÝ8æ‹YçÂî^üvÏ×gÕLŽÍ|~!©Þ¤;ÃOŸë<þôÄçE‡¹ÉÆ÷@Ù­6AÛÜ0VöÏÒXcÒ9u øTlTBRL̾ģœÝ×p¤)¡!ŠËï5‡ÿ_hµˆJH”>ìmjJØÛç,®ynÍ–”—ð%*]~y>ÙárµjüË€ ÚÍëù oç•Ñ}\R]ª†ž(¥×‰SëˆVÕÕ¡ãËãVV‚•5EýÜU}l endstream endobj 139 0 obj 2835 endobj 38 0 obj <> endobj 37 0 obj <>stream xœcd`ab`ddswsõ ÒÉÌM-Ö ÊÏMÌ«32É(üfü!ÃôC–ù·Íﵿ®ü2`]ðsªÐ÷~Áï-üßk˜‹{ç;çTe¦g”(h„…kjkë D ---’*a2 .©Å™éy j@FYjN~Anj^‰µ‚3PuNNf²BzNeAF±BbJJj H[XbNj¶‚[fNfAA~™‚†³¦‚‘¡_fnRi±Ø­ ~ù– > A©é¥9‰E˜2 ¬†FÆ&¦ B  " ¢ b l@Ÿ3°02¬f4g¬büö«†ïGG÷¬f^šÏøñ!ó÷í?-D{°Ö²OŸ0­¿¿wî¤9ýS»9L©É–ÿÉÞÕ\RÝTÓTÛ‘ØÅQó}Å,v›žê©Ý»9~¼aoîevýÇ¢«ŒßO> endobj 34 0 obj <>stream xœmXyTS×¾>1$çh+1’ˆMh«Õj«bç •Ieežg’„„¦M„) 0È<Ï àŒ‚µZ硶hoÛ«Õ×jï}݇nÞZo{ï}ëÝ»VþÈÊ9{Ÿïû~ßïûa5…`0sº:8æ´Ä-$" n©KT„_¤|ÕjË•i;=o ýmD-Üûc«bÞ¼ë6ô–YðÒL(Ÿ`2qóŽ¨hqlHPp¼ý¢#.Ç>]²ä³ý²rýúõö'Åÿ¸b¿3 .$(Òþü%1 <*:" 2~ƒý|wxxÈ)û pqtpœ½Ÿ¿€¿eÙQ¿ð€0ûÝ!á!ÑÑQ‰ö‹v|j¿jÅŠ•‡B"N&ÄÙOÖþPÔz{G{—€ „p¿Ø¿BŠÍŽÛÄ‘§n—DùÚè´+6hw\°ËžøׄP·}‰aG’ÂýD'×NY÷™ÃÒõË–ûnX±rÕÂÕ‹>ÿtëF aMK‰Oâ0±“XF|LxNÄ.b91Ÿp&v.Äb%ñ áJì%nÄ>b5±ˆ8Bì'>'Žˆ5ÄbâáH¬%܉ƒÄvƒ8Dì l‰‚GÌ øxû¹ÄLâ}b1˜EØ‚"fS .1ø˜ClÁLV„7q‰±“Ñ?ÅfŠŠ¹Œ™À¼hµÇªµœÕÅæ±õìßÉ8j ujêæ©-ÓöN»øžÓ{ϧoŸ^=cÿŒ!ë5ÖiÖgΟ9ôþŠ÷Gf‘³šlÖÙ¼ä8r†f{ÌΘ=Êuârr›c=çàœ[k[/ÛÛ7<)ï2ŸÍ?8÷ùåH­iL¢NúÉæû·¶œhú6ÜΕÈ⥊íì&v°ÛËÞ.ÏoÒ$¸c0<É£L¨UDÞWëe`5áDrÚÁ.™t{:^ ¢[ɳp;+–m=Ìн›þÐÌ?jâžÐ*‹‚ï# }ƒ—ÄFþ)Ð')É^Y|ô4‘^Iúº­!O/€SYÐÈî^R­‹2>ˆ•¨ŽfS"X`"'ä0• IX)TÇBÉlk:EŽÑ#fEå";)»©459#[™&\Œê óÕ† =(æƒr£®WCÑIY“Q¦(@6ÊæiUƈ:Ò åi¼£$B“ ’5HÕ(óD:I®PñIIq¡M±=7Ï^†ó/ á2ú3}SqQµ–o$ñ €‘ž{‰ñåÜ9Æ,¥?âæk‹rŠUW(õ¢¸(dî”I÷\i h£` y¶¿²¤PƒÕáû„(€Žr‰‡å&#é™—R)(&_ú\Þæ.9°Gð„LÓxŠCnÉ| ~¦“ò.ͪg€GLú#¸‚ëµ+(ÎP+|Éß.ÝyÚ¦W ó ¢ÊÅ€_Siªº¼ëÌ:O÷¤ “BŸ¨=`#…æ6ÐæÕC´]þ3š-”GqÇ®.A Ö‰=[ý«»…Qç“ocü>3zG`Ùë<(¥§áݞä1&|­äÂ…çY¥¤8; d*HU< ¤¿$Ó5^’`å ?™,ÈÉ€j/Tž¢d@Stñ)|~rb¡ÐìŸÃ)—;ÌgZ„ÈÜLV´â‚´´¥Bœ«Œ”ƒÛ7p&d ÞxaðøQ!ÂrT˜S-²±Á²YÝgËé§i—®"Áµ¢v“ÞPdÈíÈÅ:I‘™† cªYVRèGr‚K‹Xh‹ˆÝ ª®ãÔÄA’#úO²™Gâ]aá”agY.ë£ëbH1Ç \÷©0‘•ÈV'&§$T ÕJó=K= ŽƒõÀ!ü Û®ƒËš–5¬9çrmÿ_~~yJ‰Ë·íÜáøŽÀÕìÛá6þ#€L î{§ÂWÎ'žê4…£Lû©ªI³‰(“”Cç&ÚúšÍí1˜ðÜ–#-¤?àæè@! ZtÊã‰`‹Z)NjŠ#•ÀôrrkŽ¼\§àJ²5´ZÙƒE1í¯Ð .€ïïúa±«Oìá#R­9’,w³P;q.· ÜÜ‚(Äôܺã¸K[ƒfO–þ×0² ’m ú3èÀõÚây¸ßúÈ+⎴æ¬ Ž°U7”õ±MmÞÇ€8.9~2z'Xezw $~p=‚d ÂÜâÇ-í#`TGé?§ï»?j•A—Ú¦ÎK+yÌ–3'èM\ïÚˆB,—YKšl¾ZõrøRÍÙ>!ÂE*®béNÜ%Pa ÝJT ‡¢VGÂX"tŽ â2äJU‚(4%„ƒè¢$sX}â ðäÂýg£¡{è$i ŸcO]ØýêßaQZ¬}&¤ØæƎ ƒ2²\PS¢,T•©¼ªÍ§æðÁ£ÑÞ1ÂUPöj}Ø·è&lW¤ì°8ªÞH®×*ŠÁ Þ„ÖM À+»àÅsÆÞÂdȰ弆'`·&«,»<‹z«¯5µ€¯@¬#ºþTßçuKÅyŠÊDìûª"%ØAMì"Á:•rKÚ;_ܨ•À= î'á+ÎëZ®ÚŸ¿ØÉ‘I²M¼êÉwí¶övÃÂÑ»žëO¿„›¸QlN<"<|ãÐÇvÑlOà——¦K×fƒ2 ¸Œüåzª JãÙi'3¤ ™\¥:Ž©XcÙuùùµhÇÆ®”–­¤N³9Í™ðcÖD>ï?õ?Ú´¿ˆn'ûá&Ö;¤7™wƘ:z.× -Ì)ÔéÂd!Ò’À#-í@ Æ0ÍHîÑJŒà ȦޡÚüÂte± TV¬ÖªÚXVלhñ‹Œßé)ü+6›£ Ar'Vòdƒ¾W›¡íiÚ™‡ê6L~T[ǤCi·s3™„ë5I—PÀ‹.ŠÎ‹Ô²m;V8Ö|*‰Åuzh¤< $Ä’”î¤Ç¢CA uô±ÏÏ×ôœt4–50z¼g›qóyG5±… ˜›[k ³uÙZ`ÊÒgçƒvÐel¬m®3¶‚!PŸ^%k¢¾c£‡s¹ÍiߨõS³<Èy‹?b­v®ï«Òé{†„yð÷j]ë@c$¢TP\â ü)×È`ïÃ~7^ ´êhäÿù‚ŽƒÉ\L™²A,Ý€©Y`¡&ÏBͼÿKÍ£ÿO –’ƒB¾åÏ»9·Ø»Œ„ ȧ LZòŤûð••)fz™Y^iFáúÛ¶œ2x Þär>Ë€óX vVVjZvvà«R£ÈÃ]° !!7Æn£‹ûצSϼ„á­Ieq œï宯 O§VɯPÉh…ž­+ÊÕ`ö9Ž…ÀU…Ý«L]W›Qn÷èËáÛCq͇ۄˆø2ªTzÔò»ë®4„¬ªÙï2ÝEK:„ëu%|Åíh(ëÔÐé ]BäI‚=J¹³ú]:R¤._SЋü»ßÅ/œüâ{ à2]’«rMæG«XÉdnŽäª·@å+œÃÊU§:«ðúp#霯,±¬W““éþÍRÇÏÞB¹¥ŽûÇš¸Ú¤¢ÈtæónêJšk›jL=à è•·ÇÔSœGÝ5Kí8ý¨^Ä~ *R€ï(P¦lµ´LAž\o¡Àƒ¼¬©h„טØ^4FûQ]qAœ5ì»Ô#Ñ/H$ðŽ V/É¢,æ<(뢷4&6mÿš9îç¢1»7³$³DeL;ZK†ŠÞÖ-„lxèeÝO}ƒ‚¾ÁÑÚ[à2u5D•FŸ>„WÁ V[-Ë$kźFï‚XVÇÑÇh!òý´vëe'áÍݯàðÀY­]­ô!ÁÕýpUŽ´QyžžÞd`::ˆ=ü,À^Êyó 6Ó¢l­Z–ªNMS¸ùz%gPœgŠ4uZú\™“¥Í¢8o. ‹ìu ¾W;ªÏ7 äʼn±eàJk¯ aç›&Ë0óï[ÍpÆ[›Ñ·kñ3þwX"Ír7–g>§ð«'EJ‚JÅn‹++侄 ioÒ&b¥üFp£ÿ«‡•o™P7Np'2I°V¡p°¸W¿‰\Ÿ+ÓãFH\$!TŠ«Ðªš­†›Y#l5Ú̪fWCF• Zê"ÛÒÞMx72¸`«Úp“ß9´åÕ×Þùjt ¾€oÌ5hp¤)0"_»3»8È€*U&KÁñßšG;š€”H•s2?Âb³é£ÇMŒßÂÿécÒ.á‚·%¥ßa”¤"ò±º4,¤Ná{Ò’#¢½„o;guôqSZ»%Þ#ÁÝââotxE›ˆ|¢.Và¹ Ý Ñ¶§ëáfÈxÐz«SPÝS8QÐ0ùÈwpßÂpKÉ–´¢4 Ruœ"z%Šå­ƒñ’€ž*‹ugtl)ÙžQ¢0щt¢|ñ äÅ[ EYE ˆ*J Zrñ]{¥dUV²ÒÚ¡Ÿy%²|lþú’œ’Óx?!…!0Wø:WXÚ…Ç£_xå=Ú<³å3ß¹ãÉÓ„ Êgç”ä৩H†Ãx ŽÈäŽé˜"…‘tÌM)—(ú%ó˜$@¹[2™Qœ”W\†i^µé;¸è©-GDúŠËé—IRÒ¥vñi†>!‰iŽÂZ¸Ë€+k²JyÈ]â>Úf¡)þ‡v­>ò.?WPg6 +J 1z–øi¤?iVš¡çi›[cð0nOé5Ü[è!PÈ]1Y0ÚHºæÊ XôðÛç䫼L<²—Y,!õ`úŸ—ózð%$¨Uš xzÃý˜ó4Í'2ó”ZÙË}ÚƼ2CogC?¨&yuˆ)Zo¿*Œe•=u›·8Çx #N*ըݡ–@¨2Ó÷î3è#㋹l¶ZX¦ê½U®¿ø0‚<'^°n°aðøG¬R\¾Zµ9ùo6¿vÚr|¿Cro6÷€kÔPpç‰à¸ø§"¬JÔ–¯ËÉÉp|5:rì òÕª°¨À#ÂBküqk<ª>ÜuF}íöЖóì¥IœÖ~¹ÐÚskî·;®-DŒ/ö®ØoŠüûrçD¬Oß3wñ“=§?úê·G!ƒhÆñ|î½cÕAÀ•ÚâÄþ-îÃßYÙ3|Fp͇¥€3ð~«†ƒ.Ïîï¾~«×g·KÔ —Az&™îeðèuœþ²™°ˆë³¯#ËÈž •½´}þʼšÀ…VúK¦[ƒ{8ßÐŽ‚ë—鈋Þ[õ ²CÖw¿€Ä¥žÒî ‚“hbÚ£Ïb´IökÖøüýap?d>¾ëô wÌŒ·Ï™°ïö®`ÉÈ’¼âÜ\M¹®,7þŠBi˜ÐòJ4TŸœ*M•eúY\®ÞHnÌI.g)ú5©ÒX ÒU÷pä9“Ž‚påy.òÔ€Tl¸îüáEçCð˜ÿë>v;–p*P" “ì¬HçuýW[Ó×€»â²n“÷²u«„h7rf¥ÐsÉKðƒIš¾þã×NæÓ»þ©ü«Nt ,NÙШ •IýÓ5Xÿ$à®eX ¿ã^UYÕ©çëÑ„N—Ýs×¹ìߤ«D”Kt–·ßRYbpoÂíGOjºÏÏt× ƒ›à\ò™ÈƤJQ‰ _Ÿ9Ý~qîÓ——{øH‚ÑÒ˜„ÃÆ ^÷½þæ뀺Ñïã$ ŠFDDI÷ÄQrË;žñùXjé³ém^1Þ;?^8I$§ýÓ¿,èöªI8VRÊÛp=ª5úAÜMÅCð+ø»þÛÚѺц¶»Ã©¥¼É¾~Io2ÛÀæÇ›Y¦ðp<…sÞ,`ã¯Î>$º9áÌ:[ІGpÃÛ/IδwJcÃ4øŠ…^ýã$pósfÚŽ¶¡¦}àÎ÷­¿8ÀÙ¯W¿=y6¦òXSJ2ïÇÚອÕ{‹·€…àc¹Cô¡(Lj Î…É<ë?–Ê:á´æ°^¨1CçF0gÜ¡gtÙrÆÆwÞãn v—ïųÛfd ߇Û_´½¼rU88x³öî+á4}ºÐqñ¾¹±Q—“—“/¼u¬Ýle@B·´8ð}AprHÈÑ£á[pHãœwìôì;SÛß"àŒùä·GžµûådB.\>†³ÑAäƒÖ¢åèrƒŸ£EðÔí!}ßkaJ ­¤í¸uYƸ,ÿ,/‰SÌq¼Y(2!Ú.0¾ùüÅò¡–a]S«¹:‹²¦¾ò„ßfÂ}ô7\èÎ.¹­®ã^ªNš¨LOÄŠ`#RfgaSÈâ§çf4u¥É» ¼p,¢–Úº)I¢«Œ„UÅá|)K‰ 8÷`ìní¹!á@ÅðÜ x ùô¹T¡i=ÏxÖIfú¨º™Ù Óž½×P0}ú³òé3â$ëå| endstream endobj 141 0 obj 6608 endobj 52 0 obj <> endobj 51 0 obj <>stream xœeXyXS×¾=‘&9Úª-i$ÑÞzµÖ:S‡Vk{UêŒ(Î £ „2yÞ ’@˜gEq¬u*jжÚéöö^ûõyß>ÜÍ}ïíèí÷¾÷.çÎw²³÷Ù¿½Öú­ñÒ(‚Á`¼þqü¦MËbglÍÌNÏZ“Ÿ$Ì<~þGzƒ~cý‡ô!ª}ã%Ï?æ2ƒoL4FÒo¿ÏŽ‡†W‰CìmŒ=$’åe¦gäGOKˆßþÎŒ3ÿ÷IÌ¢E‹¢“e¿½"Uœ™ž=ߤ ‰²Ssò?ˆŽÅ£…xÙèt¡L”!ŽNJIIM m[’05+zU¦0S$:T=-öèwçÎÙ˜™,GÇÊNʉÞxhQôúèøÔt‰0)/úÅûÿû‚ÐÌ_¿L–s`Ãrù¡”±¢Ôiq+óÒ7‹3âWçgn‘l]³V*LÚ–â%bq‘±‡ñ×QkG݉ÐE —â_¢™éÌA–œõ-ûûo¤ltÔhÙ˜M/¿ô²ë•·^966nì¹qKÆ}=>üõW#_ÍmúkæÈ©‘2ÎrÎé×Ͻþ3WÁ-™0f” &\Ššµ;*õ-ï-žáÊqôyÐIÿ9Ä ß~“‹¬+F¿ä€"s¾!ÙÈ“m6·hIíf_‚«¥îŒXQÖ~ ?CžlœÈ?å•4x\u®* Ž§7ùÏ6T]vòìq4!˜ÜIOÀSàÆ»Œ%ª;³è«¼\ê±,A|­æ€ž¯€›ì.½ Ôƒªboððdò ˆBQv]ô|Z¤[g$Ð`ð¡ §Cß äc¢m¬qt½/0»;ÂOOáúŠ=ö20üy'ÑÒàÚ:4ȨPÊ„ÉÒ\º@¢Ö«€Š5%ÊrKH‰\.É«)l¾£ð¼» A ÂñMŸƒÓdK^}v¾B)Q–hB*A•Æ£Eà@Ú‡ Ñ›RHò”O¶ÀEJ@šY6›˜Î–nܦ5ÙT–"+)Çû·èúà³³‘°ážíË(Î7t"Í-ÈÍI“)Š_¯/)ñPÑO Àd&禫ÚYS1±STŸ²ný&4Šà3˜cq$h Ìó|û¬ÍgR`´m¦è7Þ=V|×[sbðògÏtÒïÕÈÔƃz!µ-br¾Qí°i'¦V(Ú{ª¼)(ò1q©44UÍßBíçð·¿s·Æ¥Hv2>³çö7ßõB5·tWd­_¯6YMfePY @GŠýEuÕ¡†“û:6¡é(MEsg^ØúÓÝ‹­÷/ ¥ÌqÃwAˆ1†ÿFÑ,ô݈v+­e¢5 ÖKä½Yi”YÍYi³ØÌ6ó›#$O8Y)Ý>Ü]Ni9h¥ÎWŽ¡Wò>éaYôXúâŽTl“*×0`ìÕn´‚ Ãçm ÃŽWyÙåúÄK¾À] ý}K$€xÛâü¤Ÿ;Xœ_a $¾‚cºÔ’JZ+-ß^s;Ø\ÞÖDr~jªóîžøóŠsˆ+@e˜&Ì‚C@iÎ3ˆÿ ØÐq¯ƒãæžäüzL^¿?a""–­Aã’$þÆòòSµ_|½îZßYò rÝ5ån\SÎO_te.‹ïOS™Ò݆p*yãhþâê¾!½ ¯^Œâô~ ¯p«Ïø¼}€„SYèêÉä yuŸÏü:ЮêË9#<¬jä™ÝÕEþŠÓ+-RÉtÅZ·†*6:ŒÀBê4FEžºäøAÁþBßfì¿ðÊP[ˆØ3FƒESMÏÆhxEÀô.>ÙihŠYПðÃk-—¨×»¿÷ȯ7,¨ ¸=Miñ˾½-•¶-5/{„ï6?9}›:Ú¼¥xZUHvŠ~= à ÷ñ~è0‚›°A£“R«÷–U´ÁqípÕøcõgá“‹·M“nÄ—³/Z=PT6cÑŽýè}žþ¸,H4-Dqh:Å)\Ñx}ðDÛÓAf‡U òIN¯((«?~îØsu)Í„—¹-V!H'9…hæd´tN¦¸ñè×g yã– ©¹«ªÉJŽž£ “­Ya´îV°L>-Hj«Ú ƒØÞy•‡Rh3-P°úÌÕªÊôòÈ^*z]¯Ž×ÿŽØÂ2ŒX_qÈ] Yôb”ô1+Yp º ×é¾Z–Âá9²^úi'À—"†£éTnÜÍ,`éZ£èÚQàÚWvÀ…·š‰Ð^”‡fApÖo_œxö=%¯ˆ™·9{ࣈu÷!¾| Ž}ð%uêôÕ¦àGp6¡•^øL«è˜^' :¾è§§qkY8€Ýîs7%Ð¥£?f žèmñLCŽf¯JhÃ;Iò³÷ȽÕÁ¡»T½ªÒ\Æœ —Àyö÷­X»;kñfªùi±›Ýæà[íL`·ðŸÿ;óÊd4[âP2a…‘Ûc­Ê›Ášœ‰’âv ·òÔ_s¸F5ߥ/>c!ÃbÔK¿^ËÀ()¼ÿÜØ8¡c*>­ó‚ßá/i£šœpzõßïƒoùdzv¢)(-BÓ_ØòàöбÏ>¨Ë™(NæþîîÐY@VW(ò……éÂl*-#U¶  x‚7n8í¹àŠèý0"N~û¼Á‰0µÅÿ¯ÁA7ŽÿÙ:ÔÿËí8 @’„ï#Ö3´J€Z,¸.³ÙïéÆ挪M|:½q=X‘„^Z½:nÓâìÉ€Ü[XÖàsÕ/Sp,½‚9¶¢ÕôÃ6XXßѫoFtÐÑÜïYóFÞ—DÜšøj½Ç[l/.vQN·Ý Üdµ,XP ågvˆN|wëopý1Áçð2Xî6&"XÍ0¦ëv? }^“Áb³ZL”Yg5–iEMmUeMWZÓ®])’=é‚ìéÞìä–!‹ù¢#邇[´í·8×bÀP¡¹¸Ù¨ö¡1#òd› Æçð¶Ø뽦bp”;JK;ÏÃ^½±Áz |> ö´žéj¾>!ÿ²ôy|u÷‰™õÔþ²Üð“þÚŸÃlÅ‚k…Í‹{Ð?øó—–1D9ÊBC#c¹và°9lŶRKÀDrþëï»혰ùÀGì9r­Î T |Áãí%¸NÓèI\Î?»ªÄ{2Ôû 3)I²P’ ÈTISß_\§0ÛкÁaM;ÃþŒ^ö,¶)¸C®#¥ý­pÚ׿…¾KÂI3þŠøÄ$Ç~ ˜:+Ø£-jY}!©¡ F{B;÷þ£„R%ïHõ‘Ò£ š'ÔŸÊ/h»ÀEp«álw]¥¯¢¡SYÆÛ²9¹0C·Àù§Êí¾=^#¶V,HdëÂnþ÷‹Ó›g¾¹½½nµuɆ”å€\¼çÓg?Ÿ†ï|ú˜êÿòÓ#w‹;V5=³¶0ùÓ“¸e ;áT.Ç.Eó˜VIÀí*e ÒÂõj‚–À¤G—/Ü?RpbÏ%*µOÑ ÉöêêŽs-i– ,Î!H1‹Xú"½¹€ÖQèÂß,ÉS:“–ïNü8«:ñxutG0äû²³öoûY!P°~÷Œ Xó°øAŠcÂjµFHÁë- \ ž£š®º êÈnQcÊÚkÐ[³ðz«ÉµY•bØdà+Øv€/{…»NŽ k‘)O—c³YŠŒ4iÄ‹c7œí;Üý鹇ƒW:°sô©Uf‹Ê¬ ¶¢ª]!PósƒŠÆ³/ Tå/dƒ~Š5Ãð,‚¾àî/– Ï͆VÞP°½¢³­½{Æ^ò§egÑÄçJpÜ貕JLn5еIl½PÙ8¬²:¬,–{c‰ÁÚAi±ÏÛÑSy×Mp<bÂi*§ïc!ñyÚùõ±ÔeÓÖí@¯)4v§˜ºeØi¦ÉºèáÃX:FÁ>X1¼cx:W锋åÚ\À×u±Ä³3X’Œy“Ž¶¢=H´ºyeßnêìŽ;¢Çà ø¼j¨ç4ÜÄ ôʯ;ɪR°Ëm>«´[Z ã!É2I¬E¯VK$©ê}x"îò»8Œ? 9Q½}Wo€ëࢨeo ×SàÚ›ïi¸3,öšÓðm xš^Êý€Õô›Ýî¾|¥Ød´ØôFAÊŽ ;³tyzƒ×Ƭv y—‹š¬:›Å¢ãë²õ@OJª'Û›~º*Pyv­W(€¯3–”‡µ˜z¿e>b¹Úž/×GsC0·ü{0²¸â,ƒ^«‘Ë•Z qÈð”û=U(.ö8JHÛîxïYS ¥– ç1ñq°Ð[Fén´’§Øl)™¶œìjy4 P•1õtW$ÍÏΪ*hn¨­mjÎoQ«²z¤³²žÀ×Gq†è :ƒËéíÆî&ŸUT 3I†@q~ ‰¬$Ë%œ4yÙªwü9—×Q^¯(XXYX¡ôèûvùrA"¹tËæåﯿýs‰½ÄîH™HŒ½”§¶¬4„ è77èNÊ­X‰ØCæõü£1?P1?è*pX»züè`W«J\-¨É+Ét¬ù—:¿£æ`/:?zÅ)¤“0£¶¯UaFÌî27UŸSá9æ2V<šcPì]ŽåÌM»vdMRëJýNàÀÿþ·Å¯J7ÄøEì#X0½&·Õ¥ÃÜÖcve¦¡?òd+ ™@F¦WvÜ>&@¶ 'Z± `š])ké« ý2((ò2Ãy;DÿÜÁn{ͬ$4»Ò|mA8ËÊGSFêÛÄŠ5&tzl¹]‰íübµ´`ŸYî= )ÚÄ»Èú¼-o nZV9´ž€ïa0|û"á¬c °â=7v¦UŽroÛ‹€tÉã(Åh ö%Cy8Ûü{ÂÇé)NÖ:L`<ý„Ó°'‚V‡ ²GÁºj¬÷æ"³DE¤ò4)EJ1 Å_£ 8ínÊˮϯÉJ²¶÷¥ß:Ûêj4¶…z«ïÿF³q>ÃË—/Ìpˆ^¸¡¿<Åé `—bÙA1pÙ›¥ZOjy|ù›ÅKœóxŽ‡Þ‹>XßyÓUêh9ÿœËkFŸ;D‹ðK@iic»Ýît9]ð øÞ} ®‘-’šl±RU réJA@éÆš3Pz/ >ãqn–Y‹&‹Uo`}°ÜÒ<ÓÜâsº®h¬%êI˜˜X5f±ù É ´Vµ•T±ÃTÃEŠ€…pÏäŠS¥âpZeŸ ›Ñ¢£ÐFê-«˜øéAiÛ¹Žæ¿\¨¼Ï³ØéÝ!zê#¸ãN¨)pW©4š úl¡ê9—nOè8üS\J—Ú¯¡˜·Ñ`±hvë»rªq8à¡Ùhz§Á•G’¯Ýêi‡¯>H?´¨€£0§\ÝÔ]_õÃÝç9iN™‡­5bÞۉƬZNRâLyΤŒüæ“ŽüÖs…ê¾Ô×ÖöêP~§¥a0lT°zM•ZP Æ£dDóÖЛlÀ͇+J¯z0ÌŒ v¿Áa©F¯}3äU±èÑ4 6ÊkíÏQntÿqŽ‚ F ¯Ä¼ÔªõZ‹ùPz\‰·kr—ºœw5v§£ÏݙטY(5(Å‚]YÉ»W¡Qõ÷ý ŠìȯÏܸ·Â9‚K0ÕâØ¢.0¿¯ä+êÙ >ƒR“?7q¨üE­jyu Îów>×ÿÍåþÃØC{t ]»©¨pkœ:sööéÁ3'šYæÕjLVµIFmFr]š¹hùÙŠ†¾íwÏ \eù󣫥_=Í ßDÀQÃQÜO¬n Em”X VƒÍd5ðÐ#V¦™?”ÝgÀÅ0ÆÜÚuæã•Û“Ѩ‚ÿ 1^vêÒë±e„)ÈÉíi<¸mÍŽè¸ TZjbNEBeYíå–_Žß¥N õ9õùòÞ™[C§€Jyí"÷Ã;òpœ¼u´çª€óìZÏî•ÛòR·äPa¹†[¯2`,á¢C¬¢õL(bù®†%Á‚“ôË Œ“O ï^D­œ 'Õ~ÖøõuHþ0'8‰„Q±E"½Ž¢'_YúäXgyû9Ӫطsí†x~ìƹK䤌 O Ïá^éÚõþ‡y³³s¨ÜÜd9ëÓÎ>¹ÛüEÏ ª®¾Õ‡i€K‰õí«§Üì¼\aN}^S[C]KknC6…_T# FDo£8ßüý)Wøb\s[=—‡Çý þ™Ë¹)çee׉[ÂÛòê…a›üÃÜãôØæW°v”Öx•%õ”£Äá+&N¦N¿Ã \|§µØ¬Àf,QÆȬ@oÕXùJö€£ÖîW)­Zœ #ž:­@»Ä@…h÷éº; øŸßFÐS Åï,P%`ÓïbÁ­ø G·7øYqwnFªV‘-ØqH”™[màu]ïi¾ ÈÛ¶¯,°U”8aßú5+QÊçÉ!dŸ<¹'|XôüLÉp>ý1÷ÑÉ“ÿ¸Š"·.÷wÀÁo‡ÿ€;ÆÍ8ÅrÓU_ð•f8å$Œh{ØÖw}Påç¡ hÌŽ5I“s×k6€?Ê—Ö¬ªHô ;×TºÃ ÅýÝ« z'4rg²àXz53™5²`$Vú1úY»Ð*æCÖI¸‚ù”Uq‰VL@N€·™NÖ tù¯·€‰7#šÑÇ\ø*$Î^ë…Œ¦åWÁ]0 ¿VtY>¨ìÜ÷E¡‰wx±1x N&Z¸3:gmvÒÆu>åsê§n3à¼ý#ÊYµ·™ÈËšŒr˜Jö/íêÎœ¶Üê`‰‹ß‰)•Tçòª”¬äb¹BœÑ-¹A>|λ’>ñ•Ö‘X:ú„7N¢W„àÞ«ṽ—k½¯¼Bÿ%î M endstream endobj 142 0 obj 6195 endobj 49 0 obj <> endobj 48 0 obj <>stream xœ…YXWׄ) Ae@1;X;bǨ(‚( °E@QDPº”]@†ÎÒQÁ6*Øb-60&“˜ãÇQcÎä»›ÿùï.ÈŽùÌ÷?83ç¶sÞóž÷\“.„‘‘‘…»ÇŒ¹s]†Í ‹ŠŒHttнí'ÙI}»H#Töçæ??#wöýx§…ôIOhèá=c#£ÍE3ÃÂc"‚×®‹´â³`±ý°aà o&Mšdëóî‹­Kàæàµmãl  Üéd;[‡„¯±]¾n³íꀀÀÝ0ßÕ!l]ƒC‚ÃÃöØ™io;fôh¯àPÿ¨Í¶žaÃl=l® YñÞK‚Hšáá³qÍϱaK½f†.›ç²)È{VÄÚù®›×-p‹ ^8;j‘ûŸ­!«}£CýŸ0bÒÈÉ£œF;|2Ænê±öãŒês‚Aô'–ób1’@,'¼‰YÄdb1˜O¸NÄhb±€p#ˆÁÄBb61†°#î„#1„ð!æc {—G %<ˆñÄ“˜AL –^ÄLb"aEXãeúÝ ¢Ñ—èIX ‚%‚'ºÑ°$fâ8&xòF³Œîuqïò½ñJãoM&~&ȹäaj"u–îC¯¦O0SÚµ{×M]Ûºùw{iZefavó#Ïn˜›_ëÞ§ûíKz|ÑÓª§Ï_-¼,[üÆnc›{…pÝ9%÷«e„åqËV~VÛ¬ÎZ½´v°ÞeýKï!½‹{ŸîcÖgqŸÃ}þmúïxs©U¥(Ѻ‹°W4†­’†ûU©.(+M)ˆáQ“¢LLP++ùi£†ž¤Å°’ªTª”)1 4í•¢hýt`'B£h$Moî²#§ÁhÃÔAZ*iH´JöÙŒBnÚ(2Döj˜aĪ ìHÐPñ"‡¶Q@@#¹ƒÔHâ…‘—è^’™hÁ®‚zKv§ D"V6U‚aª9¨¥J²LvÒ.Ë& COÐDxB~&³  å^Ä[kF¶Ÿø©.Z”¼òahÅÞ'i7bïwÚ³7êÐS?*ºýYÕa^?ȧŠEÅ;ŠöÐîšýEGmŽ UõÖ=[J#„P Á´áF†ÁP@}ívyŒçÚè¹óìÛ:ÿlj’‘\ewõ?x/ ÒzÉŒc¿>ìï£ñ²A}† G֨ׯ£Àêæͪúó|fG¥PÂ¥¨“•ÛSS‹—{nž!0ÈhjËïÐåA tyrwµo.Ÿ›¯,˜Òu%ÿŒf4í¡V$Ò=‘7HÄaÑí²,%»ÍØච@+Ñ(XIžü°ëq<ÝP"òF+ Ì]s)˜ëaZOzÊ,¬ ±ZÙ¹­«¢dŽ¡ý |¼% µQβ‘ö2JQ{ Ov‰Ú´‘C ö{´QÁï.ÒÛGóÎRT!Žè-ÙHµã"N„@Ñè‘.²ðzˆœlèeêYóí'·V™PË_>¸÷ˆpžyì|m¨Ë ¨¢0ª8„‰ôý ~ó=½>Ï#¼µ=&öôU¡Ny0úHÔ®uÂZÆsáR  Þ¡ÒH-ÂaÑXÚˆñˆ^ãì-H)ÓEPñäÒ¨ ='×JÝZéÎ4^ˆji¸ÏÉÃP2Â>ì†÷þ¹4“Cì`;Ôõl,X¼ú ̵û õâýM~ìÔÈ„ÉL|ôªí»Goxýø^‰`-êÐø'NOs+6^ʔڸᆲg›PµìîüCÓ1ìL‡êVèÞ:L[®Ôß9ͳñc^ÐllgPØx Or…Fáh=Çžm{è4ÀÎi²½Ý¼ð7~ã hŒÅÛn\`'YM•––$ÆêðÖ™ˆÇ)d¶¢á°•<*C¤ ³Õ:Dî$QpYælûC0Õ¹&õmìïí–’¦Ž6LgoX°Y»†B—¤,²ß{A–Cj(UQÔ1rº´†‚KÚ,ÌCíaª ›¸^—Þ8*Vì#)BÊåØÖ†óªÝmf Þ›ü–¯Z6Kðb&ÒÈ°+¡ïõ«{Ï*öV—TELqjá6eúöT¥Âgî’M®ØåÝì^ƒ—ÓŸ[Áø§o}½rYq©%S¦Ëv0¡ÙGÙH·s-Œá¡Žö0Ǽ'áÍ<ƒgÃ)ö…!¸Ïš´•8`× §ó1¸Žm±Çžlt¿úµÀ@÷¿€)˜Žx†zL[îê‹?¦Ùp çÚ¾v:Òiºý)-/~ý¦å·vtÁ †âBSË9¡1C“phíwNç‡á#õ²‰>B– ›g`vº¾Ó[Zúö4%¿fÃŒ(O‚Óí„ßi,¥+r•¿Ü»Ô*´ ÍÞå£m7C8+E8鲄9º$IHPéj]?t+—†GÒ*òz…éèö¬Ò( ìÊ Ñ#í*Ò[Rt¤P>…ÆêSè>‡0úš„&þ <| &`ã`*"ÀõéÌ/ˆBÑÇÃHDlÁö9þCó2RƒEã7"'GN8\ž°?†~ƒqiä(Ü`P§cK) ÐM‘øúuÇý÷Ì|™t?Gûa 4”ú{p;ó¶UZ O9öÑÍ‹j§Ú ÃG#Sdúbtx¡öf#ríiyÙk†0·úH•M²7%&ÑÈí ®í¡>¶Cì>iyñâaóKþyÁ`œÃ=±ßªqƒù²ìœ•:×Ps×±ŒŒ}Š3*AȘuaI‘ª`[¿!ßµ P`æúÎའ›zŠžÚË|uÇeÈžvpær:Û&A‡KP?5?>ñ^?)ßKZŸ÷ÅÅ»:€°€M Óó77º¹Î\0–G}:k“ªßE ¼Ä ñq+Λ¿ðB˜áùø¬ ¤ì‡A Íþ/4Úë JËô¼Ö™þ‡½°I¾0V&ÎLÑ-ˆ£ßù5D´ÀjÏŠ½ Yº²ÀP±É©Û‹R+øôt˜á nc–”ê)Ó 6Qì‘6èR¿»Áf—P•TY ÌÎ,Ð9^]¢VÆ–ñ›vE©7 K„ea#'0ìíWÿÁ"üôLð#Ó-?ßÚ6ˆ91ˆy>È{Mn6ðˆ£Ý|¹)ðæ ¦¨s‘Šú# ÛZ{°ô€ØO3¤‰þXaâ›r{qÃjúô‘#§cÊhnùU+D‹ñ¢ô­n'8!­Øh¸„¬È} ½˜È`MѬp†¾ËÑ~OP "s”ié*AÙ{›:¥8''++Wq²äVq­°G(ÏØ—Ì° Éû‹3ÊmN|y ª$E”žž™‘·lUn…ÔìÍj†.ÌÝh³EˆÛªj:n&áþÿLï@‹‘-ÐKÉN¨t A•„ÄN¨À-œ‰2œøþNþ†Ù8ê=ù¸µÊÅ- Vì@ÉEâ8öÚu~;ØØÏX>'¤2´&†¯‰­Q6§~¡Ú§Ü›°/¾"Bˆd|ÝlÁx×#|Íz”¦ª·ág ù‰øY‡oü¬‘Åô‰ s±70ñ“ß]xP]²“ß°3¨Ø«ÀQ­ÊŽ*cX-%Iå}N^8Øüà³~yŠì¸eI‡½M³u415)V‘Þn½ØÐ9kÎSïëŒ&­feûS‘²B¯ßÝ ©âÒ¦ë5„ÞÇ…]ÊÝÑ{¶–nÒKo?Z.B5êÎ!9Ô#÷Ë#½VGz-Q@QÇúA"ºõô‘Êåð2ÖòyŠÆ3 BM†~aG?ØxF¸Á<™x«¾¬ä–©†¡Ó!HG-±0‚¾wËgÞ\§Åö<¢Ú#" ©‚®úÀ#ü\¹2ÃÆ‘¯l^þÂMëRã’9Ðñ;èËߧ…Ë5×O‰G4`gü$ÜóÏ]’›Ÿ*Sþ¿iT… z^I Ù?û-ªt·qæGú­^º<ÄYpaœi4æí ˜øåÍÊºË pn¯ƒðF‹*£WØ1^˜vÀ”:Ó}„vQÓ¯.ÿõ{ Žî/J)JNËÈLKUDºÄ.×U‡ÎóPá2qÞ)w_¿±§ËøÜÏᾎÛe‡í†ž¢±²ç¿dà+™QlÛvXÃy¸ü¦Ý›URI»'cNÁ11ê”k!Í—Ê8v¯¸Ú¯ÒÛ¦ÿ”ÙŽ«5‡"ùÚ¨ÃÛîl»»m§ª:®&¶bƒ°Žqžå3RÁÎ-8ŸÏ¸™Y®*L} Crî§Ù½+ÄË·mÀì‡;­ç#OT󡚰©¥žE…›*"*j„ÌÍ«g+X‹‡ÂU¿Üy:iö.¯ U"š–·÷EØ…‹;& ç#Ãp?CÕ[ù^³ƒÌdðCh76}ø+n€::Ù"ÝŒ¶+Ü‘ì¦Þ)ÿ§ú"·OôeÅFJs-[(6Ò@ÕÑÁ-™!Úz¶¡•Q‹æy…Θ%kŽŸãá‹á2ò§|¾øÛ›Wkš¾P°‘î'þ«ê¥Nb““1ºšE œÉ3è8uRIY~!–e”v¢ n¿NÚ¨Róñ§Ÿí¾¤á€—åÏ=yþh£/{¾'ƒ/EQ2%Ó.“uÀô„Ù\ã1˜\É°w¸~Z«p«jEž–…ÀÒ`½‹BÎÈŽ”L‡Ól›¡î?LJ•—üÍ ˜ÝAë*½fÔu'éøLuí zj~´¾;IU%è4£Ÿ)‡Y³ǸÞùY?7¿×ÃĤtXÕa+Dý0H0ùñG °¥>U¸ 0’<-¿“ÌH͇»©s”+º? É%Ô8T8î“ŸØPC=Ñš‘ç©Ÿ ä*!ÏuÄEƒã2O—6‘ù¯«Vó_ÒûJ'*]Þõ£—ßõ£,_Pï7˜PEÝuûldÐœÄèEŠ¤t•RHf’Ô)EÙ¹ºÒÿ°º&ÿ°ÀÜ?·~ïB{—‡ä­ÄüÙsœ÷XÜËN»¶øù+{/^U°ñ³iö,˜˜ÌöðÙ삩˯î³k÷N¾=uF•r˜whw˜”‰ÏSey‘‚@ICÝš ÅAé8ËC ùh£È yIQä×2£a†˜ `…VÓye!Œƒ à@|ø¦å …>F–¨X’¾­) `r@©)2Ïö6ÌçFa”ÚÃ(dOÎùð]L …<ÀU~M&´­9Su?Vì-0Á4íL±-ÈÞªCO17w¼©Ð]yur[ŒƒsôâÁ=õSw`]nË@ªÿx©¶‡§þÀú@œ­ï}¬§.¯8;ßý–¥Š¨3v¯V c‚—3ì­Ïè¿]Xtvµ'qW«l¬a[ÚMþæÅSŠ=9ëô•àû˜Ì[Û 'ôÞŠÌnpYÊÃ~\ÑzîåÃÉì'O:dÊã¶ÎËŠv˜[^£€–‚‰v yúÃa‡,pCe÷°Ôm82’ú’ž2Ñö](…“Ïe %krvPWÚ1/Â9ܪÊ0SÓõ´0 Ò¸LMæA-\¯ø²æÔÙ–oN?4BeFQZaZnfžÀª‹5kËWÍ™±Ò—wöX7N@ ƒf~‡Ì¡[ëƒïx5íÉhŸ5“üù>\õ©âÊåßyD`î\tŸ2n»³Û’†'á|†ZÈRífðF2«$QÏÖ§tåI:Á¡±Ú¢ÌôL•Ñ§XqQ^^yž&Håä m×i†ÞºNÅèbŘb¶C1×éí`Ù­ô`ªý´ÁºëÖ9}ÌX †¿¸¬è¬x!E˜ëöé²éSVL¢…˜œä¼Ô¼ô¬4IJMIŠ>wòÆ=ŸóÍ×ê€a`æD0G݆NˆA&<»Ûtü±¨P5q›?MŠ‰Û°vÍ– ™µàæ7?\¼ÙüÕy¿ ûøœ!3?RwÖø*#8 T»ñ_D«­9z$´&€OÖï³Jêû_m É$ t£áÃþ#GB÷w –¶üù—[˜•+ä2EÉêää´ô¥}û—Gº23MHïŒÕSQ^nY¾ýÓC‡©^m- âf¡ìó lWšX^Z˜¯)RÀ ¨$Qoê Ö ÿ¸(nŸÎèÝŠ®o8pœ2FÆÓvXû=@ƒñ `Œâ%~Hã„ë•_Õ6ӜNuÑ»‚kWVº s™1´07Æ-teTppôjœÁš¨ºÐƘ¯„ëÌOíåÝ×u\Ô%‰CžóãÒÒTB>Y²:»0s1XŸ µ¥ˆ§ zäž,kxé+Ý®qWÿ£Fƒ{Nj¼e¨ñÆ]˜É?}j/<‡p×üJ Ò÷ÍÝE.‡¾xæÚå`Øï¡|TµÿrŸgãÙ{- [¤ˆÞœ*Ä0)¸dçç—å*ʯ|Ùð•À<¸ååê6b’P9foKŠ¯ úZtKñ5˜pþ[ˆt¡Üuœvħå¤eg½U‚*=Cµ=Ãz{”!(sUê4´Ôá_)iéi¸}Ò³2²3²2¬sTéùBŽ›—#‡xkݯKsðÂÉ‚R ®‚0ðЀ¯¹;H\„¡H]œ›™½=w…!¯„?„?¼¹ æÙyYنŸ÷U´S}/ÞâØUc˜˜Á'ê5M¦·†Éÿ£—^Š”–µß¿+&P(ZkM®€jZ4AñÀ[²½ÕúõUc˜‚·˜”œ’”žµ=;¿ƒzÖÚé®ólC¸"óíi™Û…tFO$û*w¡Ë1è*¼^¯ÿÝ L"¦¨“¦"°8"}.ÂN °ÒT2­Ç}HbaJq^^v~‰âÄ®SÅÇæÉ%Ï1ýgÏ´Ÿï³ûÔr^Yž­ÂÔ‘’’´­,þàþÜúsqŸã†ÖôûŸÁL¦?ôiPÊ–%<,£Í·VIãªpTUEì&šž43Í>"ˆÿ`*ž endstream endobj 143 0 obj 5268 endobj 76 0 obj <> endobj 75 0 obj <>stream xœu’}leÇŸëËsLÄ6ͧ½sfH1d›1Ý[ ã¥s( ©zé*ÝZÛkW»i×â!„¶cmXÛ™± â"ê“¢™1&Ëb„lJ5 aq†?HLŒáwðlÆkTþ௻üîó<ß—ß1H£B Ãè[vµ¾jk«¶zE¿[ðX¦¼\ÁÈO«ägÔ´‚¦ïî|£¿»¨‡#OBð ð®Cj† ±z}!¿ÛÕÕËoè´½n®®ÞXšÔÖÕÕñB÷¿ðMBÀíêá×+/‡××-ôô6ðV…öxÜy—'äë ð§SpŽíux„C|‹Ûãöù¼‡ù V3¿©¦¦v§»û€àÛ½=^~o\¢Çáhˆb·ïÛÝÜñZ'BÏ¡zT‹Ö# Ú‚¶"’iPÝfÞ`~Q}¨ZT·Þ}w­|K"& æw—È1¢†uÄ؉CÑØ@$Ëp0‹ÿÌÏ_¿òÖW/ãfÏO^ft׿ÁDO• o—ELàŒØÆ^ýξ§}ç›[9ú<¦g43;'MÅÎ/ˆuI.]{Ǿ&u⢺,úÙŸ!n„&×NàÓ§©Ñ÷ýUáàªF–ûS3í£¡Oû9Î$ãéT4⨺äbC+×Rw%[²¢ÄV‚{UlŽßK¬†:¡þ#ó涟žåhì¡dÿ/#‚3#ÅÛ‚5  WâýöCGk‹ÕfáèSø~§×sÿ½"QEn“>RnXQ„”†ªì8¦SñdÆål&–ˆÄ¢!“VÀþ…KæJn¹‘}„ʼ,øÁt ½aV‘N%oçô ]„/ˆx±Ü —÷Èi£a’8ì™Ý•/·mvdŸörçÄÏžŸí;$ué›;_4Új¤Æ™£—?8=œt ŽjØÖ>f “ûɬ¾Ên,ÜšévNpÝYoâ•Tûˆ?ñΘ,rVúDwyîëk&ƒþWiÎ~b×±p|(%é ṿKÙƒìji+¹¿£<Ô+‹É£,Býv6œ|o4}2‘5^ÞOqÉÄUhXµm\¬B&Ìy¢–ÈYãTHThÆÁ¡áHñ`ž.áÚææÍ›Z–L°”gK?˜²Žè=jJ¡(¾a-h+$»¶/'oÉ>—ËáéÇÈšé²2Rö8Bÿ$oa endstream endobj 144 0 obj 923 endobj 63 0 obj <> endobj 62 0 obj <>stream xœeV{TSg¶?1’sK-™SA0'Z¡88>ªÕ2ÖêHm}¨ÔF$@ !!A^ ûñ~C@ÀBD AP‹S´×Úz«¶µ3SÛ©¶Þ{Û{¹ûлÖý«kf­ùï¬óíï±û÷ûí- æΡ{èHDdøÎàH•FiøÝ6­Z‘·.Þ½°”÷ðþsø%Bü&þá—Ç¿DzØü_Øã ÷^‚¦!g!% %-¡Z]–^•˜& zoÿ¡ÁÁ+ÿñgmHHˆ46ë×éÛJƒ*!EH>Ò•j­N£LIÛ$ %Ñjµ*Nš ÎÒ%¤r…B©po;(W+“¥ï¨Ô*N›. ]!}mÍšµá*Mì ƒt¿V#O‘†kC¤{¤aJ…ê„æ_(ŠòÏJ‰Ó*BuÊT}‚ašêDä{j¹&vÕÚ×Ö­¢ŽR{©·©j;µœÚG½Cí§P;¨Hjõµ‹:H½Nm Â¨mT8J½HySbê7K½L-!èQs©Á ‚hAÇœ 9-ÂÂò¹‚¹rNQˆ(Kô ½. ÿÎ3×çeÌûbÞßçožßá¹Ì3Õó“_r¼øb,ÿÿÆ*@à)äÓx9‹ƒ "×™úBd@¦3f³þ]é aWBÕ¾¨±¾ÆQj)ñ±ã2m+®,®4—¡ÁÍrX€¯ødÌ>’šœ†|ÍÕ5%¨´¤Œ+©(©@åÌ9ƒU¯KUÊú“><®¾µUÒj³ö÷ü+ø¥>Í—kk»Ê;íÅ#;ï}'Áî=H€[$„D÷³D…5ùHÎàaÉ ÌÇÍŒŠìt|…± õ2`¥QyUmm #~hk³×Ûüzšu8|ŠFñy'U§I°ÑN+ÊòëÑeÊéo^Ù+ÓFÄKă÷ÉŹwxß.‚ÃR!¿l¼<571ë#ƒÿÿtß³4˜*¹ 3A^rôlZ/b.·Û/Nû¿º/Ç’¿Á‡7º>Ÿà²Îzhs»øÍî_…µðªÊy ‹ÅAË°?~åÇå°ØgÏI’Òàç˜åJÔìDK$~¯Ê8´/"ã*ÂÛgÇ&9‚Hî6~þ x×î 6ºA'yìPƒ£b²ŠçLV{ØhYY^I¿‡“ ôS5…HÆàÝtÌÆ"C ž"Åœxû?úÛ¸Ó2:,ÙEÃK,*ÊÏ6æe¤¥›N æ þ ¶ã愳ˠläðiÚk*>óÊÔ<'Id»p*V²aɆ£™)Ƥ"-Ú‰öô¤Œ¥ŒçÞC?1wæÀ‚aW–Ò%q)lI=[äéD¹‰&S&2£œòµö¨º(ò (¼¯Â18^Å÷ÙÍæÞë\w[›upTãð!ycykºÞ¼ÎÏÿðáj-{ýjÝ|˜>C‹ÃQl9ª€» ÐÞJ‡—e[Ñ–ÒWŽµç æ~õœ`Çmý #Òö©9qø]ºÓ,ªª±Ô70â mV[}›ß˜}/^„j#ö'¥Øúr88=Ã{°·Öw ø@‚XÜQuV R ”³é=YÝÎÓw¨ý9g8¹/é¢ÌI²{icÄ_ÃÂG#ÝO?æ Ø kÙ2Xp¶u¢–“ÕêŠÌRméa&/¦g¶ðûk|@7©t Iw¦Ò?þ–ç °ó.##уÕNËjÌ5¨ŸáŸäЛv© _üòêeÒ%‚A0Ücé¿ÄaŽ†Csóãõé*Ä„©?&”óëþôVGr‡-ØÖÚ ¬Þ×Ü7Ý…7°ûˆþ‹êòPÜŒÐbóMÑD;-v:¼ÜØ€&ØGuºœÕ5…'ë$-º&s;bzÛ;/râÞA•óØ¥nÇ1‰øî×´Û\b»Á <îõ¸¹Ë}û&,ð‹ÿr‘ø¿)>_ÆŽã—iñ3Ê­­ŒóÞw®T5$Ù´\›¡%o8ãM]œB±g³n§1â¿™ö˜“ô±‹÷ÝW7üþÛ±ÿz6 Ù%Ú”QÕùAg[?7øþ0rTž·ú’ãÛm—Æ£~ãÚNæ‘¿6}%G\kÏN’E¦­“ÙZ«ê:müAD^°‘7³Ã-ÊU«2ŽEe]xúCKï0‘Ÿoîyþ § ô'<ÂSø’…€tQNÑ)#*Bù¥'+’êÒʉtÖì Û¸ó’ìçîM§%3 Mêñí²ÁÇé-qˆêZ+«jPª>S{ºÃ8nêDÌ÷·&ÿú™Ât™{÷œÖÎ3ÎNG_{‡)½MÒšQ—ÕÍ8DD~ÈÁÿßy½Ãû[ˆݰ…XâT´ƒÍBy•ù X}>7[ Žs–~4Hìè [x7ñ5|_/úüTc e¦Ãi´-?³™ÑÃ÷zsm~úŒÃ4Äáó¹C4½›¿Ç¢Êò¦²JrHm¥¥Âá÷¤7fÙîEr:—š­*Üò>Õ´|cü ~Œ'„ ™ßÁf½(üõ¸ã»"Ý~HïrÅݽÓÿÁ×—$úº åÉÜtä«55÷sp퇲¿k†w÷aµ÷¬&â'ä{ 7ù"‰ªÍ5f;K¾Â™‰¯ÀN'VQÃ/¤·C6+þ9&1Q~Ü™40pÞ9àRõÄÌåÇj/±{ü£u<Ëc]Möò‰KfNV—Œ.%$v10ezôt½Å0ø-LJJ7iýbs¬W9x‚# ô¥‚j³»ÛTÐëFýi¬Ç2:AÓkj5rLyZ ‡ B¨„y,úƒÉôz!ÁuÊA¯¯4Õ¢ o§áÅÓc²fìÉœ™ÇôˆŠ±Ì㜨<dž`a93mŸ±Ö‘)Cð5¬ƒûÂ)!‹E7-·kÖéé/Š¬hƒ'htàìpü&øKà1ú+Ûšëk-åWJIè÷zúÓÂú[ÏA=ïÎmvY-NÄLví K¢Ùµ[®ëºÂñu(Ë#ü| Ö°2¥âxÔ…øá+}½CÃʋLjJŠ dííß‘€ HŸN½Íâ ,ðH¥kʪËÊJ;jU ˆqÔ8ÆM³4 ÉÈzŸ1ðžvzMivzÈðw²ÝŒ@àˇHÀ_Èë!5ˆRBE¤û‹ˆU­úò~ÏôÀ÷ßz€©#Q ‰…"C¥ÝÊtŠº&{;¯¡äÌlK¨O¯Ö¢4™|ôðæD9é›k˜4~== 3cÔ(ÿÉ#o°BàV-ÿe‚·²}9mcˆ¹u1nÏÎÄÄ•.›þSŠ3û‚ŠßíJ9{Jx›HAàPŽ+¥‡K·g×ÇeĹ}±åÜÍÅß„_ Úzdy¤¤Õè¾Ya!ùµVo(ü ¼âæý¨fùí›èˆ·ðoð¦«÷®ôÅ´øg(ÁË!–ß¡Hüt¿ò2VŠ@ £xÔYÁG|!ˆðü !|‡Xè¹@ìï‹~‹ÿóÇÂKE¹¾ßiÇ÷£Ìèèiºúâ$1Ýš†TÄ$¤êN$~!0ï'Xú|÷WXÐÅ)ëÔå!m|¼2¬¼Ü ‡¬"ç|z: €Ô¶àŠúªü[e endstream endobj 145 0 obj 3117 endobj 117 0 obj <> endobj 116 0 obj <>stream xœe]L[eÇÏ¡kÏ«0mNHÜlOta]ðƒšáÖ¨ Î!Ÿ]»P =кSZ9@-°¶èK?øëJë80VÀˆn!2—x1cÌâÇÅ£ñ¯»]<^.<-1^xñ&oÞç÷>ÏóûÓÔž<Š¦iöeë©ÓÖ×Ë,.7/>ù’GpŽVd œ¼Ÿ–äɪÈóäí_·-ê¹mŸ&ŠapôQ*šGS•¯¿ÓÕîìâŒ'l‡ËÊžøïÅd6›¹ÿ¿®Š]í\©réá×Íwt=ÇU*´ ¸Z¹vÁïuŠœÝáàÙoV»ÀŸáŽ»—×ëéጕ‡¹gÊËM5.wK·È5xÜö®Æc檹7x‡«ÛýÿEQŒ‡ïtZÜ&Šª£ŽSÔkTUCi)¤ØS{¨Ô ]LŸ£ïæämn÷Ê#g—ä–h ‡À‡T“Ý,Ñ#Èã„`ÿzàÊÖ0*°_§,äyÊg«¯ó} ¥P5»qÛP(×½ µËpd‰–K¡˜m}S𿃸c¶çšÿê@fxA\3ôsÿ3+ï®6§-‘â£FRJJï—Aѽõ«¿k/¨ILl f?]Ç‹8Õ7!Äßx"§P?y„Q¦`I6IiíW`(ÑmB‡lgI½¨YšàVDn0¸åƒÐÛH„”ÄÔÄ‚3ø6‚zfcq-319Ø7­Oy጖W ºå/\™¦Ó¼÷Õ&½nó¾Òÿ¦Ò_{^‘蛊³ *plc‰EÔ\à´3Î`û@ø­°2bHbÚâÁ^Ffpl|jjòÒœt~£kIo£œcp[ Ï5¬ A‰iø3£Ì/Ö[fk›¯Þ¦‡O˜Â­§ñüV~š†NxVcð‹_ …*Q'lÍ3GÆBSøG$K ìÞhN’|tEó!4«wþÖŒfõMò7®CQ íHJ³ïsí’öÖ®@ö”èÖ¡5›T£¨ù|h:¨hä’ í&5(1Îxè^ÉiŒ]LÍL!ݽ‹'Ç“ûW]µ9‘–P mD Sœwáx¾”THŒVb]µ‡‚| KŒ#:×ÄrÎ |× ›ÞýSªÆÕ¸ÙË×"ÝúJì#ÊÒ ¿)ì£ ¾ÛªbIœÐê÷˜ÉèD4¹<5?>ƒÑütw“a‡e°Ù×kü‰r¾Ä”Gzø'$ßée }iÙž[Z“y¸üL¦ ¸¹‚½õ!çÀÉ endstream endobj 146 0 obj 946 endobj 15 0 obj <>/FontBBox[0 -37 97 118]/FontMatrix[1 0 0 1 0 0]/FirstChar 0/LastChar 38/Widths[ 0 0 0 0 0 0 0 76 0 66 70 0 80 0 113 0 83 0 81 85 0 88 33 69 0 46 107 0 0 142 82 84 89 50 117 72 74 0 93] >> endobj 28 0 obj <> endobj 77 0 obj <> endobj 25 0 obj <> endobj 64 0 obj <> endobj 22 0 obj <> endobj 19 0 obj <> endobj 13 0 obj <> endobj 10 0 obj <> endobj 53 0 obj <> endobj 50 0 obj <> endobj 42 0 obj <> endobj 39 0 obj <> endobj 118 0 obj <> endobj 36 0 obj <> endobj 32 0 obj <> endobj 14 0 obj <> endobj 2 0 obj <>endobj xref 0 147 0000000000 65535 f 0000040470 00000 n 0000120769 00000 n 0000040345 00000 n 0000040518 00000 n 0000038826 00000 n 0000000015 00000 n 0000003662 00000 n 0000048862 00000 n 0000048607 00000 n 0000111058 00000 n 0000047153 00000 n 0000046903 00000 n 0000109868 00000 n 0000120568 00000 n 0000102014 00000 n 0000040587 00000 n 0000060780 00000 n 0000060546 00000 n 0000108676 00000 n 0000056120 00000 n 0000055788 00000 n 0000107485 00000 n 0000051542 00000 n 0000051222 00000 n 0000105095 00000 n 0000063597 00000 n 0000063031 00000 n 0000102720 00000 n 0000040811 00000 n 0000062144 00000 n 0000061896 00000 n 0000119377 00000 n 0000041016 00000 n 0000076707 00000 n 0000076267 00000 n 0000118186 00000 n 0000075380 00000 n 0000075132 00000 n 0000115797 00000 n 0000072188 00000 n 0000071885 00000 n 0000114616 00000 n 0000041224 00000 n 0000041254 00000 n 0000038994 00000 n 0000003682 00000 n 0000006404 00000 n 0000090552 00000 n 0000090116 00000 n 0000113432 00000 n 0000083812 00000 n 0000083424 00000 n 0000112245 00000 n 0000041394 00000 n 0000039146 00000 n 0000006425 00000 n 0000009899 00000 n 0000041501 00000 n 0000039298 00000 n 0000009920 00000 n 0000014919 00000 n 0000097492 00000 n 0000097194 00000 n 0000106290 00000 n 0000041566 00000 n 0000039442 00000 n 0000014940 00000 n 0000019685 00000 n 0000041620 00000 n 0000041879 00000 n 0000042129 00000 n 0000039594 00000 n 0000019706 00000 n 0000023530 00000 n 0000096163 00000 n 0000095929 00000 n 0000103911 00000 n 0000042192 00000 n 0000039746 00000 n 0000023551 00000 n 0000027848 00000 n 0000042257 00000 n 0000039898 00000 n 0000027869 00000 n 0000032098 00000 n 0000042355 00000 n 0000042601 00000 n 0000042805 00000 n 0000042869 00000 n 0000043101 00000 n 0000043165 00000 n 0000043229 00000 n 0000043475 00000 n 0000043539 00000 n 0000043807 00000 n 0000043872 00000 n 0000044129 00000 n 0000044193 00000 n 0000044459 00000 n 0000044523 00000 n 0000044588 00000 n 0000044837 00000 n 0000044902 00000 n 0000044967 00000 n 0000045032 00000 n 0000045280 00000 n 0000045345 00000 n 0000045411 00000 n 0000045595 00000 n 0000045835 00000 n 0000045901 00000 n 0000045966 00000 n 0000046031 00000 n 0000046096 00000 n 0000046161 00000 n 0000100959 00000 n 0000100718 00000 n 0000116988 00000 n 0000046227 00000 n 0000046292 00000 n 0000046357 00000 n 0000046596 00000 n 0000046661 00000 n 0000040051 00000 n 0000032119 00000 n 0000036875 00000 n 0000046793 00000 n 0000040198 00000 n 0000036897 00000 n 0000038804 00000 n 0000046859 00000 n 0000048585 00000 n 0000051200 00000 n 0000055766 00000 n 0000060524 00000 n 0000061874 00000 n 0000063010 00000 n 0000071863 00000 n 0000075110 00000 n 0000076246 00000 n 0000083402 00000 n 0000090094 00000 n 0000095907 00000 n 0000097173 00000 n 0000100696 00000 n 0000101993 00000 n trailer << /Size 147 /Root 1 0 R /Info 2 0 R >> startxref 120819 %%EOF gcl-2.7.1/ansi-tests/PaxHeaders/read-delimited-list.lsp0000644000000000000000000000013114542551763020013 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.733790243 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-delimited-list.lsp0000644000175000017500000000302214542551763017407 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 11:17:21 2005 ;;;; Contains: Tests of READ-DELIMITED-LIST (in-package :cl-test) (deftest read-delimited-list.1 (with-input-from-string (*standard-input* "1 2 3)") (read-delimited-list #\))) (1 2 3)) (deftest read-delimited-list.2 (with-input-from-string (*standard-input* "1 2 3 ]") (read-delimited-list #\] nil)) (1 2 3)) (deftest read-delimited-list.3 (with-input-from-string (is "1 2 3)") (with-open-stream (os (make-broadcast-stream)) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (read-delimited-list #\) t)))) (1 2 3)) (deftest read-delimited-list.4 (with-input-from-string (is "1 2 3)X") (values (read-delimited-list #\) is) (notnot (eql (read-char is) #\X)))) (1 2 3) t) (deftest read-delimited-list.5 (with-input-from-string (is "1 2 3) X") (values (read-delimited-list #\) is nil) (notnot (eql (read-char is) #\Space)))) (1 2 3) t) (deftest read-delimited-list.6 (with-input-from-string (is (concatenate 'string "1 2 3" (string #\Newline) "]")) (read-delimited-list #\] is)) (1 2 3)) ;;; Tests with RECURSIVE-P set to true must be done inside a reader macro function ;;; Error tests (deftest read-delimited-list.error.1 (signals-error (read-delimited-list) program-error) t) (deftest read-delimited-list.error.2 (signals-error (with-input-from-string (is "1 2 3)") (read-delimited-list #\) is nil nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/shiftf.lsp0000644000000000000000000000013214542551763015455 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.733790243 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/shiftf.lsp0000644000175000017500000000302614542551763015054 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 15:43:44 2003 ;;;; Contains: Tests of SHIFTF (in-package :cl-test) (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 shiftf.1 (let ((x 0)) (values x (shiftf x 1) x)) 0 0 1) (deftest shiftf.2 (let ((x 'a) (y 'b) (z 'c)) (values x y z (shiftf x y z 'd) x y z)) a b c a b c d) (deftest shiftf.3 (let ((x (vector 0 1 2 3))) (values (copy-seq x) (shiftf (aref x (aref x 0)) (aref x (aref x 1)) (aref x (aref x 2)) (aref x (aref x 3)) 'foo) (copy-seq x))) #(0 1 2 3) 0 #(1 2 3 foo)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest shiftf.4 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (shiftf (expand-in-current-env (%m x)) y 'foo) x y))) 1 2 foo) (deftest shiftf.5 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (shiftf x (expand-in-current-env (%m y)) 'foo) x y))) 1 2 foo) (deftest shiftf.6 (macrolet ((%m (z) z)) (let ((x 1) (y 2)) (values (shiftf x y (expand-in-current-env (%m 'foo))) x y))) 1 2 foo) ;;; Need to add more shiftf tests here gcl-2.7.1/ansi-tests/PaxHeaders/store-value.lsp0000644000000000000000000000013214542551763016440 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.733790243 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/store-value.lsp0000644000175000017500000000237414542551763016044 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 09:10:22 2003 ;;;; Contains: Tests for STORE-VALUE restart and function (in-package :cl-test) (deftest store-value.1 (restart-case (progn (store-value 10) 'bad) (store-value (x) (list x 'good))) (10 good)) (deftest store-value.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (store-value 17 c2)) (store-value (x) (list x 'bad)) (store-value (x) (list x 'good)))) (17 good)) (deftest store-value.3 (restart-case (progn (store-value 11 nil) 'bad) (store-value (x) (list x 'good))) (11 good)) (deftest store-value.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (store-value 18 nil)) (store-value (x) (list x 'good)) (store-value (x) (list x 'bad)))) (18 good)) (deftest store-value.5 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (store-value 21 c2))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/remove-method.lsp0000644000000000000000000000013114542551763016744 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.733790243 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remove-method.lsp0000644000175000017500000001554114542551763016351 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 19:53:37 2003 ;;;; Contains: Tests of REMOVE-METHOD (in-package :cl-test) (defparameter *remove-meth-gf-01* (defgeneric remove-meth-gf-01 (x))) (defparameter *remove-meth-gf-01-method-t* (defmethod remove-meth-gf-01 ((x t)) x)) (defparameter *remove-meth-gf-02* (defgeneric remove-meth-gf-02 (x))) (defparameter *remove-meth-gf-02-method-t* (defmethod remove-meth-gf-02 ((x t)) x)) ;;; remove method must not signal an error if the method ;;; does not belong to the generic function (deftest remove-method.1 (and (eqt (remove-method *remove-meth-gf-01* *remove-meth-gf-02-method-t*) *remove-meth-gf-01*) (remove-meth-gf-01 :good)) :good) ;;; Add, then remove, a method (deftest remove-method.2 (let (meth) (values (remove-meth-gf-01 10) (progn (setf meth (eval '(defmethod remove-meth-gf-01 ((x integer)) (1+ x)))) nil) (remove-meth-gf-01 10) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth)) (remove-meth-gf-01 10))) 10 nil 11 t 10) ;;; Add two disjoint methods, then remove (deftest remove-method.3 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(19 a)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) (list x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(19 a)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(19 a)))) (19 a) (19 (a)) (20 (a)) t (20 a) t (19 a)) ;;; Remove in the other order (deftest remove-method.4 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(19 a)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) (list x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(19 a)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(19 a)))) (19 a) (19 (a)) (20 (a)) t (19 (a)) t (19 a)) ;;; Now methods that shadow one another (deftest remove-method.5 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (9 20.0) (9 21.0) t (11 21.0) t (10 20.0)) (deftest remove-method.6 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (9 20.0) (9 21.0) t (9 20.0) t (10 20.0)) (deftest remove-method.7 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (11 21.0) (9 21.0) t (9 20.0) t (10 20.0)) (deftest remove-method.8 (let (meth1 meth2) (values (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) (mapcar #'remove-meth-gf-01 '(10 20.0)) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) (mapcar #'remove-meth-gf-01 '(10 20.0)))) (10 20.0) (11 21.0) (9 21.0) t (11 21.0) t (10 20.0)) ;;; Adding and removing auxiliary methods (declaim (special *rmgf-03-var*)) (defparameter *remove-meth-gf-03* (defgeneric remove-meth-gf-03 (x))) (defparameter *remove-meth-gf-03-method-t* (defmethod remove-meth-gf-03 ((x t)) (list *rmgf-03-var* x))) (deftest remove-method.9 (let (meth (*rmgf-03-var* 0)) (values (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :before ((x number)) (incf *rmgf-03-var*)))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) ((0 5) (0 a)) ((1 5) (1 a)) t ((1 5) (1 a))) (deftest remove-method.10 (let (meth (*rmgf-03-var* 0)) (values (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :after ((x number)) (incf *rmgf-03-var*)))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) ((0 5) (0 a)) ((0 5) (1 a)) t ((1 5) (1 a))) (deftest remove-method.11 (let (meth (*rmgf-03-var* 0)) (values (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :around ((x number)) (incf *rmgf-03-var*) (prog1 (call-next-method) (decf *rmgf-03-var*))))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) ((0 5) (0 a)) ((1 5) (0 a)) t ((0 5) (0 a))) ;;; Must add tests for nonstandard method combinations gcl-2.7.1/ansi-tests/PaxHeaders/array-misc.lsp0000644000000000000000000000013114542551762016237 xustar0030 mtime=1703597042.916022294 29 atime=1744294960.73779026 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-misc.lsp0000644000175000017500000000120314542551762015632 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/simple-string.lsp0000644000000000000000000000013114542551763016766 xustar0030 mtime=1703597043.024022464 29 atime=1744294960.73779026 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-string.lsp0000644000175000017500000000340414542551763016366 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:27:46 2004 ;;;; Contains: Tests associated with SIMPLE-STRING (in-package :cl-test) (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) (deftest simple-string.6 (subtypep* 'simple-string '(simple-array * (*))) t t) (deftest simple-string.7 (subtypep* 'simple-string '(simple-array * 1)) t t) (deftest simple-string.8 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string '(simple-array character (*))) nil t) (deftest simple-string.9 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string '(simple-array base-char (*))) nil t) (deftest simple-string.10 :notes (:nil-vectors-are-strings) (subtypep* 'simple-string 'simple-base-string) nil t) (deftest simple-string.11 :notes (:nil-vectors-are-strings) (subtypep* '(simple-array nil (*)) 'simple-string) t t) (deftest simple-string.12 :notes (:nil-vectors-are-strings) (typep* (make-array '(0) :element-type nil) 'simple-string) t) (deftest simple-string.13 :notes (:nil-vectors-are-strings) (typep* (make-array '(12) :element-type nil) 'simple-string) t) (deftest simple-string.14 (typep* "abc" '(simple-string)) t) (deftest simple-string.15 (typep* "abc" '(simple-string *)) t) (deftest simple-string.16 (typep* "abc" '(simple-string 3)) t) (deftest simple-string.17 (typep* "abc" '(simple-string 2)) nil) (deftest simple-string.18 (typep* "abc" '(simple-string 4)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/keywordp.lsp0000644000000000000000000000013014542551762016033 xustar0029 mtime=1703597042.99602242 29 atime=1744294960.73779026 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/keywordp.lsp0000644000175000017500000000246614542551762015443 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:46:51 2003 ;;;; Contains: Tests of KEYWORDP (in-package :cl-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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.13 (let ((kwp (find-package "KEYWORD")) (bad nil)) (do-symbols (s "KEYWORD" bad) (when (and (not (eq (symbol-package s) kwp)) (keywordp s)) (push s bad)))) nil) (deftest keywordp.order.1 (let ((i 0)) (values (keywordp (progn (incf i) nil)) i)) nil 1) (deftest keywordp.error.1 (signals-error (keywordp) program-error) t) (deftest keywordp.error.2 (signals-error (keywordp :x :x) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/logbitp.lsp0000644000000000000000000000013114542551763015631 xustar0030 mtime=1703597043.000022426 29 atime=1744294960.73779026 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logbitp.lsp0000644000175000017500000000331114542551763015226 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 07:02:00 2003 ;;;; Contains: Tests of LOGBITP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logbitp.error.1 (signals-error (logbitp) program-error) t) (deftest logbitp.error.2 (signals-error (logbitp 0) program-error) t) (deftest logbitp.error.3 (signals-error (logbitp 0 0 0) program-error) t) (deftest logbitp.error.4 (check-type-error #'(lambda (x) (logbitp x 0)) (typef 'unsigned-byte)) nil) (deftest logbitp.error.5 (check-type-error #'(lambda (x) (logbitp 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logbitp.1 (loop for x in *integers* unless (if (logbitp 0 x) (oddp x) (evenp x)) collect x) nil) (deftest logbitp.2 (loop for len from 0 to 300 for i = (ash 1 len) always (and (logbitp len i) (loop for j from 0 to 300 always (or (eql j len) (not (logbitp j i)))))) t) (deftest logbitp.3 (logbitp most-positive-fixnum 0) nil) (deftest logbitp.4 (notnot-mv (logbitp most-positive-fixnum -1)) t) (deftest logbitp.5 (logbitp (1+ most-positive-fixnum) 0) nil) (deftest logbitp.6 (notnot-mv (logbitp (1+ most-positive-fixnum) -1)) t) (deftest logbitp.7 (loop for len = (random 100) for i = (random-from-interval (ash 1 len)) for k = (random (1+ len)) repeat 1000 unless (if (ldb-test (byte 1 k) i) (logbitp k i) (not (logbitp k i))) collect (list i k)) nil) (deftest logbitp.8 (loop for k from 1 to 1000 always (logbitp k -1)) t) (deftest logbitp.order.1 (let ((i 0) a b) (values (logbitp (progn (setf a (incf i)) 2) (progn (setf b (incf i)) #b111010)) i a b)) nil 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/member-if.lsp0000644000000000000000000000013014542551763016033 xustar0030 mtime=1703597043.004022432 29 atime=1744294960.73779026 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/member-if.lsp0000644000175000017500000000652214542551763015440 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:51:56 2003 ;;;; Contains: Tests of MEMBER-IF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Error cases (deftest member-if.error.1 (check-type-error #'(lambda (x) (member-if #'identity x)) #'listp) nil) (deftest member-if.error.2 (signals-error (member-if) program-error) t) (deftest member-if.error.3 (signals-error (member-if #'null) program-error) t) (deftest member-if.error.4 (signals-error (member-if #'null '(a b c) :bad t) program-error) t) (deftest member-if.error.5 (signals-error (member-if #'null '(a b c) :bad t :allow-other-keys nil) program-error) t) (deftest member-if.error.6 (signals-error (member-if #'null '(a b c) :key) program-error) t) (deftest member-if.error.7 (signals-error (member-if #'null '(a b c) 1 2) program-error) t) (deftest member-if.error.8 (signals-error (locally (member-if #'identity 'a) t) type-error) t) (deftest member-if.error.9 (signals-error (member-if #'cons '(a b c)) program-error) t) (deftest member-if.error.10 (signals-error (member-if #'identity '(a b c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/fresh-line.lsp0000644000000000000000000000013114542551762016224 xustar0030 mtime=1703597042.992022413 29 atime=1744294960.73779026 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fresh-line.lsp0000644000175000017500000000360014542551762015622 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/array.lsp0000644000000000000000000000013114542551762015306 xustar0030 mtime=1703597042.916022294 29 atime=1744294960.73779026 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array.lsp0000644000175000017500000001232014542551762014703 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/remove-duplicates.lsp0000644000000000000000000000013014542551763017620 xustar0030 mtime=1703597043.020022457 29 atime=1744294960.73779026 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remove-duplicates.lsp0000644000175000017500000003064214542551763017225 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 29 20:49:47 2002 ;;;; Contains: Tests for REMOVE-DUPLICATES, DELETE-DUPLICATES (in-package :cl-test) (compile-and-load "remove-aux.lsp") (compile-and-load "remove-duplicates-aux.lsp") (deftest random-remove-duplicates (loop for result = (random-test-remove-dups (1+ (random 20))) repeat 1000 unless (eq result t) collect result) nil) (deftest random-delete-duplicates (loop for result = (random-test-remove-dups (1+ (random 20)) nil) repeat 1000 unless (eq result t) collect result) nil) ;;; 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)) (defharmless remove-duplicates.test-and-test-not.1 (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql :test-not #'eql)) (defharmless remove-duplicates.test-and-test-not.2 (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql :test #'eql)) (defharmless delete-duplicates.test-and-test-not.1 (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql :test-not #'eql)) (defharmless delete-duplicates.test-and-test-not.2 (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql :test #'eql)) ;;; Const fold tests (def-fold-test remove-duplicates.fold.1 (remove-duplicates '(1 2 3 3))) (def-fold-test remove-duplicates.fold.2 (remove-duplicates #(1 2 3 3))) (def-fold-test remove-duplicates.fold.3 (remove-duplicates #*0011)) (def-fold-test remove-duplicates.fold.4 (remove-duplicates "1233")) ;;; 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 (signals-error (remove-duplicates) program-error) t) (deftest remove-duplicates.error.2 (signals-error (remove-duplicates nil :start) program-error) t) (deftest remove-duplicates.error.3 (signals-error (remove-duplicates nil 'bad t) program-error) t) (deftest remove-duplicates.error.4 (signals-error (remove-duplicates nil 'bad t :allow-other-keys nil) program-error) t) (deftest remove-duplicates.error.5 (signals-error (remove-duplicates nil 1 2) program-error) t) (deftest remove-duplicates.error.6 (signals-error (remove-duplicates (list 'a 'b 'c) :test #'identity) program-error) t) (deftest remove-duplicates.error.7 (signals-error (remove-duplicates (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest remove-duplicates.error.8 (signals-error (remove-duplicates (list 'a 'b 'c) :key #'cons) program-error) t) (deftest remove-duplicates.error.9 (signals-error (remove-duplicates (list 'a 'b 'c) :key #'car) type-error) t) (deftest remove-duplicates.error.10 (check-type-error #'remove-duplicates #'sequencep) nil) ;;; (deftest delete-duplicates.error.1 (signals-error (delete-duplicates) program-error) t) (deftest delete-duplicates.error.2 (signals-error (delete-duplicates nil :start) program-error) t) (deftest delete-duplicates.error.3 (signals-error (delete-duplicates nil 'bad t) program-error) t) (deftest delete-duplicates.error.4 (signals-error (delete-duplicates nil 'bad t :allow-other-keys nil) program-error) t) (deftest delete-duplicates.error.5 (signals-error (delete-duplicates nil 1 2) program-error) t) (deftest delete-duplicates.error.6 (signals-error (delete-duplicates (list 'a 'b 'c) :test #'identity) program-error) t) (deftest delete-duplicates.error.7 (signals-error (delete-duplicates (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest delete-duplicates.error.8 (signals-error (delete-duplicates (list 'a 'b 'c) :key #'cons) program-error) t) (deftest delete-duplicates.error.9 (signals-error (delete-duplicates (list 'a 'b 'c) :key #'car) type-error) t) (deftest delete-duplicates.error.10 (check-type-error #'delete-duplicates #'sequencep) nil) ;;; Specialized string tests (deftest remove-duplicates.string.1 (do-special-strings (s "abcadefabgz" nil) (let ((s2 (remove-duplicates s))) (assert (string= s "abcadefabgz")) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "cdefabgz")))) nil) (deftest remove-duplicates.string.2 (do-special-strings (s "abcadefabgz" nil) (let ((s2 (remove-duplicates s :from-end t))) (assert (string= s "abcadefabgz")) (assert (equal (array-element-type s) (array-element-type s2))) (assert (string= s2 "abcdefgz")))) nil) (deftest delete-duplicates.string.1 (do-special-strings (s "abcadefabgz" nil) (let ((aet (array-element-type s)) (s2 (delete-duplicates s))) (assert (equal aet (array-element-type s2))) (assert (string= s2 "cdefabgz")))) nil) (deftest delete-duplicates.string.2 (do-special-strings (s "abcadefabgz" nil) (let ((aet (array-element-type s)) (s2 (delete-duplicates s :from-end t))) (assert (equal aet (array-element-type s2))) (assert (string= s2 "abcdefgz")))) nil) ;;; Order of elements kept under EQUAL, EQUALP tests (deftest remove-duplicates.2 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equal))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest remove-duplicates.2a (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x 'x y) :test 'equal))) (values result (notnot (eql (cadr result) x)) (notnot (eql (cadr result) y)))) (x (a)) nil t) (deftest remove-duplicates.3 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) (deftest remove-duplicates.3a (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x 'u 'v y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a) u v) t nil) (deftest remove-duplicates.4 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equalp))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest remove-duplicates.5 (let* ((x (list 'a)) (y (list 'a)) (result (remove-duplicates (list x y) :test 'equalp :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) ;;; Similar, but destructive (deftest delete-duplicates.2 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equal))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest delete-duplicates.2a (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x 'x y) :test 'equal))) (values result (notnot (eql (cadr result) x)) (notnot (eql (cadr result) y)))) (x (a)) nil t) (deftest delete-duplicates.3 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) (deftest delete-duplicates.3a (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x 'u 'v y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a) u v) t nil) (deftest delete-duplicates.4 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equalp))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) nil t) (deftest delete-duplicates.5 (let* ((x (list 'a)) (y (list 'a)) (result (delete-duplicates (list x y) :test 'equalp :from-end t))) (values result (notnot (eql (car result) x)) (notnot (eql (car result) y)))) ((a)) t nil) gcl-2.7.1/ansi-tests/PaxHeaders/decode-universal-time.lsp0000644000000000000000000000013114542551762020355 xustar0030 mtime=1703597042.972022382 29 atime=1744294960.73779026 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/decode-universal-time.lsp0000644000175000017500000000777014542551762017767 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 7 07:00:58 2005 ;;;; Contains: Tests of DECODE-UNIVERSAL-TIME (in-package :cl-test) (deftest decode-universal-time.1 (decode-universal-time 0 0) 0 0 0 1 1 1900 0 nil 0) (deftest decode-universal-time.2 (decode-universal-time 0 -1) 0 0 1 1 1 1900 0 nil -1) (deftest decode-universal-time.3 (let ((count 0)) (loop for time = (random 10000000000) for tz = (- (random 49) 24) for (second minute hour date month year day daylight-p zone) = (multiple-value-list (decode-universal-time time tz)) for time2 = (encode-universal-time second minute hour date month year zone) repeat 1000 unless (and (eql tz zone) (eql time time2) (null daylight-p)) collect (progn (incf count) (list time tz (list second minute hour date month year day daylight-p zone) time2)) until (>= count 100))) nil) (deftest decode-universal-time.4 (let ((count 0)) (loop for time = (random 10000000000) for tz = (/ (- (random (1+ (* 48 3600))) (* 24 3600)) 3600) for (second minute hour date month year day daylight-p zone) = (multiple-value-list (decode-universal-time time tz)) for time2 = (encode-universal-time second minute hour date month year zone) repeat 1000 unless (and (eql tz zone) (eql time time2) (null daylight-p)) collect (progn (incf count) (list time tz (list second minute hour date month year day daylight-p zone) time2)) until (>= count 100))) nil) (deftest decode-universal-time.5 (let ((count 0)) (loop for time = (random 10000000000) for (second minute hour date month year day daylight-p zone) = (handler-case (multiple-value-list (decode-universal-time time)) (error (c) (print time) (error c))) for time2 = (encode-universal-time second minute hour date month year) repeat 1000 unless (let ((daylight-p-2 (nth-value 7 (decode-universal-time time2)))) (or (eql time time2) (and daylight-p (not daylight-p-2) ; (eql time (- time2 3600)) ) (and (not daylight-p) daylight-p-2 ; (eql time (+ time2 3600)) ))) collect (progn (incf count) (list time (list second minute hour date month year day daylight-p zone) time2)) until (>= count 100))) nil) (deftest decode-universal-time.6 (let ((vals0 (multiple-value-list (get-decoded-time))) (vals1 (multiple-value-list (decode-universal-time (get-universal-time)))) (vals2 (multiple-value-list (get-decoded-time)))) (when (equal vals0 vals2) (assert (= (length vals1) 9)) (assert (= (length vals2) 9)) (assert (equal (subseq vals1 0 7) (subseq vals2 0 7))) (assert (if (elt vals1 7) (elt vals2 7) (not (elt vals2 7)))) (assert (= (elt vals1 8) (elt vals2 8)))) (values))) (deftest decode-universal-time.7 (decode-universal-time (* 365 3600 24) 0) 0 0 0 1 1 1901 1 nil 0) (deftest decode-universal-time.8 (decode-universal-time (* 2 365 3600 24) 0) 0 0 0 1 1 1902 2 nil 0) (deftest decode-universal-time.9 (decode-universal-time (* 3 365 3600 24) 0) 0 0 0 1 1 1903 3 nil 0) (deftest decode-universal-time.10 (decode-universal-time (* 4 365 3600 24) 0) 0 0 0 1 1 1904 4 nil 0) (deftest decode-universal-time.11 (decode-universal-time (+ (* 24 3600) (* 5 365 3600 24)) 0) 0 0 0 1 1 1905 6 nil 0) (deftest decode-universal-time.12 (loop for time = (random 100000000000) for tz = (- (random 49) 24) for interval = (1+ (random 10000)) for time2 = (+ time (* interval 24 3600)) ;; 'time2' is exactly interval days after 'time' for day = (nth-value 6 (decode-universal-time time tz)) for day2 = (nth-value 6 (decode-universal-time time2 tz)) repeat 1000 ;; Check that the days of the week are consistent unless (= (mod day2 7) (mod (+ day interval) 7)) collect (list time time2 tz interval day day2)) nil) ;;; Error tests (deftest decode-universal-time.error.1 (signals-error (decode-universal-time) program-error) t) (deftest decode-universal-time.error.2 (signals-error (decode-universal-time 0 0 nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load.lsp0000644000000000000000000000013014542551762015106 xustar0029 mtime=1703597042.99602242 29 atime=1744294960.73779026 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/load.lsp0000644000175000017500000001434114542551762014511 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/complement.lsp0000644000000000000000000000012714542551762016340 xustar0028 mtime=1703597042.9200223 29 atime=1744294960.73779026 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/complement.lsp0000644000175000017500000000714314542551762015737 0ustar00cammcamm;-*- 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 (check-predicate #'(lambda (x) (eql (funcall (cl::complement #'not) x) (not (not x))))) nil) (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.6 (flet ((%f (&rest args) (notnot (evenp (length args))))) (let ((cf (complement #'%f))) (values (%f) (%f 'a) (%f 'a 'b) (%f 'a 'b 'c) (funcall cf) (funcall cf 'a) (funcall cf 'a 'b) (funcall cf 'a 'b 'c)))) t nil t nil nil t nil t) (deftest complement.7 (flet ((%f (&optional x y) (if x (not y) y))) (let ((cf (complement #'%f))) (values (%f) (%f nil) (%f t) (%f nil nil) (%f t nil) (%f nil t) (%f t t) (funcall cf) (funcall cf nil) (funcall cf t) (funcall cf nil nil) (funcall cf t nil) (funcall cf nil t) (funcall cf t t)))) nil nil t nil t t nil t t nil t nil nil t) (deftest complement.8 (flet ((%f (&key x y) (if x (not y) y))) (let ((cf (complement #'%f))) (values (list (%f) (%f :x nil) (%f :x t) (%f :y nil) (%f :y t :y nil) (%f :x nil :y nil) (%f :x t :y nil) (%f :y t :x nil) (%f :x t :y t)) (list (funcall cf) (funcall cf :x nil) (funcall cf :x t) (funcall cf :y nil) (funcall cf :y t) (funcall cf :x nil :y nil) (funcall cf :x t :y nil) (funcall cf :y t :x nil) (funcall cf :x t :y t :x nil)) (list (funcall cf :x nil :y t :foo nil :allow-other-keys t) (funcall cf :x nil :y t :allow-other-keys nil))))) (nil nil t nil t nil t t nil) (t t nil t nil t nil nil t) (nil nil)) (deftest complement.9 (let ((sym (gensym))) (eval `(defgeneric ,sym (x y))) (eval `(defmethod ,sym ((x integer) (y integer)) (evenp (+ x y)))) (eval `(defmethod ,sym ((x t) (y t)) nil)) (let ((cf (complement (symbol-function sym)))) (values (funcall cf 'a 'b) (funcall cf 0 0) (funcall cf 0 1) (funcall cf 1 0) (funcall cf 1 1)))) t nil t t nil) (deftest complement.10 (let ((cf (complement (compile nil '(lambda (x y) (evenp (+ x y))))))) (values (funcall cf 0 0) (funcall cf 0 1) (funcall cf 1 0) (funcall cf 1 1))) nil t t nil) (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) ;;; Error tests (deftest complement.error.1 (signals-error (complement) program-error) t) (deftest complement.error.2 (signals-error (complement #'not t) program-error) t) (deftest complement.error.3 (signals-error (funcall (complement #'identity)) program-error) t) (deftest complement.error.4 (signals-error (funcall (complement #'identity) t t) program-error) t) (deftest complement.error.5 (signals-error (funcall (complement #'(lambda (&key) t)) :foo t) program-error) t) (deftest complement.error.6 (signals-error (funcall (complement #'(lambda (&key) t)) :allow-other-keys nil :allow-other-keys t :foo t) program-error) t) (deftest complement.error.7 (signals-error (funcall (complement #'(lambda (x &rest y) (and x (evenp (length y)))))) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/print-structure.lsp0000644000000000000000000000013014542551763017362 xustar0030 mtime=1703597043.016022451 29 atime=1744294960.73779026 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-structure.lsp0000644000175000017500000000220114542551763016755 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed May 26 22:19:52 2004 ;;;; Contains: Printing tests for structures (in-package :cl-test) (compile-and-load "printer-aux.lsp") (defstruct print-struct-1 foo bar) (deftest print-structure.1 (let ((s (make-print-struct-1 :foo 1 :bar 2))) (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (let ((str (write-to-string s :readably nil :case :upcase :escape nil))) (assert (string= (subseq str 0 3) "#S(")) (let ((vals (read-from-string (subseq str 2)))) (assert (listp vals)) (assert (= (length vals) 5)) (assert (eq (car vals) 'print-struct-1)) (assert (symbolp (cadr vals))) (assert (symbolp (cadddr vals))) (cond ((string= (symbol-name (cadr vals)) "FOO") (assert (string= (symbol-name (cadddr vals)) "BAR")) (assert (= (caddr vals) 1)) (assert (= (car (cddddr vals)) 2))) (t (assert (string= (symbol-name (cadr vals)) "BAR")) (assert (string= (symbol-name (cadddr vals)) "FOO")) (assert (= (caddr vals) 2)) (assert (= (car (cddddr vals)) 1)))) nil))))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/fceiling-aux.lsp0000644000000000000000000000013214542551762016544 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.741790278 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fceiling-aux.lsp0000644000175000017500000000074714542551762016152 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 06:24:45 2003 ;;;; Contains: Tests of FCEILING (in-package :cl-test) (defun fceiling.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (fceiling n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (< (- d) r 1)) collect (list n d q r n2))) gcl-2.7.1/ansi-tests/PaxHeaders/ffloor-aux.lsp0000644000000000000000000000013214542551762016253 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.741790278 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ffloor-aux.lsp0000644000175000017500000000076214542551762015656 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 12 07:02:07 2003 ;;;; Contains: Aux. functions used in FFLOOR tests (in-package :cl-test) (defun ffloor.1-fn () (loop for n = (- (random 200000) 100000) for d = (1+ (random 10000)) for vals = (multiple-value-list (ffloor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 100 unless (and (eql (length vals) 2) (floatp q) (= n n2) (integerp r) (< -1 r d)) collect (list n d q r n2))) gcl-2.7.1/ansi-tests/PaxHeaders/define-symbol-macro.lsp0000644000000000000000000000013214542551762020025 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.741790278 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-symbol-macro.lsp0000644000175000017500000000125314542551762017424 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:55:05 2003 ;;;; Contains: Tests of DEFINE-SYMBOL-MACRO (in-package :cl-test) (deftest define-symbol-macro.error.1 (signals-error (funcall (macro-function 'define-symbol-macro)) program-error) t) (deftest define-symbol-macro.error.2 (signals-error (funcall (macro-function 'define-symbol-macro) '(define-symbol-macro nonexistent-symbol-macro nil)) program-error) t) (deftest define-symbol-macro.error.3 (signals-error (funcall (macro-function 'define-symbol-macro) '(define-symbol-macro nonexistent-symbol-macro nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/exp.lsp0000644000000000000000000000013214542551762014765 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.741790278 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/exp.lsp0000644000175000017500000000373714542551762014375 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 21:24:44 2003 ;;;; Contains: Tests of EXP (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "exp-aux.lsp") ;;; Error tests (deftest exp.error.1 (signals-error (exp) program-error) t) (deftest exp.error.2 (signals-error (exp 0 nil) program-error) t) (deftest exp.error.3 (signals-error (exp 0 0 0) program-error) t) ;;; Other tests (deftest exp.1 (let ((result (exp 0))) (or (eqlt result 1) (eqlt result 1.0f0))) t) (deftest exp.2 (mapcar #'exp '(0.0s0 0.0f0 0.0d0 0.0l0)) (1.0s0 1.0f0 1.0d0 1.0l0)) (deftest exp.3 (mapcar #'exp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) (1.0s0 1.0f0 1.0d0 1.0l0)) ;;; FIXME ;;; Add more tests here for floating point accuracy (defun texp (x) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow t :floating-point-underflow t) (unwind-protect (exp x) #+gcl(si::break-on-floating-point-exceptions :floating-point-overflow nil :floating-point-underflow nil))) (deftest exp.error.4 (signals-error (texp (+ (log most-positive-short-float) 100)) floating-point-overflow) t) (deftest exp.error.5 (signals-error (texp (+ (log most-positive-single-float) 100)) floating-point-overflow) t) (deftest exp.error.6 (signals-error (texp (+ (log most-positive-double-float) 100)) floating-point-overflow) t) (deftest exp.error.7 (signals-error (texp (+ (log most-positive-long-float) 100)) floating-point-overflow) t) (deftest exp.error.8 (signals-error (texp (- (log least-positive-short-float) 100)) floating-point-underflow) t) (deftest exp.error.9 (signals-error (texp (- (log least-positive-single-float) 100)) floating-point-underflow) t) (deftest exp.error.10 (signals-error (texp (- (log least-positive-double-float) 100)) floating-point-underflow) t) (deftest exp.error.11 (signals-error (texp (- (log least-positive-double-float) 100)) floating-point-underflow) t) gcl-2.7.1/ansi-tests/PaxHeaders/union.lsp0000644000000000000000000000013114542551763015321 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.741790278 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/union.lsp0000644000175000017500000002421214542551763014721 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:41:24 2003 ;;;; Contains: Tests of UNION (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) (defharmless union.test-and-test-not.1 (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql)) (defharmless union.test-and-test-not.2 (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql)) ;;; 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)) (def-fold-test union.fold.1 (union '(a b c d e) '(d x y a w c))) ;;; Error tests (deftest union.error.1 (signals-error (union) program-error) t) (deftest union.error.2 (signals-error (union nil) program-error) t) (deftest union.error.3 (signals-error (union nil nil :bad t) program-error) t) (deftest union.error.4 (signals-error (union nil nil :key) program-error) t) (deftest union.error.5 (signals-error (union nil nil 1 2) program-error) t) (deftest union.error.6 (signals-error (union nil nil :bad t :allow-other-keys nil) program-error) t) (deftest union.error.7 (signals-error (union (list 1 2) (list 3 4) :test #'identity) program-error) t) (deftest union.error.8 (signals-error (union (list 1 2) (list 3 4) :test-not #'identity) program-error) t) (deftest union.error.9 (signals-error (union (list 1 2) (list 3 4) :key #'cons) program-error) t) (deftest union.error.10 (signals-error (union (list 1 2) (list 3 4) :key #'car) type-error) t) (deftest union.error.11 (signals-error (union (list 1 2 3) (list* 4 5 6)) type-error) t) (deftest union.error.12 (signals-error (union (list* 1 2 3) (list 4 5 6)) type-error) t) ;;; The next two tests used to check for union with NIL, but arguably ;;; that goes beyond the 'be prepared to signal an error' requirement, ;;; since a union algorithm doesn't have to traverse one argument ;;; if the other is the empty list. (deftest union.error.13 (check-type-error #'(lambda (x) (union x '(1 2))) #'listp) nil) (deftest union.error.14 (check-type-error #'(lambda (x) (union '(1 2) x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/array-total-size.lsp0000644000000000000000000000013214542551762017400 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.741790278 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-total-size.lsp0000644000175000017500000000244614542551762017004 0ustar00cammcamm;-*- 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.6 (macrolet ((%m (z) z)) (array-total-size (expand-in-current-env (%m #(a b c))))) 3) (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 (signals-error (array-total-size) program-error) t) (deftest array-total-size.error.2 (signals-error (array-total-size #(a b c) nil) program-error) t) (deftest array-total-size.error.3 (check-type-error #'array-total-size #'arrayp) nil) (deftest array-total-size.error.4 (signals-error (array-total-size 0) type-error) t) (deftest array-total-size.error.5 (signals-type-error x 0 (locally (array-total-size x) t)) t) gcl-2.7.1/ansi-tests/PaxHeaders/loop3.lsp0000644000000000000000000000013214542551763015226 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.741790278 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop3.lsp0000644000175000017500000000650614542551763014633 0ustar00cammcamm;-*- 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 (signals-error (loop for x on '(a b c) for x on '(d e f) collect x) program-error) t) (deftest loop.3.15 (signals-error (loop for (x . x) on '((a b) (c d)) collect x) program-error) t) (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.3.24 (macrolet ((%m (z) z)) (loop for x on (expand-in-current-env (%m '(1 2 3))) sum (car x))) 6) (deftest loop.3.25 (macrolet ((%m (z) z)) (loop for e on (expand-in-current-env (%m '(a b c d e f))) by #'cddr collect (car e))) (a c e)) (deftest loop.3.26 (macrolet ((%m (z) z)) (loop for e on '(a b c d e f) by (expand-in-current-env (%m #'cddr)) collect (car e))) (a c e)) (deftest loop.3.27 (macrolet ((%m (z) z)) (loop as x on (expand-in-current-env (%m '(1 2 3))) sum (car x))) 6) gcl-2.7.1/ansi-tests/PaxHeaders/encode-universal-time.lsp0000644000000000000000000000013214542551762020370 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.741790278 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/encode-universal-time.lsp0000644000175000017500000000636614542551762020001 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 8 12:54:34 2005 ;;;; Contains: Tests of ENCODE-UNIVERSAL-TIME ;;; See also the tests in decode-universal-time.lsp (in-package :cl-test) (deftest encode-universal-time.1 (loop with count = 0 for year = (+ 1900 (random 1000)) ;; Gregorian leap year algorithm for leap? = (and (= (mod year 4) 0) (or (/= (mod year 100) 0) (= (mod year 400) 0))) for month = (1+ (random 12)) for date = (1+ (random (elt (if leap? #(0 31 29 31 30 31 30 31 31 30 31 30 31) #(0 31 28 31 30 31 30 31 31 30 31 30 31)) month))) for hour = (random 24) for minute = (random 60) for second = (random 60) for tz = (if (and (= year 1900) (= date 0) (= month 0)) (random 25) (- (random 49) 24)) for time = (encode-universal-time second minute hour date month year tz) for decoded-vals = (multiple-value-list (decode-universal-time time tz)) for vals = (list second minute hour date month year (elt decoded-vals 6) nil tz) repeat 20000 unless (equal vals decoded-vals) collect (progn (incf count) (list vals time decoded-vals)) until (>= count 100)) nil) #| (deftest encode-universal-time.2 (loop with count = 0 for year = (+ 1901 (random 1000)) ;; Gregorian leap year algorithm for leap? = (and (= (mod year 4) 0) (or (/= (mod year 100) 0) (= (mod year 400) 0))) for month = (1+ (random 12)) for date = (1+ (random (elt (if leap? #(0 31 29 31 30 31 30 31 31 30 31 30 31) #(0 31 28 31 30 31 30 31 31 30 31 30 31)) month))) for hour = (random 24) for minute = (random 60) for second = (random 60) for time = (encode-universal-time second minute hour date month year) for decoded-vals = (multiple-value-list (decode-universal-time time)) for vals = (list second minute hour date month year (elt decoded-vals 6) (elt decoded-vals 7) (elt decoded-vals 8)) repeat 20000 unless (equal vals decoded-vals) collect (progn (incf count) (list vals time decoded-vals)) until (>= count 100)) nil) |# (deftest encode-universal-time.3 (loop with count = 0 for year = (+ 1900 (random 1000)) ;; Gregorian leap year algorithm for leap? = (and (= (mod year 4) 0) (or (/= (mod year 100) 0) (= (mod year 400) 0))) for month = (1+ (random 12)) for date = (1+ (random (elt (if leap? #(0 31 29 31 30 31 30 31 31 30 31 30 31) #(0 31 28 31 30 31 30 31 31 30 31 30 31)) month))) for hour = (random 24) for minute = (random 60) for second = (random 60) for tz = (/ (if (and (= year 1900) (= date 0) (= month 0)) (random (1+ (* 24 3600))) (- (random (1+ (* 48 3600))) (* 24 3600))) 3600) for time = (encode-universal-time second minute hour date month year tz) for decoded-vals = (multiple-value-list (decode-universal-time time tz)) for vals = (list second minute hour date month year (elt decoded-vals 6) nil tz) repeat 20000 unless (equal vals decoded-vals) collect (progn (incf count) (list vals time decoded-vals)) until (>= count 100)) nil) ;;; Error cases (deftest encode-universal-time.error.1 (signals-error (encode-universal-time 0 0 0 1 1) program-error) t) (deftest encode-universal-time.error.2 (signals-error (encode-universal-time 0 0 0 1 1 1901 0 nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-system-construction.lsp0000644000000000000000000000013114772071560021157 xustar0029 mtime=1743287152.90290866 30 atime=1744294960.741790278 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-system-construction.lsp0000644000175000017500000000045314772071560020560 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/use-value.lsp0000644000000000000000000000013114542551763016077 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.741790278 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/use-value.lsp0000644000175000017500000000233314542551763015477 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 09:13:59 2003 ;;;; Contains: Tests for USE-VALUE restart and function (in-package :cl-test) (deftest use-value.1 (restart-case (progn (use-value 10) 'bad) (use-value (x) (list x 'good))) (10 good)) (deftest use-value.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (use-value 17 c2)) (use-value (x) (list x 'bad)) (use-value (x) (list x 'good)))) (17 good)) (deftest use-value.3 (restart-case (progn (use-value 11 nil) 'bad) (use-value (x) (list x 'good))) (11 good)) (deftest use-value.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (use-value 18 nil)) (use-value (x) (list x 'good)) (use-value (x) (list x 'bad)))) (18 good)) (deftest use-value.5 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (use-value 21 c2))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-11.lsp0000644000000000000000000000013214542551762016327 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.741790278 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-11.lsp0000644000175000017500000001353314542551762015732 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/iteration.lsp0000644000000000000000000000013214763573237016175 xustar0030 mtime=1741616799.673591244 30 atime=1744294960.741790278 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/iteration.lsp0000644000175000017500000002040014763573237015567 0ustar00cammcamm;-*- 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 successive 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 successive 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.7.1/ansi-tests/PaxHeaders/rassoc.lsp0000644000000000000000000000013114542551763015463 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.741790278 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rassoc.lsp0000644000175000017500000001547514542551763015076 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:33:49 2003 ;;;; Contains: Tests of RASSOC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (schar 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)) (deftest rassoc.26 (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) :test #'<) (d . 15)) (deftest rassoc.27 (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) :test-not #'>=) (d . 15)) (defharmless rassoc.test-and-test-not.1 (rassoc 'a '((x . b) (y . a) (z . c)) :test #'eql :test-not #'eql)) (defharmless rassoc.test-and-test-not.2 (rassoc 'a '((x . b) (y . a) (z . c)) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (rassoc) program-error) t) (deftest rassoc.error.2 (signals-error (rassoc nil) program-error) t) (deftest rassoc.error.3 (signals-error (rassoc nil nil :bad t) program-error) t) (deftest rassoc.error.4 (signals-error (rassoc nil nil :key) program-error) t) (deftest rassoc.error.5 (signals-error (rassoc nil nil 1 1) program-error) t) (deftest rassoc.error.6 (signals-error (rassoc nil nil :bad t :allow-other-keys nil) program-error) t) (deftest rassoc.error.7 (signals-error (rassoc 'a '((b . a)(c . d)) :test #'identity) program-error) t) (deftest rassoc.error.8 (signals-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity) program-error) t) (deftest rassoc.error.9 (signals-error (rassoc 'a '((b . a)(c . d)) :key #'cons) program-error) t) (deftest rassoc.error.10 (signals-error (rassoc 'z '((a . b) . c)) type-error) t) (deftest rassoci.error.11 (check-type-error #'(lambda (x) (rassoc 'a x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/rt-acl.system0000644000000000000000000000013214542551763016102 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.745790296 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rt-acl.system0000644000175000017500000000047714542551763015510 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/print-random-state.lsp0000644000000000000000000000013114542551763017721 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.745790296 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-random-state.lsp0000644000175000017500000000112714542551763017321 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 25 07:15:02 2004 ;;;; Contains: Tests of printing random states (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.random-state.1 (loop repeat 100 do (loop repeat 50 do (random 1000)) nconc (let* ((rs1 (make-random-state *random-state*)) (rs2 (with-standard-io-syntax (read-from-string (write-to-string rs1 :readably t)))) (result (list (notnot (random-state-p rs2)) (is-similar rs1 rs2)))) (unless (equal result '(t t)) (list result rs1 rs2)))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/bit-aux.lsp0000644000000000000000000000013014542551762015540 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.745790296 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-aux.lsp0000644000175000017500000000524614542551762015147 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 24 19:25:39 2005 ;;;; Contains: Aux file for BIT-* tests (in-package :cl-test) (defun bit-random-test-fn (bit-fn log-fn &key (reps 5000) (maxlen 256)) (assert (typep maxlen '(integer 1))) (assert (typep reps 'unsigned-byte)) (loop for len = (random maxlen) for twos = (make-list len :initial-element 2) for v1 = (map 'bit-vector #'random twos) for v2 = (map 'bit-vector #'random twos) for result = (funcall bit-fn v1 v2) repeat reps unless (and (= (length result) len) (every #'(lambda (result-bit v1-bit v2-bit) (= result-bit (logand 1 (funcall log-fn v1-bit v2-bit)))) result v1 v2)) collect (list len v1 v2 result))) (defun bit-random-test-fn1 (bit-fn log-fn &key (reps 5000) (maxlen 256)) (assert (typep maxlen '(integer 1))) (assert (typep reps 'unsigned-byte)) (loop for len = (random maxlen) for twos = (make-list len :initial-element 2) for vb = (make-array maxlen :element-type 'bit :initial-contents (mapcar 'random twos)) for v1 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for v2 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for result = (funcall bit-fn v1 v2) repeat reps unless (and (= (length result) len) (every #'(lambda (result-bit v1-bit v2-bit) (= result-bit (logand 1 (funcall log-fn v1-bit v2-bit)))) result v1 v2)) collect (progn (print (setq lll (list len v1 v2 result))) (break)))) (defun bit-random-test-fn2 (bit-fn log-fn &key (reps 5000) (maxlen 256)) (assert (typep maxlen '(integer 1))) (assert (typep reps 'unsigned-byte)) (loop for len = (random maxlen) for twos = (make-list len :initial-element 2) for vb = (make-array maxlen :element-type 'bit :initial-contents (mapcar 'random twos)) for v1 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for v2 = (make-array len :element-type 'bit :displaced-to vb :displaced-index-offset (random (- maxlen len))) for vb1 = (make-array maxlen :element-type 'bit) for v3 = (make-array len :element-type 'bit :displaced-to vb1 :displaced-index-offset (random (- maxlen len))) for result = (funcall bit-fn v1 v2 v3) for correct = (map 'bit-vector log-fn v1 v2) for miss = (mismatch result correct) repeat reps when miss return (list v1 v2 result correct miss len (length result)))) (defun bmm (a b c) (let ((i -1)) (map nil (lambda (a b c) (incf i) (unless (eql (logand a b) c) (return-from bmm i))) a b c))) gcl-2.7.1/ansi-tests/PaxHeaders/read-from-string.lsp0000644000000000000000000000013114542551763017351 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.745790296 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-from-string.lsp0000644000175000017500000001441114542551763016751 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 14:50:09 2005 ;;;; Contains: Tests of READ-FROM-STRING (in-package :cl-test) (deftest read-from-string.1 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123") (let ((vals (multiple-value-list (read-from-string s)))) (assert (= (length vals) 2)) (assert (eql (first vals) 123)) (assert (member (second vals) '(3 4)))))) nil) (deftest read-from-string.2 (let ((*package* (find-package :cl-test))) (do-special-strings (s "XYZ ") (let ((vals (multiple-value-list (read-from-string s)))) (assert (equal vals '(|XYZ| 4)))))) nil) (deftest read-from-string.3 (let ((*package* (find-package :cl-test))) (do-special-strings (s "(1 2 3)X") (let ((vals (multiple-value-list (read-from-string s)))) (assert (equal vals '((1 2 3) 7)))))) nil) (deftest read-from-string.4 (do-special-strings (s "") (let ((vals (multiple-value-list (read-from-string s nil :good)))) (assert (= (length vals) 2)) (assert (equal (first vals) :good)) (assert (member (second vals) '(0 1))))) nil) (deftest read-from-string.5 (let ((*package* (find-package :cl-test))) (do-special-strings (s "71235") (let ((vals (multiple-value-list (read-from-string s t nil :start 1 :end 4)))) (assert (equal vals '(123 4)))))) nil) (deftest read-from-string.6 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :start 1)))) (assert (equal vals '(123 5)))))) nil) (deftest read-from-string.7 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :end 4)))) (assert (equal vals '(7123 4)))))) nil) (deftest read-from-string.8 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123") (let ((vals (multiple-value-list (read-from-string s nil 'foo :start 2 :end 2)))) (assert (equal vals '(foo 2)))))) nil) (deftest read-from-string.9 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") (let ((vals (multiple-value-list (read-from-string s t nil :preserve-whitespace t)))) (assert (equal vals '(123 3)))))) nil) (deftest read-from-string.10 (let ((*package* (find-package :cl-test))) (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) (let ((vals (multiple-value-list (read-from-string s t nil :preserve-whitespace t)))) (assert (equal vals '(nil 3)))))) nil) ;;; Multiple keywords (deftest read-from-string.11 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :start 1 :start 2)))) (assert (equal vals '(123 5)))))) nil) (deftest read-from-string.12 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") (let ((vals (multiple-value-list (read-from-string s t nil :end 4 :end 2)))) (assert (equal vals '(7123 4)))))) nil) (deftest read-from-string.13 (let ((*package* (find-package :cl-test))) (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) (let ((vals (multiple-value-list (read-from-string s t nil :preserve-whitespace t :preserve-whitespace nil)))) (assert (equal vals '(nil 3)))))) nil) ;;; Allow other keys (deftest read-from-string.14 (with-standard-io-syntax (let ((*package* (find-package :cl-test))) (do-special-strings (s "abc ") (let ((vals (multiple-value-list (read-from-string s t nil :allow-other-keys nil)))) (assert (equal vals '(|ABC| 4)) (vals) "VALS is ~A" vals))))) nil) (deftest read-from-string.15 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") (let ((vals (multiple-value-list (read-from-string s t nil :foo 'bar :allow-other-keys t)))) (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) nil) (deftest read-from-string.16 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") (let ((vals (multiple-value-list (read-from-string s t nil :allow-other-keys t :allow-other-keys nil :foo 'bar)))) (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) nil) ;;; default for :end (deftest read-from-string.17 (let ((*package* (find-package :cl-test))) (do-special-strings (s "XYZ ") (let ((vals (multiple-value-list (read-from-string s t nil :end nil)))) (assert (equal vals '(|XYZ| 4)))))) nil) ;;; TODO Add tests for reading from strings containing non-base characters ;;; Error tests (deftest read-from-string.error.1 (signals-error (read-from-string "") error) t) (deftest read-from-string.error.2 (signals-error (read-from-string "(A B ") error) t) (deftest read-from-string.error.3 (signals-error (read-from-string "" t) error) t) (deftest read-from-string.error.4 (signals-error (read-from-string "" t nil) error) t) (deftest read-from-string.error.5 (signals-error (read-from-string "(A B " nil) error) t) (deftest read-from-string.error.6 (signals-error (read-from-string "(A B " t) error) t) (deftest read-from-string.error.7 (signals-error (read-from-string "123" t nil :start 0 :end 0) error) t) (deftest read-from-string.error.8 (signals-error (read-from-string) program-error) t) (deftest read-from-string.error.9 (signals-error (read-from-string "A" nil t :bad-keyword t) program-error) t) (deftest read-from-string.error.10 (signals-error (read-from-string "A" nil t :bad-keyword t :allow-other-keys nil) program-error) t) (deftest read-from-string.error.11 (signals-error (read-from-string "A" nil t :bad-keyword t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest read-from-string.error.12 (signals-error (read-from-string "A" nil t :allow-other-keys nil :allow-other-keys t :bad-keyword t) program-error) t) (deftest read-from-string.error.13 (signals-error (read-from-string "A" nil t :start) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/defclass-errors.lsp0000644000000000000000000000013214542551762017267 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.745790296 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defclass-errors.lsp0000644000175000017500000001002014542551762016656 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Apr 25 06:59:22 2003 ;;;; Contains: Error case tests for DEFCLASS (in-package :cl-test) ;;; I created some redundant tests by accident. This list of ;;; tests could be reduced in size. (deftest defclass.error.1 (signals-error (defclass erroneous-class.1 () (a b c d b e)) program-error) t) (deftest defclass.error.2 (signals-error (defclass erroneous-class.2 () ((s1 :initarg :foo)) (:default-initargs :foo 1 :foo 2)) program-error) t) (deftest defclass.error.3 (signals-error (defclass erroneous-class.3 () ((s1 :initform 0 :initform 2))) program-error) t) (deftest defclass.error.4 (signals-error (defclass erroneous-class.4 () ((s1 :initform 0 :initform 0))) program-error) t) (deftest defclass.error.5 (signals-error (defclass erroneous-class.5 () ((s1 :type fixnum :type character))) program-error) t) (deftest defclass.error.6 (signals-error (defclass erroneous-class.6 () ((s1 :type t :type t))) program-error) t) (deftest defclass.error.7 (signals-error (defclass erroneous-class.7 () ((s1 :documentation "foo" :documentation "bar"))) program-error) t) (deftest defclass.error.8 (signals-error (defclass erroneous-class.8 () ((s1 :documentation #1="foo" :documentation #1#))) program-error) t) (deftest defclass.error.9 (signals-error (defclass erroneous-class.9 () ((s1 :allocation :class :allocation :instance))) program-error) t) (deftest defclass.error.10 (signals-error (defclass erroneous-class.10 () ((s1 :allocation :class :allocation :class))) program-error) t) (deftest defclass.error.11 (signals-error (defclass erroneous-class.11 () ((s1 :allocation :instance :allocation :instance))) program-error) t) (deftest defclass.error.12 (signals-error (defclass erroneous-class.12 () ((s1 #.(gensym) nil))) program-error) t) (deftest defclass.error.13 (signals-error (defclass erroneous-class.13 () (a b c) (#.(gensym))) program-error) t) (deftest defclass.error.14 (signals-error (defclass defclass-error-14 nil (foo foo)) program-error) t) (deftest defclass.error.15 (signals-error (defclass defclass-error-15 nil (foo (foo))) program-error) t) (deftest defclass.error.16 (signals-error (defclass defclass-error-16 nil ((foo :initarg f1)) (:default-initargs :f1 10 :f1 20)) program-error) t) (deftest defclass.error.17 (signals-error (defclass defclass-error-17 nil ((foo :initform 10 :initform 20 :reader defclass-error-4/foo))) program-error) t) (deftest defclass.error.18 (signals-error (defclass defclass-error-18 nil ((foo :initform 10 :initform 10 :reader defclass-error-5/foo))) program-error) t) (deftest defclass.error.19 (signals-error (defclass defclass-error-19 nil ((foo :initarg f1 :type t :type t :reader defclass-error-6/foo))) program-error) t) (deftest defclass.error.20 (signals-error (defclass defclass-error-20 nil ((foo :initarg f1 :documentation "x" :reader defclass-error-7/foo :documentation "x"))) program-error) t) (deftest defclass.error.21 (signals-error (defclass defclass-error-21 () ((foo #:unknown-slot-option nil))) program-error) t) (deftest defclass.error.22 (let ((option (gentemp "UNKNOWN-OPTION" (symbol-package :foo)))) (eval `(signals-error (defclass defclass-error-22 () (foo bar) (,option nil)) program-error))) t) (deftest defclass.error.23 (loop for cl in *built-in-classes* for name = (class-name cl) unless (or (not name) (handler-case (progn (eval `(defclass ,(gensym) (,name))) nil) (error (c) c))) collect (list cl name)) nil) (deftest defclass.error.24 (loop for cl in *built-in-classes* for name = (class-name cl) unless (or (not name) (handler-case (progn (eval `(defclass ,name ())) nil) (error (c) c))) collect (list cl name)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/slot-unbound.lsp0000644000000000000000000000013214542551763016623 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.745790296 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/slot-unbound.lsp0000644000175000017500000000257614542551763016233 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 15 06:57:23 2003 ;;;; Contains: Tests for SLOT-UNBOUND (in-package :cl-test) (defclass slot-unbound-class-01 () ((a :reader sunb-a) (b :accessor sunb-b) (c :writer sunb-c) (e :reader sunb-e) (f :reader sunb-f))) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) (slot-name t)) (list (class-name class) slot-name)) (deftest slot-unbound.1 (let ((obj (make-instance 'slot-unbound-class-01))) (values (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) (slot-unbound-class-01 a) (slot-unbound-class-01 b) (slot-unbound-class-01 c)) (deftest slot-unbound.2 (let ((obj (make-instance 'slot-unbound-class-01))) (values (sunb-a obj) (sunb-b obj))) (slot-unbound-class-01 a) (slot-unbound-class-01 b)) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) (slot-name (eql 'e))) (values)) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) (slot-name (eql 'f))) (values 1 2 3)) (deftest slot-unbound.3 (slot-value (make-instance 'slot-unbound-class-01) 'e) nil) (deftest slot-unbound.4 (slot-value (make-instance 'slot-unbound-class-01) 'f) 1) (deftest slot-unbound.5 (sunb-e (make-instance 'slot-unbound-class-01)) nil) (deftest slot-unbound.6 (sunb-f (make-instance 'slot-unbound-class-01)) 1) gcl-2.7.1/ansi-tests/PaxHeaders/no-next-method.lsp0000644000000000000000000000013114542551763017037 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.745790296 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/no-next-method.lsp0000644000175000017500000000216514542551763016442 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 14:41:50 2003 ;;;; Contains: Tests of NO-NEXT-METHOD (in-package :cl-test) (defgeneric no-next-meth-gf-01 (x)) (defmethod no-next-meth-gf-01 ((x integer)) (call-next-method)) (defmethod no-next-meth-gf-01 :around ((x character)) (call-next-method)) (deftest no-next-method.1 (handler-case (progn (no-next-meth-gf-01 10) :bad) (error () :good)) :good) (deftest no-next-method.2 (handler-case (progn (no-next-meth-gf-01 ) :bad) (error () :good)) :good) ;;; (defparameter *no-next-meth-gf-02* ;;; (defgeneric no-next-meth-gf-02 (x))) ;;; ;;; (defmethod no-next-meth-gf-02 ((x integer)) ;;; (call-next-method)) ;;; ;;; (defmethod no-next-meth-gf-02 :around ((x character)) ;;; (call-next-method)) ;;; ;;; (defmethod no-next-method ((gf (eql *no-next-meth-gf-02*)) ;;; (method standard-method) ;;; &rest args) ;;; (values (copy-list args) :aborted)) ;;; ;;; (deftest no-next-method.3 ;;; (no-next-meth-gf-02 10) ;;; (10) :aborted) ;;; ;;; (deftest no-next-method.4 ;;; (no-next-meth-gf-02 #\a) ;;; (#\a) :aborted) gcl-2.7.1/ansi-tests/PaxHeaders/assoc-if-not.lsp0000644000000000000000000000013214542551762016473 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.745790296 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/assoc-if-not.lsp0000644000175000017500000001107214542551762016072 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:28:37 2003 ;;;; Contains: Tests of ASSOC-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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)) ;;; Macro env tests (deftest assoc-if-not.env.1 (macrolet ((%m (z) z)) (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d)))) (values (assoc-if-not (expand-in-current-env (%m 'oddp)) alist) (assoc-if-not (expand-in-current-env (%m #'oddp)) alist) (assoc-if-not 'oddp (expand-in-current-env (%m alist)))))) (4 . c) (4 . c) (4 . c)) (deftest assoc-if-not.env.2 (macrolet ((%m (z) z)) (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d)))) (values (assoc-if-not 'evenp alist (expand-in-current-env (%m :key)) #'1+) (assoc-if-not #'evenp alist :key (expand-in-current-env (%m '1+))) ))) (4 . c) (4 . c)) ;;; Error tests (deftest assoc-if-not.error.1 (signals-error (assoc-if-not) program-error) t) (deftest assoc-if-not.error.2 (signals-error (assoc-if-not #'null) program-error) t) (deftest assoc-if-not.error.3 (signals-error (assoc-if-not #'null nil :bad t) program-error) t) (deftest assoc-if-not.error.4 (signals-error (assoc-if-not #'null nil :key) program-error) t) (deftest assoc-if-not.error.5 (signals-error (assoc-if-not #'null nil 1 1) program-error) t) (deftest assoc-if-not.error.6 (signals-error (assoc-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest assoc-if-not.error.7 (signals-error (assoc-if-not #'cons '((a b)(c d))) program-error) t) (deftest assoc-if-not.error.8 (signals-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons) program-error) t) (deftest assoc-if-not.error.9 (signals-type-error x 'a (assoc-if-not #'car '((a b)(c d)))) t) (deftest assoc-if-not.error.10 (signals-type-error x 'a (assoc-if-not #'identity '((a b)(c d)) :key #'car)) t) (deftest assoc-if-not.error.11 (signals-error (assoc-if-not #'identity '((a . b) . c)) type-error) t) (deftest assoc-if-not.error.12 (signals-error (assoc-if-not #'identity '((a . b) :bad (c . d))) type-error) t) (deftest assoc-if-not.error.13 (signals-type-error x 'y (assoc-if-not #'identity x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/constantly.lsp0000644000000000000000000000013214542551762016367 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.745790296 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/constantly.lsp0000644000175000017500000000151014542551762015762 0ustar00cammcamm;-*- 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 (signals-error (cl:constantly) program-error) t) ;;; The next test fails in CMUCL, which has non-conformantly extended ;;; the syntax of constantly. (deftest constantly.error.2 (signals-error (cl:constantly 1 1) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/update-instance-for-different-class.lsp0000644000000000000000000000013114542551763023110 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.745790296 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/update-instance-for-different-class.lsp0000644000175000017500000000740014542551763022510 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 5 19:32:56 2003 ;;;; Contains: Tests for UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (in-package :cl-test) (defclass uifdc-class-01a () ((a :initarg :a) (b :initarg :b))) (defclass uifdc-class-01b () (a b)) (declaim (special *uifdc-01-obj*)) (defmethod update-instance-for-different-class ((from-obj uifdc-class-01a) (to-obj uifdc-class-01b) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (assert (not (eq *uifdc-01-obj* from-obj))) (assert (eq *uifdc-01-obj* to-obj)) (if (slot-boundp from-obj 'a) (setf (slot-value to-obj 'b) (slot-value from-obj 'a)) (slot-makunbound to-obj 'b)) (if (slot-boundp from-obj 'b) (setf (slot-value to-obj 'a) (slot-value from-obj 'b)) (slot-makunbound to-obj 'a)) to-obj) (deftest update-instance-for-different-class.1 (let* ((obj (make-instance 'uifdc-class-01a)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)))) (nil nil) t t (nil nil)) (deftest update-instance-for-different-class.2 (let* ((obj (make-instance 'uifdc-class-01a :a 1)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) (t nil) t t (nil t) 1) (deftest update-instance-for-different-class.3 (let* ((obj (make-instance 'uifdc-class-01a :b 1)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil t) t t (t nil) 1) (deftest update-instance-for-different-class.4 (let* ((obj (make-instance 'uifdc-class-01a :a 1 :b 2)) (new-class (find-class 'uifdc-class-01b)) (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj new-class) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (t t) t t (t t) 2 1) ;;; after method (defclass uifdc-class-02 () ((a :initform 'x :initarg :a) (b :initarg :b))) (defmethod update-instance-for-different-class :after ((from-obj uifdc-class-01a) (to-obj uifdc-class-02) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value to-obj 'a) 100) to-obj) (deftest update-instance-for-different-class.5 (let* ((obj (make-instance 'uifdc-class-01a)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) t (t nil) 100) (deftest update-instance-for-different-class.6 (let* ((obj (make-instance 'uifdc-class-01a :a 1)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) t (t nil) 100) (deftest update-instance-for-different-class.7 (let* ((obj (make-instance 'uifdc-class-01a :b 17)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) t (t t) 100 17) (deftest update-instance-for-different-class.8 (let* ((obj (make-instance 'uifdc-class-01a :b 17 :a 4)) (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) t (t t) 100 17) gcl-2.7.1/ansi-tests/PaxHeaders/search-vector.lsp0000644000000000000000000000013214542551763016737 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.745790296 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/search-vector.lsp0000644000175000017500000001226414542551763016342 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on vectors (in-package :cl-test) (compile-and-load "search-aux.lsp") (deftest search-vector.1 (let ((target *searched-vector*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail = (subseq target i) 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) ;; Order of test, test-not (deftest search-vector.17 (let ((pat #(10)) (target #(1 4 6 10 15 20))) (search pat target :test #'<)) 4) (deftest search-vector.18 (let ((pat #(10)) (target #(1 4 6 10 15 20))) (search pat target :test-not #'>=)) 4)gcl-2.7.1/ansi-tests/PaxHeaders/with-standard-io-syntax.lsp0000644000000000000000000000013214542551763020674 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.745790296 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-standard-io-syntax.lsp0000644000175000017500000000543714542551763020303 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 05:12:13 2004 ;;;; Contains: Tests of WITH-STANDARD-IO-SYNTAX (in-package :cl-test) (deftest with-standard-io-syntax.1 (let ((*package* (find-package :cl-test))) (with-standard-io-syntax (eqlt *package* (find-package "CL-USER")))) t) (deftest with-standard-io-syntax.2 (let ((*print-array* nil)) (with-standard-io-syntax *print-array*)) t) (deftest with-standard-io-syntax.3 (let ((*print-base* 8)) (with-standard-io-syntax *print-base*)) 10) (deftest with-standard-io-syntax.4 (let ((*print-case* :downcase)) (with-standard-io-syntax *print-case*)) :upcase) (deftest with-standard-io-syntax.5 (let ((*print-circle* t)) (with-standard-io-syntax *print-circle*)) nil) (deftest with-standard-io-syntax.6 (let ((*print-escape* nil)) (with-standard-io-syntax *print-escape*)) t) (deftest with-standard-io-syntax.7 (let ((*print-gensym* nil)) (with-standard-io-syntax *print-gensym*)) t) (deftest with-standard-io-syntax.8 (let ((*print-length* 100)) (with-standard-io-syntax *print-length*)) nil) (deftest with-standard-io-syntax.9 (let ((*print-level* 100)) (with-standard-io-syntax *print-level*)) nil) (deftest with-standard-io-syntax.10 (let ((*print-lines* 100)) (with-standard-io-syntax *print-lines*)) nil) (deftest with-standard-io-syntax.11 (let ((*print-miser-width* 100)) (with-standard-io-syntax *print-miser-width*)) nil) (deftest with-standard-io-syntax.12 (let ((*print-pretty* t)) (with-standard-io-syntax *print-pretty*)) nil) (deftest with-standard-io-syntax.13 (let ((*print-right-margin* 100)) (with-standard-io-syntax *print-right-margin*)) nil) (deftest with-standard-io-syntax.14 (let ((*read-base* 8)) (with-standard-io-syntax *read-base*)) 10) (deftest with-standard-io-syntax.15 (let ((*read-default-float-format 'long-float)) (with-standard-io-syntax *read-default-float-format*)) single-float) (deftest with-standard-io-syntax.16 (let ((*read-eval* nil)) (with-standard-io-syntax *read-eval*)) t) (deftest with-standard-io-syntax.17 (let ((*read-suppress* t)) (with-standard-io-syntax *read-suppress*)) nil) (deftest with-standard-io-syntax.18 (with-standard-io-syntax (notnot-mv (readtablep *readtable*))) t) (deftest with-standard-io-syntax.19 (with-standard-io-syntax) nil) (deftest with-standard-io-syntax.20 (with-standard-io-syntax (values 'a 'b 'c)) a b c) (deftest with-standard-io-syntax.21 (block done (tagbody (with-standard-io-syntax (go 10) 10 (return-from done :bad)) 10 (return-from done :good))) :good) (deftest with-standard-io-syntax.22 (let ((i 3)) (with-standard-io-syntax (incf i 10) (+ i 2))) 15) gcl-2.7.1/ansi-tests/PaxHeaders/random-aux.lsp0000644000000000000000000000013114542551763016244 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.749790313 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-aux.lsp0000644000175000017500000002336314542551763015652 0ustar00cammcamm;-*- 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) (declaim (special +standard-chars+ *cl-symbols-vector*)) (defvar *maximum-random-int-bits* (max 36 (1+ (integer-length most-positive-fixnum)))) (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)) (when (typep total 'ratio) (setf total (coerce total 'double-float))) `(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))))))) (defmacro rselect (cumulative-frequency-array &rest cases) (let ((len (length cases)) (a (gensym "A")) (max (gensym "MAX")) (r (gensym "R")) (p (gensym "P")) (done (gensym "DONE"))) (assert (> len 0)) `(let ((,a ,cumulative-frequency-array)) (assert (eql ,len (length ,a))) (let* ((,max (aref ,a ,(1- len))) (,r (random ,max))) (block ,done ,@(loop for i from 0 for c in cases collect `(let ((,p (aref ,a ,i))) (when (< ,r ,p) (return-from ,done ,c)))) (error "Should not happen!")))))) (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 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 make-random-integer () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) (rcase (6 (- (random r) (floor (/ r 2)))) (1 (- r (random (min 10 r)))) (1 (+ (floor (/ r 2)) (random (min 10 r))))))) (defun make-random-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (random r))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (if (coin) (/ n d) (- (/ n d)))))) (defun make-random-nonnegative-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (random r))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (/ n d)))) (defun make-random-positive-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (1+ (random r)))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (/ n d)))) (defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive) (assert (rationalp upper-limit)) (assert (not (minusp upper-limit))) (cond ((= upper-limit 0) 0) ((<= upper-limit 1/1000000) (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive) 1000000)) ((>= upper-limit 1000000) (* (random 1000000) (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive))) (t (assert (< 1/1000000 upper-limit 1000000)) (let ((x 0)) (loop do (setq x (* upper-limit (rational (random 1.0)))) while (or (and (not lower-inclusive) (zerop x)) (and (not upper-inclusive) (= x upper-limit))) finally (return x)))))) (defun make-random-float () (rcase (1 (random most-positive-short-float)) (1 (random most-positive-single-float)) (1 (random most-positive-double-float)) (1 (random most-positive-long-float)))) (defun make-random-symbol () (rcase (3 (random-from-seq #(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))) (2 (random-from-seq *cl-symbols-vector*)) (1 (gensym)))) (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-thing (n) (if (<= n 1) (random-leaf) (rcase (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2)))) (1 (apply #'vector (mapcar #'random-thing (random-partition (1- n) (max 10 (1- n)))))) ))) (defparameter *use-random-byte* t) (defparameter *random-readable* nil) (defun make-random-string (size-spec &key simple) (let* ((size (if (eql size-spec '*) (random 30) size-spec)) (use-random-byte nil) (etype 'character) (s (random-case (progn (setf use-random-byte *use-random-byte*) (make-string size :element-type 'character)) (progn (setf use-random-byte *use-random-byte*) (make-array size :element-type 'character :initial-element #\a)) (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char)) :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) :initial-element #\a) (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char)) :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) :initial-element #\a)))) (if (coin) (dotimes (i size) (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) (dotimes (i size) (setf (char s i) (or (and (eql etype 'character) use-random-byte (or (code-char (random (min char-code-limit (ash 1 16)))) (code-char (random 256)))) (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" (random 62)))))) (when (and (not simple) (not *random-readable*) (coin 5)) (let ((len (+ (random (1+ size)) size))) (setq s (make-random-string len)) (setq etype (array-element-type s)) (setq s (make-array size :element-type etype :displaced-to s :displaced-index-offset (random (1+ (- len size))))))) s)) (defun random-leaf () (rcase (1 (let ((k (ash 1 (1+ (random 40))))) (random-from-interval k (- k)))) (1 (random-from-seq +standard-chars+)) (1 (random-real)) (1 (make-random-string (random 20))) (1 (gensym)) (1 (make-symbol (make-random-string (random 20)))) (1 (random-from-seq *cl-symbols-vector*)))) (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)))) (defun random-partition* (n p) "Partition n into p numbers, each >= 0. Return list of numbers." (assert (<= 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)))))))))) (defun random-partition (n p) "Partition n into p numbers, each >= 1 (if possible.)" (cond ((<= n p) (make-list p :initial-element 1)) (t (mapcar #'1+ (random-partition* (- n p) p))))) ;;; Random method combination ;;; Methods in this method combination take a single method qualifier, ;;; which is a positive integer. Each method is invoked ;;; with probability proportional to its qualifier. ;;; ;;; Inside a method, a throw to the symbol FAIL causes ;;; the application to repeat. This enables methods to abort ;;; and retry the random selection process. (defun positive-integer-qualifier-p (qualifiers) (typep qualifiers '(cons (integer 1) null))) (define-method-combination randomized nil ((method-list positive-integer-qualifier-p)) (assert method-list) (let ((clauses (mapcar #'(lambda (method) (let ((weight (car (method-qualifiers method)))) `(,weight (call-method ,method)))) method-list))) `(loop (catch 'fail (return (rcase ,@clauses)))))) gcl-2.7.1/ansi-tests/PaxHeaders/copy-readtable.lsp0000644000000000000000000000013214542551762017064 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.749790313 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/copy-readtable.lsp0000644000175000017500000000215014542551762016460 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 31 07:15:35 2004 ;;;; Contains: Tests of COPY-READTABLE (in-package :cl-test) (deftest copy-readtable.1 (notnot-mv (typep (copy-readtable) 'readtable)) t) (deftest copy-readtable.2 (notnot-mv (typep (copy-readtable *readtable*) 'readtable)) t) (deftest copy-readtable.3 (notnot-mv (typep (copy-readtable *readtable* nil) 'readtable)) t) (deftest copy-readtable.4 (let ((rt (copy-readtable *readtable*))) (eql rt *readtable*)) nil) (deftest copy-readtable.5 (let ((rt (copy-readtable *readtable* nil))) (eql rt *readtable*)) nil) (deftest copy-readtable.6 (let* ((rt (copy-readtable)) (rt2 (copy-readtable *readtable* rt))) (notnot (eql rt rt2))) t) ;;; NIL as a readtable designator indicating the standard readtable (deftest copy-readtable.7 (let ((rt (copy-readtable nil))) (values (notnot rt) (notnot (readtablep rt)) (not (eql rt *readtable*)))) t t t) ;;; Error tests (deftest copy-readtable.error.1 (signals-error (copy-readtable *readtable* nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/bit-orc2.lsp0000644000000000000000000000013014542551762015610 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.749790313 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-orc2.lsp0000644000175000017500000001565314542551762015222 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:31:35 2003 ;;;; Contains: Tests of BIT-ORC2 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-orc2 (expand-in-current-env (%m #*0011)) #*0101)) #*1011) (deftest bit-orc2.21 (macrolet ((%m (z) z)) (bit-orc2 #*1010 (expand-in-current-env (%m #*1100)))) #*1011) (deftest bit-orc2.22 (macrolet ((%m (z) z)) (bit-orc2 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*10110111) (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) (deftest bit-orc2.fold.1 (flet ((%f () (declare (optimize speed (safety 0) (space 0))) (bit-orc2 #*00101 #*01011))) (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) #*10101 #*00101 #*10101) ;;; Random tests (deftest bit-orc2.random.1 (bit-random-test-fn #'bit-orc2 #'logorc2) nil) ;;; Error tests (deftest bit-orc2.error.1 (signals-error (bit-orc2) program-error) t) (deftest bit-orc2.error.2 (signals-error (bit-orc2 #*000) program-error) t) (deftest bit-orc2.error.3 (signals-error (bit-orc2 #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/define-setf-expander.lsp0000644000000000000000000000013214542551762020166 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.749790313 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/define-setf-expander.lsp0000644000175000017500000000630314542551762017566 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 17:19:35 2003 ;;;; Contains: Tests of DEFINE-SETF-EXPANDER (in-package :cl-test) (def-macro-test define-setf-expander.error.1 (define-setf-expander nonexistent-access-fn (x))) ;;; Non-error tests (defun my-car (x) (car x)) (ignore-errors (defparameter *define-setf-expander-vals.1* (multiple-value-list (define-setf-expander my-car (place &environment env) (multiple-value-bind (temps vals stores set-form get-form) (get-setf-expansion place env) (declare (ignore stores set-form)) (let ((store (gensym)) (temp (gensym))) (values `(,@temps ,temp) `(,@vals ,get-form) `(,store) `(progn (rplaca ,temp ,store) ,store) `(my-car ,temp)))))))) (deftest define-setf-expander.1 *define-setf-expander-vals.1* (my-car)) (deftest define-setf-expander.2 (let ((a (list 'x 'y))) (values (copy-list a) (my-car a) (setf (my-car a) 'z) a)) (x y) x z (z y)) (deftest define-setf-expander.3 (multiple-value-bind (temps vals stores set get) (get-setf-expansion '(my-car x)) (values (and (listp temps) (notnot (every #'symbolp temps))) (notnot (listp vals)) (and (listp stores) (= (length stores) 1) (notnot (every #'symbolp stores))) (equalt get `(my-car ,(second (second set)))))) t t t t) (deftest define-setf-expander.4 (let ((a (list (list 1)))) (values (copy-tree a) (my-car (my-car a)) (setf (my-car (my-car a)) 2) a)) ((1)) 1 2 ((2))) (defun my-assoc (key alist) (loop for pair in alist when (and (consp pair) (eql key (car pair))) return pair)) (ignore-errors (define-setf-expander my-assoc (key place &environment env) (multiple-value-bind (temps vals stores set-form get-form) (get-setf-expansion place env) (let ((store (gensym)) (key-temp (gensym)) (pair-temp (gensym)) (place-temp (gensym))) (return-from my-assoc (values `(,@temps ,key-temp ,place-temp ,pair-temp) `(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp)) `(,store) `(if (null ,pair-temp) (let ((,(car stores) (cons (cons ,key-temp ,store) ,place-temp))) ,set-form ,store) (setf (cdr ,pair-temp) ,store)) `(cdr ,pair-temp))))))) (deftest define-setf-expander.5 (let ((x nil)) (values (copy-tree x) (setf (my-assoc 'foo x) 1) (copy-tree x) (setf (my-assoc 'foo x) 2) (copy-tree x) (setf (my-assoc 'bar x) 3) (copy-tree x))) nil 1 ((foo . 1)) 2 ((foo . 2)) 3 ((bar . 3) (foo . 2))) (deftest define-setf-expander.6 (let ((n (gensym)) (doc "D-S-EX.6")) (assert (null (documentation n 'setf))) (assert (eql (eval `(define-setf-expander ,n () ,doc (values nil nil nil nil nil))) n)) (or (documentation n 'setf) doc)) "D-S-EX.6") (deftest define-setf-expander.7 (let ((n (gensym)) (doc "D-S-EX.7")) (assert (null (documentation n 'setf))) (assert (eql (eval `(define-setf-expander ,n () (values nil nil nil nil nil))) n)) (assert (null (documentation n 'setf))) (values (setf (documentation n 'setf) doc) (or (documentation n 'setf) doc))) "D-S-EX.7" "D-S-EX.7") gcl-2.7.1/ansi-tests/PaxHeaders/loop.lsp0000644000000000000000000000013214542551763015143 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.749790313 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop.lsp0000644000175000017500000000306214542551763014542 0ustar00cammcamm;-*- 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)) ;;; Loop errors (def-macro-test loop.error.1 (loop)) (deftest loop-finish.error.1 (block done (loop for i from 1 to 10 do (macrolet ((%m (&environment env) (let ((mfn (macro-function 'loop-finish env))) (cond ((not mfn) '(return-from done :fail1)) ((not (eval `(signals-error (funcall ,mfn) program-error))) '(return-from done :fail2)) ((not (eval `(signals-error (funcall ,mfn '(loop-finish)) program-error))) '(return-from done :fail3)) ((not (eval `(signals-error (funcall ,mfn '(loop-finish) nil nil) program-error))) '(return-from done :fail4)) (t '(return-from done :good)))))) (%m)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/make-symbol.lsp0000644000000000000000000000013214542551763016412 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.749790313 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-symbol.lsp0000644000175000017500000000570614542551763016020 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:45:21 2003 ;;;; Contains: Tests of MAKE-SYMBOL (in-package :cl-test) (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.11 :notes (:nil-vectors-are-strings) (symbol-name (make-symbol (make-array '(0) :element-type nil))) "") (deftest make-symbol.12 (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) :element-type 'base-char)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.13 (let* ((name (make-array '(6) :initial-contents '(#\A #\B #\C #\D #\E #\F) :element-type 'character :fill-pointer 4)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.14 (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) :adjustable t :element-type 'character)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.15 (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) :element-type 'character)) (name (make-array '(4) :element-type 'character :displaced-to name0 :displaced-index-offset 1)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (deftest make-symbol.16 (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) :element-type 'base-char)) (name (make-array '(4) :element-type 'base-char :displaced-to name0 :displaced-index-offset 1)) (s (make-symbol name)) (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) nil t) (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 (check-type-error #'make-symbol #'stringp) nil) (deftest make-symbol.error.9 (signals-error (make-symbol) program-error) t) (deftest make-symbol.error.10 (signals-error (make-symbol "a" "a") program-error) t) (deftest make-symbol.error.11 (signals-type-error x '(#\a #\b #\c) (make-symbol x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/max.lsp0000644000000000000000000000013114542551763014756 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.749790313 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/max.lsp0000644000175000017500000001017514542551763014361 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 3 15:55:17 2003 ;;;; Contains: Tests of MAX (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest max.error.1 (signals-error (max) program-error) t) (deftest max.error.2 (check-type-error #'max #'realp) nil) (deftest max.error.3 (check-type-error #'(lambda (x) (max 0 x)) #'realp) nil) ;;; Non-error tests (deftest max.1 (loop for n in *reals* when (or (not (eql (max n) n)) (not (eql (max n n) n)) (not (eql (max n n n) n)) (not (eql (apply #'max (make-list (min 256 (1- call-arguments-limit)) :initial-element n)) n))) collect n) nil) (deftest max.2 (max.2-fn) nil) (deftest max.3 (loop for x = (- (random 60000) 30000) for y = (- (random 60000) 30000) for m = (max x y) for m2 = (if (>= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest max.4 (loop for x = (- (random 6000000) 3000000) for y = (- (random 6000000) 3000000) for m = (max x y) for m2 = (if (>= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest max.5 (loop for x = (- (random 1000000000000) 500000000000) for y = (- (random 1000000000000) 500000000000) for m = (max x y) for m2 = (if (>= x y) x y) repeat 1000 unless (eql m m2) collect (list x y m m2)) nil) (deftest max.6 (let ((m (max 2 1.0s0))) (or (eqlt m 2) (eqlt m 2.0s0))) t) (deftest max.7 (max 0 1.0s0) 1.0s0) (deftest max.8 (let ((m (max 2 1.0f0))) (or (eqlt m 2) (eqlt m 2.0f0))) t) (deftest max.9 (max 0 1.0f0) 1.0f0) (deftest max.10 (let ((m (max 2 1.0d0))) (or (eqlt m 2) (eqlt m 2.0d0))) t) (deftest max.11 (max 0 1.0d0) 1.0d0) (deftest max.12 (let ((m (max 2 1.0l0))) (or (eqlt m 2) (eqlt m 2.0l0))) t) (deftest max.13 (max 0 1.0l0) 1.0l0) (deftest max.15 (let ((m (max 1.0s0 0.0f0))) (or (eqlt m 1.0s0) (eqlt m 1.0f0))) t) (deftest max.16 (max 0.0s0 1.0f0) 1.0f0) (deftest max.17 (let ((m (max 1.0s0 0.0d0))) (or (eqlt m 1.0s0) (eqlt m 1.0d0))) t) (deftest max.18 (max 0.0s0 1.0d0) 1.0d0) (deftest max.19 (let ((m (max 1.0s0 0.0l0))) (or (eqlt m 1.0s0) (eqlt m 1.0l0))) t) (deftest max.20 (max 0.0s0 1.0l0) 1.0l0) (deftest max.21 (let ((m (max 1.0f0 0.0d0))) (or (eqlt m 1.0f0) (eqlt m 1.0d0))) t) (deftest max.22 (max 0.0f0 1.0d0) 1.0d0) (deftest max.23 (let ((m (max 1.0f0 0.0l0))) (or (eqlt m 1.0f0) (eqlt m 1.0l0))) t) (deftest max.24 (max 0.0f0 1.0l0) 1.0l0) (deftest max.25 (let ((m (max 1.0d0 0.0l0))) (or (eqlt m 1.0d0) (eqlt m 1.0l0))) t) (deftest max.26 (max 0.0d0 1.0l0) 1.0l0) (deftest max.27 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for x = (make-list i :initial-element 0) do (setf (elt x (random i)) 1) unless (eql (apply #'max x) 1) collect x) nil) (deftest max.28 (let ((m (max 1/3 0.2s0))) (or (eqlt m 1/3) (eqlt m (float 1/3 0.2s0)))) t) (deftest max.29 (let ((m (max 1.0s0 3 2.0f0))) (or (eqlt m 3) (eqlt m 3.0f0))) t) (deftest max.30 (let ((m (max 1.0d0 3 2.0f0))) (or (eqlt m 3) (eqlt m 3.0d0))) t) (deftest max.31 (let ((m (max 1.0s0 3 2.0l0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.32 (let ((m (max 1.0l0 3 2.0s0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.33 (let ((m (max 1.0d0 3 2.0l0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.34 (let ((m (max 1.0l0 3 2.0d0))) (or (eqlt m 3) (eqlt m 3.0l0))) t) (deftest max.order.1 (let ((i 0) x y) (values (max (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20)) i x y)) 20 2 1 2) (deftest max.order.2 (let ((i 0) x y z) (values (max (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i x y z)) 30 3 1 2 3) (deftest max.order.3 (let ((i 0) u v w x y z) (values (max (progn (setf u (incf i)) 10) (progn (setf v (incf i)) 20) (progn (setf w (incf i)) 30) (progn (setf x (incf i)) 10) (progn (setf y (incf i)) 20) (progn (setf z (incf i)) 30)) i u v w x y z)) 30 6 1 2 3 4 5 6) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-cons.lsp0000644000000000000000000000013114542551763017004 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.749790313 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-cons.lsp0000644000175000017500000002600514542551763016406 0ustar00cammcamm;-*- 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) (compile-and-load "types-aux.lsp") ;;; 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) ;;; Test case that came up in SBCL (deftest subtypep.cons.21 (check-all-subtypep '(cons integer single-float) '(or (cons fixnum single-float) (cons bignum single-float))) nil) (deftest subtypep.cons.22 (check-all-subtypep '(cons single-float integer) '(or (cons single-float fixnum) (cons single-float bignum))) nil) ;;; More test cases from SBCL, CMUCL, culled from random test failures (deftest subtype.cons.23 (let ((t1 '(cons t (cons (not long-float) symbol))) (t2 '(not (cons symbol (cons integer integer))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.24 (let ((t1 '(cons (eql 3671) (cons short-float (eql -663423073525)))) (t2 '(not (cons t (cons (not complex) (cons integer t)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.25 (let ((t1 '(cons t (cons (not long-float) (integer 44745969 61634129)))) (t2 '(not (cons (eql -3) (cons short-float (cons t float)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.26 (let ((t1 '(cons integer (cons single-float (cons t t)))) (t2 '(cons t (cons (not complex) (not (eql 8)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.27 (let ((t1 '(cons (not (integer -27 30)) (cons rational (cons integer integer)))) (t2 '(not (cons integer (cons integer (eql 378132631)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.28 (let ((t1 '(cons (integer -1696888 -1460338) (cons single-float symbol))) (t2 '(not (cons (not (integer -14 20)) (cons (not integer) cons))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtypep.cons.29 (let ((t2 '(or (not (cons unsigned-byte cons)) (not (cons (integer -6 22) rational))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.30 (let ((t1 '(not (cons t (cons t (cons cons t))))) (t2 '(or (or (cons (cons t integer) t) (not (cons t (cons t cons)))) (not (cons (cons (eql -27111309) t) (cons t (eql 1140730))))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtypep.cons.31 (let ((t2 '(or (not (cons (or (cons t ratio) (cons short-float t)) (cons (cons (eql -7418623) (integer -9 53)) (cons cons t)))) (not (cons (cons t (eql -265039)) (cons (cons t cons) t)))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.32 (let ((t2 '(cons t (or (not (cons integer (eql 0))) (not (cons (or float (eql 0)) cons)))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.33 (let ((t2 '(or (not (cons (cons t cons) (cons t (cons unsigned-byte t)))) (not (cons (cons integer t) (cons t (cons cons t))))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.34 (let ((t2 '(or (not (cons (or (eql 0) ratio) (not cons))) (not (cons integer cons))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.35 (notnot-mv (subtypep '(cons nil t) 'float)) t t) (deftest subtypep.cons.36 (notnot-mv (subtypep '(cons t nil) 'symbol)) t t) (deftest subtypep.cons.37 (notnot-mv (subtypep '(cons nil nil) 'real)) t t) (deftest subtypep.cons.38 (let ((t1 '(cons t (complex (real -32 0)))) (t2 `(not (cons t (complex (integer * -500)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) ;;; From GCL (deftest subtypep.cons.39 (values (subtypep t '(and (not (cons cons (cons cons t))) (not (cons t cons))))) nil) (deftest subtypep.cons.40 (let ((type1 '(cons (eql 0) cons)) (type2 '(cons unsigned-byte symbol))) (values (subtypep* type1 type2) (subtypep* `(not ,type2) `(not ,type1)))) nil nil) ;;; From sbcl 0.9.5.31 (deftest subtypep.cons.41 (let ((type1 '(cons t (complex (real -10 -4)))) (type2 '(not (cons t (complex (integer -200 -100)))))) (multiple-value-bind (sub1 success1) (subtypep* type1 type2) (multiple-value-bind (sub2 success2) (subtypep* `(not ,type2) `(not ,type1)) (if (and success1 success2 (not (eq sub1 sub2))) (values sub1 sub2) nil)))) nil) (deftest subtypep.cons.42 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) (integer -234496 215373)) integer)) (t2 '(cons (cons (cons integer integer) (integer -234496 215373)) t))) (values (subtypep `(not ,t2) `(not ,t1)))) nil) ;;;; From sbcl 0.9.6.57 (deftest subtypep.cons.43 (let* ((n -3.926510009989861d7) (t1 '(not (cons float t))) (t2 `(or (not (cons (eql 0) (real ,n ,n))) (not (cons t (eql 0)))))) (multiple-value-bind (sub1 good1) (subtypep* t1 t2) (multiple-value-bind (sub2 good2) (subtypep* `(not ,t2) `(not ,t1)) (or (not good1) (not good2) (and sub1 sub2) (and (not sub1) (not sub2)))))) t) #+gcl (deftest subtypep.cons.44 (check-all-subtypep 'si::proper-list 'list) nil) #+gcl (deftest subtypep.cons.45 (check-all-not-subtypep 'si::proper-list nil) nil) #+gcl (deftest subtypep.cons.46 (check-all-not-subtypep 'list 'si::proper-list) nil) #+gcl (deftest subtypep.cons.47 (check-all-subtypep '(cons t (cons t null)) 'si::proper-list) nil) #+gcl (deftest subtypep.cons.48 (check-all-subtypep '(cons t (cons t si::proper-list)) 'si::proper-list) nil) #+gcl (deftest subtypep.cons.49 (check-all-not-subtypep 'si::proper-list '(cons t (cons t si::proper-list))) nil) #+gcl (deftest subtypep.cons.50 (check-all-not-subtypep '(cons t (cons t (not si::proper-list))) 'si::proper-list) nil) #+gcl (deftest subtypep.cons.51 (check-all-not-subtypep '(cons t (cons t (not si::proper-list))) nil) nil) #+gcl (deftest subtypep.cons.52 (check-all-not-subtypep 'si::proper-list '(cons t (cons t (not si::proper-list)))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/ctypecase.lsp0000644000000000000000000000013214542551762016151 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.749790313 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ctypecase.lsp0000644000175000017500000000533314542551762015553 0ustar00cammcamm;-*- 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 (check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp) nil) (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) (assert (eql (type-error-datum c) 1)) (assert (not (typep 1 (type-error-expected-type c)))) (store-value 'a c)))) (ctypecase x (symbol :good) (float :bad))) x)) :good a) ;;; (deftest ctypecase.error.1 ;;; (signals-error (ctypecase) program-error) ;;; t) (deftest ctypecase.13 (let ((x 'a)) (ctypecase x (number 'bad) (#.(find-class 'symbol nil) 'good))) good) (deftest ctypecase.14 (block done (tagbody (let ((x 'a)) (ctypecase x (symbol (go 10) 10 (return-from done 'bad)))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest ctypecase.15 (macrolet ((%m (z) z)) (ctypecase (expand-in-current-env (%m :foo)) (integer :bad1) (keyword :good) (symbol :bad2))) :good) (deftest ctypecase.16 (macrolet ((%m (z) z)) (ctypecase :foo (integer (expand-in-current-env (%m :bad1))) (keyword (expand-in-current-env (%m :good))) (symbol (expand-in-current-env (%m :bad2))))) :good) (deftest ctypecase.error.1 (signals-error (funcall (macro-function 'ctypecase)) program-error) t) (deftest ctypecase.error.2 (signals-error (funcall (macro-function 'ctypecase) '(ctypecase t)) program-error) t) (deftest ctypecase.error.3 (signals-error (funcall (macro-function 'ctypecase) '(ctypecase t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/rassoc-if-not.lsp0000644000000000000000000000013114542551763016655 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.749790313 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rassoc-if-not.lsp0000644000175000017500000000746714542551763016272 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:35:27 2003 ;;;; Contains: Tests of RASSOC-IF-NOT (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (rassoc-if-not) program-error) t) (deftest rassoc-if-not.error.2 (signals-error (rassoc-if-not #'null) program-error) t) (deftest rassoc-if-not.error.3 (signals-error (rassoc-if-not #'null nil :bad t) program-error) t) (deftest rassoc-if-not.error.4 (signals-error (rassoc-if-not #'null nil :key) program-error) t) (deftest rassoc-if-not.error.5 (signals-error (rassoc-if-not #'null nil 1 1) program-error) t) (deftest rassoc-if-not.error.6 (signals-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest rassoc-if-not.error.7 (signals-error (rassoc-if-not #'cons '((a . b)(c . d))) program-error) t) (deftest rassoc-if-not.error.8 (signals-error (rassoc-if-not #'car '((a . b)(c . d))) type-error) t) (deftest rassoc-if-not.error.9 (signals-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons) program-error) t) (deftest rassoc-if-not.error.10 (signals-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car) type-error) t) (deftest rassoc-if-not.error.11 (signals-error (rassoc-if-not #'identity '((a . b) . c)) type-error) t) (deftest rassoc-if-not.error.12 (check-type-error #'(lambda (x) (rassoc-if-not #'identity x)) #'listp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/syntax-tokens.lsp0000644000000000000000000000013114542551763017020 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.749790313 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/syntax-tokens.lsp0000644000175000017500000000631114542551763016420 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 14 07:43:24 2005 ;;;; Contains: Tests of reading of tokens (in-package :cl-test) (compile-and-load "reader-aux.lsp") ;; Erroneous numbers (def-syntax-test syntax.number-token.error.1 (signals-error (read-from-string "1/0") reader-error) t) #| (def-syntax-test syntax.number-token.error.2 (loop for f in (list most-positive-short-float most-positive-single-float most-positive-double-float most-positive-long-float) for c across "sfdl" for r = (float-radix f) for x = (nth-value 1 (decode-float f)) for n = (1+ (ceiling (* (log r 10) x))) for s = (format nil "1.0~C~D" c n) for vals = (multiple-value-list (eval `(signals-error (read-from-string ,s) reader-error))) unless (equal vals '(t)) collect (list f c r x n s vals)) nil) |# (def-syntax-test syntax.number-token.3 (loop for tp in '(short-float single-float double-float long-float) for c across "sfdl" for s = (concatenate 'string "1.0" (make-string 1000 :initial-element #\0) "1" (string c) "0") for n = (read-from-string s) unless (and (typep n tp) (<= 1 n) (< n 2)) collect (list c tp s n)) nil) (def-syntax-test syntax.number-token.4 (loop for type in '(short-float single-float double-float long-float) nconc (let* ((*read-default-float-format* type) (s (concatenate 'string "1." (make-string 1000 :initial-element #\0) "1")) (n (read-from-string s))) (unless (and (typep n type) (<= 1 n) (< n 2)) (list (list type s n))))) nil) ;;; Dot tokens (def-syntax-test syntax.dot-token.1 (read-from-string "\\.") |.| 2) (def-syntax-test syntax.dot-token.2 (read-from-string ".\\.") |..| 3) (def-syntax-test syntax.dot-token.3 (read-from-string "\\..") |..| 3) (def-syntax-test syntax.dot-token.4 (read-from-string "..\\.") |...| 4) (def-syntax-test syntax.dot-token.5 (read-from-string ".\\..") |...| 4) (def-syntax-test syntax.dot-token.6 (read-from-string "\\...") |...| 4) (def-syntax-test syntax.dot-token.7 (read-from-string ".||") |.| 3) (def-syntax-test syntax.dot-token.8 (read-from-string "..||") |..| 4) (def-syntax-test syntax.dot-error.1 (signals-error (read-from-string ".") reader-error) t) (def-syntax-test syntax.dot-error.2 (signals-error (read-from-string "..") reader-error) t) (def-syntax-test syntax.dot-error.3 (signals-error (read-from-string "...") reader-error) t) (def-syntax-test syntax.dot-error.4 (signals-error (read-from-string "( . 1)") reader-error) t) (def-syntax-test syntax.dot-error.5 (signals-error (read-from-string "(1 ..)") reader-error) t) (def-syntax-test syntax.dot-error.6 (signals-error (read-from-string "(1 .. 2)") reader-error) t) (def-syntax-test syntax.dot-error.7 (signals-error (read-from-string "#(1 . 2)") reader-error) t) ;;; right paren (def-syntax-test syntax.right-paren-error.1 (signals-error (read-from-string ")") reader-error) t) (def-syntax-test syntax.comma-error.1 (signals-error (read-from-string ",") reader-error) t) (def-syntax-test syntax.comma-error.2 (signals-error (read-from-string ",1") reader-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/logical-pathname.lsp0000644000000000000000000000013214542551763017377 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.753790331 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logical-pathname.lsp0000644000175000017500000000453314542551763017002 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/fdefinition.lsp0000644000000000000000000000013214542551762016467 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.753790331 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fdefinition.lsp0000644000175000017500000000422414542551762016067 0ustar00cammcamm;-*- 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 (signals-error (fdefinition) program-error) t) (deftest fdefinition.error.2 (signals-error (fdefinition 'cons nil) program-error) t) (deftest fdefinition.error.3 (let ((v (gensym))) (eval `(signals-error (fdefinition ',v) undefined-function :name ,v))) t) (deftest fdefinition.error.4 (check-type-error #'fdefinition #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) nil) ;;; (deftest fdefinition.error.5 ;;; (let ((fn `(setf ,(gensym)))) ;;; (eval `(signals-error (fdefinition ',fn) undefined-function ;;; :name ,fn))) ;;; t) (deftest fdefinition.error.6 (signals-error (locally (fdefinition 10) t) type-error) t) (deftest fdefinition.error.7 (check-type-error #'fdefinition (constantly nil) '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) nil) (deftest fdefinition.error.8 (loop for x in *mini-universe* unless (symbolp x) nconc (handler-case (list x (fdefinition `(setf ,x))) (type-error (c) (assert (not (typep (type-error-datum c) (type-error-expected-type c)))) nil) (error (c) (list (list x c))))) nil) ;;; 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.7.1/ansi-tests/PaxHeaders/defsetf.lsp0000644000000000000000000000013214542551762015611 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.753790331 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defsetf.lsp0000644000175000017500000000622714542551762015216 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 17:18:01 2003 ;;;; Contains: Tests of DEFSETF (in-package :cl-test) ;;; Need to add non-error tests (def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn nonexistent-update-fn)) ;;; Short form (defun defsetf.1-accessor (x) (cadr x)) (defun defsetf.1-accessor-settor (x val) (setf (cadr x) val)) (deftest defsetf.1 (progn (let ((vals (multiple-value-list (defsetf defsetf.1-accessor defsetf.1-accessor-settor)))) (assert (equal vals '(defsetf.1-accessor)) () "Return values are ~A~%" vals)) (eval '(let ((x (list 1 2 3))) (values (setf (defsetf.1-accessor x) 4) x)))) 4 (1 4 3)) ;;; Use a macro instead of a function for updatefn (defun defsetf.2-accessor (x) (cadr x)) (defmacro defsetf.2-accessor-settor (x val) `(setf (cadr ,x) ,val)) (defparameter *defsetf.2-vals* (multiple-value-list (defsetf defsetf.2-accessor defsetf.2-accessor-settor))) (deftest defsetf.2a *defsetf.2-vals* (defsetf.2-accessor)) (deftest defsetf.2b (let ((x (list 1 2 3))) (values (setf (defsetf.2-accessor x) 4) x)) 4 (1 4 3)) ;;; Documentation string (defun defsetf.3-accessor (x) (cadr x)) (defun defsetf.3-accessor-settor (x val) (setf (cadr x) val)) (defparameter *defsetf.3-vals* (multiple-value-list (defsetf defsetf.3-accessor defsetf.3-accessor-settor "A doc string"))) (deftest defsetf.3a *defsetf.3-vals* (defsetf.3-accessor)) (deftest defsetf.3b (let ((doc (documentation 'defsetf.3-accessor 'setf))) (or (null doc) (equalt doc "A doc string"))) t) (deftest defsetf.3c (let ((x (list 1 2 3))) (values (setf (defsetf.3-accessor x) 4) x)) 4 (1 4 3)) ;;; Long form of defsetf (defun defsetf.4-accessor (n seq) (elt seq n)) (defparameter *defsetf.4-vals* (multiple-value-list (defsetf defsetf.4-accessor (n seq) (val) (declare) "Doc string for defsetf.4-accessor setf" `(setf (elt ,seq ,n) ,val)))) (deftest defsetf.4a *defsetf.4-vals* (defsetf.4-accessor)) (deftest defsetf.4b (let ((doc (documentation 'defsetf.4-accessor 'setf))) (or (null doc) (equalt doc "Doc string for defsetf.4-accessor setf"))) t) (deftest defsetf.4c (let ((x (list 1 2 3 4)) (i 0) (j nil) (k nil)) (values (setf (defsetf.4-accessor (progn (setf j (incf i)) 2) (progn (setf k (incf i)) x)) (progn (incf i) 'a)) x i j k)) a (1 2 a 4) 3 1 2) ;;; Test that there's a block around the forms in long form defsetf (defun defsetf.5-accessor (x) (car x)) (defsetf defsetf.5-accessor (y) (val) (return-from defsetf.5-accessor `(setf (car ,y) ,val))) (deftest defsetf.5a (let ((x (cons 'a 'b))) (values (setf (defsetf.5-accessor x) 'c) x)) c (c . b)) ;;; Test that the defsetf expansion function is defined in the same ;;; lexical environment that the defsetf appears in (defun defsetf.6-accessor (x) (car x)) (let ((z 'car)) (defsetf defsetf.6-accessor (y) (val) `(setf (,z ,y) ,val))) (deftest defsetf.6a (let ((x (cons 'a 'b))) (values (setf (defsetf.6-accessor x) 'c) x)) c (c . b)) gcl-2.7.1/ansi-tests/PaxHeaders/string-trim.lsp0000644000000000000000000000013214542551763016451 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.753790331 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-trim.lsp0000644000175000017500000001202714542551763016051 0ustar00cammcamm;-*- 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.8a (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'base-char :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.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'base-char :adjustable t :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.20 :notes (:nil-vectors-are-strings) (string-trim "abcd" (make-array '(0) :element-type nil)) "") (deftest string-trim.21 :notes (:nil-vectors-are-strings) (string-trim (make-array '(0) :element-type nil) "abcd") "abcd") (deftest string-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'base-char :adjustable t))) (values (string-trim "ab" s) s)) "cae" "abcaeb") (deftest string-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" :element-type 'character :adjustable t))) (values (string-trim "ab" s) s)) "cae" "abcaeb") (deftest string-trim.24 (let* ((etype 'base-char) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-trim "ab" s) s s0)) "c" "bca" "abcaeb") (deftest string-trim.25 (let* ((etype 'character) (s0 (make-array '(6) :initial-contents "abcaeb" :element-type etype)) (s (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1))) (values (string-trim "ab" s) s s0)) "c" "bca" "abcaeb") (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) (def-fold-test string-trim.fold.1 (string-trim " " " abcd ")) ;;; Error cases (deftest string-trim.error.1 (signals-error (string-trim) program-error) t) (deftest string-trim.error.2 (signals-error (string-trim "abc") program-error) t) (deftest string-trim.error.3 (signals-error (string-trim "abc" "abcdddabc" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/hash-table-p.lsp0000644000000000000000000000013114542551762016435 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.753790331 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table-p.lsp0000644000175000017500000000153114542551762016034 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 16 21:58:37 2003 ;;;; Contains: Tests for HASH-TABLE-P (in-package :cl-test) (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 (check-type-predicate #'hash-table-p 'hash-table) nil) (deftest hash-table-p.3 (let ((i 0)) (values (hash-table-p (incf i)) i)) nil 1) (deftest hash-table-p.4 (hash-table-p t) nil) (deftest hash-table-p.5 (notnot-mv (hash-table-p (make-hash-table))) t) (deftest hash-table-p.error.1 (signals-error (hash-table-p) program-error) t) (deftest hash-table-p.error.2 (signals-error (let ((h (make-hash-table))) (hash-table-p h nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/truncate-aux.lsp0000644000000000000000000000013114542551763016611 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.753790331 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/truncate-aux.lsp0000644000175000017500000000543314542551763016215 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 05:15:17 2003 ;;;; Contains: Aux. functions associated with tests of TRUNCATE (in-package :cl-test) (defun truncate.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (if (>= n 0) (< -1 r d) (< (- d) r 1))) collect (list n d q r n2))) (defun truncate.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= 0 r) (< r d) (= n n2)) collect (list n d q r n2))) (defun truncate.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (truncate n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (if (>= n 0) (and (<= 0 r) (< r 1)) (and (< -1 r) (<= r 0))) ) collect (list n q r n2))) (defun truncate.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (truncate n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (if (>= n 0) (and (<= 0 r) (< r 1)) (and (< -1 r) (<= r 0))) ) collect (list n q r n2))) (defun truncate.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (if (> n 0) (and (<= 0 r) (< r (- d))) (and (>= 0 r) (> r d))) (= n n2)) collect (list n q d r n2))) (defun truncate.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (truncate n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (if (> n 0) (and (<= 0 r) (< r (- d))) (and (>= 0 r) (> r d))) (= n n2)) collect (list n q d r n2))) gcl-2.7.1/ansi-tests/PaxHeaders/compiler-macros.lsp0000644000000000000000000000013014542551762017263 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.753790331 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compiler-macros.lsp0000644000175000017500000000030114542551762016655 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/print-floats.lsp0000644000000000000000000000013114542551763016613 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.753790331 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-floats.lsp0000644000175000017500000003102214542551763016210 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Mar 2 07:32:57 2004 ;;;; Contains: Tests of printing of floating point numbers (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.short-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'short-float)) (loop for i from -4000 to 4000 for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.short-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'short-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-short-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'short-float type) nconc (list c (char-downcase c)))) (deftest print.short-float.3 (let ((chars *possible-short-float-exponent-markers*)) (loop for type in '(single-float double-float long-float) nconc (and (not (subtypep 'short-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.short-float.4 (let ((chars *possible-short-float-exponent-markers*)) (loop for type in '(single-float double-float long-float) nconc (and (not (subtypep 'short-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0s0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.short-float.random (let ((lower-bound (if (< (log least-positive-short-float 10) -100) (expt 0.1s0 100) least-positive-short-float)) (upper-bound (/ (if (> (log most-positive-short-float 10) 100) (expt 10.0s0 100) most-positive-short-float) 10))) (loop for sf = lower-bound then (* 10 sf) while (< sf upper-bound) nconc (loop for x = (handler-case (random sf) (arithmetic-error (c) 0.0s0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil) ;;; single floats (deftest print.single-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'single-float)) (loop for i from -4000 to 4000 for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.single-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'single-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-single-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'single-float type) nconc (list c (char-downcase c)))) (deftest print.single-float.3 (let ((chars *possible-single-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'single-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.single-float.4 (let ((chars *possible-single-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'single-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0f0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.single-float.random (let ((lower-bound (if (< (log least-positive-single-float 10) -100) (expt 0.1f0 100) least-positive-single-float)) (upper-bound (/ (if (> (log most-positive-single-float 10) 100) (expt 10.0f0 100) most-positive-single-float) 10))) (loop for f = lower-bound then (* 10 f) while (< f upper-bound) nconc (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0f0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil) ;;; double float (deftest print.double-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'double-float)) (loop for i from -4000 to 4000 for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.double-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'double-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-double-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'double-float type) nconc (list c (char-downcase c)))) (deftest print.double-float.3 (let ((chars *possible-double-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'double-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.double-float.4 (let ((chars *possible-double-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'double-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0d0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.double-float.random (let ((lower-bound (if (< (log least-positive-double-float 10) -100) (expt 0.1d0 100) least-positive-double-float)) (upper-bound (/ (if (> (log most-positive-double-float 10) 100) (expt 10.0d0 100) most-positive-double-float) 10))) (loop for f = lower-bound then (* 10 f) while (< f upper-bound) nconc (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0d0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil) ;;; long float (deftest print.long-float.1 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'long-float)) (loop for i from -4000 to 4000 for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) unless (equalp s1 s2) collect (list i f s1 s2)))) nil) (deftest print.long-float.2 (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* 'long-float)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (equalp s1 s2)) collect (list i f s1 s2)))) nil) (defparameter *possible-long-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) for c across "SFDL" when (subtypep 'long-float type) nconc (list c (char-downcase c)))) (deftest print.long-float.3 (let ((chars *possible-long-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'long-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i from -4000 to 4000 for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) unless (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars)) collect (list type i f s1 s2))))))) nil) (deftest print.long-float.4 (let ((chars *possible-long-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) nconc (and (not (subtypep 'long-float type)) (with-standard-io-syntax (let ((*print-readably* nil) (*read-default-float-format* type)) (loop for i = (- (random 20000000) 10000000) for f = (float i 0.0l0) for s1 = (with-output-to-string (s) (prin1 f s)) for len1 = (length s1) for s2 = (format nil "~A.0" i) repeat 10000 unless (or (/= i (rational f)) ;; not enough bits ;; (> (nth-value 1 (integer-decode-float f)) 0) (and (> len1 4) (string-equal s1 s2 :start1 0 :end1 (- len1 2)) (eql (char s1 (- len1 1)) #\0) (member (char s1 (- len1 2)) chars))) collect (list type i f s1 s2))))))) nil) (deftest print.long-float.random (let ((lower-bound (if (< (log least-positive-long-float 10) -100) (expt 0.1l0 100) least-positive-long-float)) (upper-bound (/ (if (> (log most-positive-long-float 10) 100) (expt 10.0l0 100) most-positive-long-float) 10))) (loop for f = lower-bound then (* 10 f) while (< f upper-bound) nconc (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0l0)) for y = (if (coin) (- x) x) repeat 10 nconc (randomly-check-readability y)))) nil)gcl-2.7.1/ansi-tests/PaxHeaders/hash-table-rehash-threshold.lsp0000644000000000000000000000013114542551762021442 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.753790331 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table-rehash-threshold.lsp0000644000175000017500000000210114542551762021033 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:52:52 2003 ;;;; Contains: Tests of HASH-TABLE-REHASH-THRESHOLD (in-package :cl-test) (deftest hash-table-rehash-threshold.1 (typep* (hash-table-rehash-threshold (make-hash-table)) '(real 0 1)) t) (deftest hash-table-rehash-threshold.2 (loop for test in '(eq eql equal equalp) unless (typep* (hash-table-rehash-threshold (make-hash-table :test test)) '(real 0 1)) collect test) nil) (deftest hash-table-rehash-threshold.3 (loop for test in '(eq eql equal equalp) for fn = (symbol-function test) unless (typep* (hash-table-rehash-threshold (make-hash-table :test fn)) '(real 0 1)) collect test) nil) (deftest hash-table-rehash-threshold.error.1 (signals-error (hash-table-rehash-threshold) program-error) t) (deftest hash-table-rehash-threshold.error.2 (signals-error (hash-table-rehash-threshold (make-hash-table) nil) program-error) t) (deftest hash-table-rehash-threshold.error.3 (check-type-error #'hash-table-rehash-threshold #'hash-table-p) nil) gcl-2.7.1/ansi-tests/PaxHeaders/hash-table-test.lsp0000644000000000000000000000013114542551762017155 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.753790331 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table-test.lsp0000644000175000017500000000207014542551762016553 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 05:56:22 2003 ;;;; Contains: Tests for HASH-TABLE-TEST (in-package :cl-test) (deftest hash-table-test.1 (hash-table-test (make-hash-table)) eql) (deftest hash-table-test.2 (loop for test in '(eq eql equal equalp) unless (eq (hash-table-test (make-hash-table :test test)) test) collect test) nil) (deftest hash-table-test.3 (loop for test in '(eq eql equal equalp) unless (eq (hash-table-test (make-hash-table :test (symbol-function test))) test) collect test) nil) (deftest hash-table-test.4 (loop for test in '(eq eql equal equalp) unless (eq (hash-table-test (make-hash-table :test (eval `(function ,test)))) test) collect test) nil) ;;; Error cases (deftest hash-table-test.error.1 (signals-error (hash-table-test) program-error) t) (deftest hash-table-test.error.2 (signals-error (hash-table-test (make-hash-table) nil) program-error) t) (deftest hash-table-test.error.3 (check-type-error #'hash-table-test #'hash-table-p) nil) gcl-2.7.1/ansi-tests/PaxHeaders/lambda-list-keywords.lsp0000644000000000000000000000013114542551762020226 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.753790331 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/lambda-list-keywords.lsp0000644000175000017500000000205514542551762017627 0ustar00cammcamm;-*- 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) (and (symbolp sym) (let ((name (symbol-name sym))) (and (> (length name) 0) (eql (aref name 0) #\&))))) lambda-list-keywords) nil) gcl-2.7.1/ansi-tests/PaxHeaders/atom.lsp0000644000000000000000000000013214542551762015131 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.753790331 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/atom.lsp0000644000175000017500000000114314542551762014526 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:28:09 2003 ;;;; Contains: Tests of ATOM (in-package :cl-test) ; (compile-and-load "cons-aux.lsp") (deftest atom.1 (loop for x in *universe* unless (if (atom x) (not (consp x)) (consp x)) collect x) nil) (deftest atom.2 (macrolet ((%m (z) z)) (atom (expand-in-current-env (%m 0)))) t) (deftest atom.order.1 (let ((i 0)) (values (atom (progn (incf i) '(a b))) i)) nil 1) (deftest atom.error.1 (signals-error (atom) program-error) t) (deftest atom.error.2 (signals-error (atom 'a 'b) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-two-way-stream.lsp0000644000000000000000000000013214542551763020005 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.753790331 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-two-way-stream.lsp0000644000175000017500000001565614542551763017420 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/not-and-null.lsp0000644000000000000000000000013114542551763016501 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.757790348 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/not-and-null.lsp0000644000175000017500000000167714542551763016113 0ustar00cammcamm;-*- 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 (signals-error (null) program-error) t) (deftest null.error.2 (signals-error (null nil nil) program-error) t) (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 (signals-error (not) program-error) t) (deftest not.error.2 (signals-error (not nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-15.lsp0000644000000000000000000000013214542551762016333 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.757790348 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-15.lsp0000644000175000017500000003274614542551762015745 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-min.lsp0000644000000000000000000000013214542551762022623 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.757790348 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-min.lsp0000644000175000017500000001337114542551762022226 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 24 21:31:55 2003 ;;;; Contains: Tests of DEFGENERIC with :method-combination MIN (in-package :cl-test) (declaim (special *x*)) (compile-and-load "defgeneric-method-combination-aux.lsp") (deftest defgeneric-method-combination.min.1 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.min.1 (x) (:method-combination min) (:method min ((x integer)) (car (push 1 *x*))) (:method min ((x rational)) (car (push 2 *x*))) (:method min ((x number)) (car (push 3 *x*))) (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) (deftest defgeneric-method-combination.min.2 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.min.2 (x) (:method-combination min :most-specific-first) (:method min ((x integer)) (car (push 1 *x*))) (:method min ((x rational)) (car (push 2 *x*))) (:method min ((x number)) (car (push 3 *x*))) (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) (deftest defgeneric-method-combination.min.3 (let ((*x* nil) (fn (eval '(defgeneric dg-mc.fun.min.3 (x) (:method-combination min :most-specific-last) (:method min ((x integer)) (car (push 1 *x*))) (:method min ((x rational)) (car (push 2 *x*))) (:method min ((x number)) (car (push 3 *x*))) (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) (let ((*x* nil)) (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (1 2 3 4)) (2 (2 3 4)) (3 (3 4)) (4 (4))) (deftest defgeneric-method-combination.min.4 (let ((fn (eval '(defgeneric dg-mc.min.4 (x) (:method-combination min) (:method min ((x integer)) 1) (:method :around ((x rational)) 'foo) (:method min ((x number)) 2) (:method min ((x symbol)) 3) (:method min ((x t)) 4))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) foo foo 2 3 4) (deftest defgeneric-method-combination.min.5 (let ((fn (eval '(defgeneric dg-mc.min.5 (x) (:method-combination min) (:method min ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method min ((x number)) 2) (:method min ((x symbol)) 4) (:method min ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn 'x) (funcall fn '(a b c)))) (foo 1) (foo 2) 2 4 8) (deftest defgeneric-method-combination.min.6 (let ((fn (eval '(defgeneric dg-mc.min.6 (x) (:method-combination min) (:method min ((x integer)) 1) (:method :around ((x rational)) (list 'foo (call-next-method))) (:method :around ((x real)) (list 'bar (call-next-method))) (:method min ((x number)) 2) (:method min ((x symbol)) 4) (:method min ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) (funcall fn 4/3) (funcall fn 1.54) (funcall fn #c(1.0 2.0)) (funcall fn 'x) (funcall fn '(a b c)))) (foo (bar 1)) (foo (bar 2)) (bar 2) 2 4 8) (deftest defgeneric-method-combination.min.7 (let ((fn (eval '(defgeneric dg-mc.min.7 (x) (:method-combination min) (:method min ((x dgmc-class-04)) 1) (:method min ((x dgmc-class-03)) 2) (:method min ((x dgmc-class-02)) 4) (:method min ((x dgmc-class-01)) 8))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) (funcall fn (make-instance 'dgmc-class-02)) (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) 8 4 2 1) (deftest defgeneric-method-combination.min.8 (let ((fn (eval '(defgeneric dg-mc.min.8 (x) (:method-combination min) (:method min ((x (eql 1000))) 0) (:method :around ((x symbol)) (values)) (:method :around ((x integer)) (values 'a 'b 'c)) (:method :around ((x complex)) (call-next-method)) (:method :around ((x number)) (values 1 2 3 4 5 6)) (:method min ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) (multiple-value-list (funcall fn 10)) (multiple-value-list (funcall fn #c(9 8))) (multiple-value-list (funcall fn '(a b c))))) () (a b c) (1 2 3 4 5 6) (1)) (deftest defgeneric-method-combination.min.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.min.9 (x) (:method-combination min))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) :error) (deftest defgeneric-method-combination.min.10 (progn (eval '(defgeneric dg-mc.min.10 (x) (:method-combination min) (:method ((x t)) 0))) (handler-case (dg-mc.min.10 'a) (error () :error))) :error) (deftest defgeneric-method-combination.min.11 (progn (eval '(defgeneric dg-mc.min.11 (x) (:method-combination min) (:method nonsense ((x t)) 0))) (handler-case (dg-mc.min.11 0) (error () :error))) :error) (deftest defgeneric-method-combination.min.12 (let ((fn (eval '(defgeneric dg-mc.min.12 (x) (:method-combination min) (:method :around ((x t)) 1) (:method min ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) (error () :error))) :error) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-04.lsp0000644000000000000000000000013114542551763020767 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.757790348 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-04.lsp0000644000175000017500000001467614542551763020404 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 6 21:44:41 2005 ;;;; Contains: Test that invoke the random type prop infrastructure, part 4 (in-package :cl-test) (defun char-or-same (c &rest args) (declare (ignore args)) (if (coin) `(eql ,c) 'character)) (eval-when (:load-toplevel :execute) (compile 'char-or-same)) (def-type-prop-test char=.1 'char= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char=.2 'char= '(character character) 2) (def-type-prop-test char=.3 'char= (list 'character #'char-or-same) 2) (def-type-prop-test char=.4 'char= (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char=.5 'char= '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char/=.1 'char/= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char/=.2 'char/= '(character character) 2) (def-type-prop-test char/=.3 'char/= (list 'character #'char-or-same) 2) (def-type-prop-test char/=.4 'char/= (list 'character 'character #'char-or-same) 3) (def-type-prop-test char/=.5 'char/= nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char<=.1 'char<= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char<=.2 'char<= '(character character) 2) (def-type-prop-test char<=.3 'char<= (list 'character #'char-or-same) 2) (def-type-prop-test char<=.4 'char<= (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char<=.5 'char<= '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char>=.1 'char>= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char>=.2 'char>= '(character character) 2) (def-type-prop-test char>=.3 'char>= (list 'character #'char-or-same) 2) (def-type-prop-test char>=.4 'char>= (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char>=.5 'char>= '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char<.1 'char< nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char<.2 'char< '(character character) 2) (def-type-prop-test char<.3 'char< (list 'character #'char-or-same) 2) (def-type-prop-test char<.4 'char< (list 'character 'character #'char-or-same) 3) (def-type-prop-test char<.5 'char< nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char>.1 'char> nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char>.2 'char> '(character character) 2) (def-type-prop-test char>.3 'char> (list 'character #'char-or-same) 2) (def-type-prop-test char>.4 'char> (list 'character 'character #'char-or-same) 3) (def-type-prop-test char>.5 'char> nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char-equal.1 'char-equal nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-equal.2 'char-equal '(character character) 2) (def-type-prop-test char-equal.3 'char-equal (list 'character #'char-or-same) 2) (def-type-prop-test char-equal.4 'char-equal (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char-equal.5 'char-equal '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char-not-equal.1 'char-not-equal nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-not-equal.2 'char-not-equal '(character character) 2) (def-type-prop-test char-not-equal.3 'char-not-equal (list 'character #'char-or-same) 2) (def-type-prop-test char-not-equal.4 'char-not-equal (list 'character 'character #'char-or-same) 3) (def-type-prop-test char-not-equal.5 'char-not-equal nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char-not-greaterp.1 'char-not-greaterp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-not-greaterp.2 'char-not-greaterp '(character character) 2) (def-type-prop-test char-not-greaterp.3 'char-not-greaterp (list 'character #'char-or-same) 2) (def-type-prop-test char-not-greaterp.4 'char-not-greaterp (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char-not-greaterp.5 'char-not-greaterp '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char-not-lessp.1 'char-not-lessp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-not-lessp.2 'char-not-lessp '(character character) 2) (def-type-prop-test char-not-lessp.3 'char-not-lessp (list 'character #'char-or-same) 2) (def-type-prop-test char-not-lessp.4 'char-not-lessp (list 'character #'char-or-same #'char-or-same) 3) (def-type-prop-test char-not-lessp.5 'char-not-lessp '(character) 3 :rest-type #'char-or-same :maxargs 6) (def-type-prop-test char-lessp.1 'char-lessp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-lessp.2 'char-lessp '(character character) 2) (def-type-prop-test char-lessp.3 'char-lessp (list 'character #'char-or-same) 2) (def-type-prop-test char-lessp.4 'char-lessp (list 'character 'character #'char-or-same) 3) (def-type-prop-test char-lessp.5 'char-lessp nil 2 :rest-type 'character :maxargs 6) (def-type-prop-test char-greaterp.1 'char-greaterp nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char-greaterp.2 'char-greaterp '(character character) 2) (def-type-prop-test char-greaterp.3 'char-greaterp (list 'character #'char-or-same) 2) (def-type-prop-test char-greaterp.4 'char-greaterp (list 'character 'character #'char-or-same) 3) (def-type-prop-test char-greaterp.5 'char-greaterp nil 2 :rest-type 'character :maxargs 6) (defun length1-p (seq) (= (length seq) 1)) (def-type-prop-test character 'character '((or character (and (string 1) (satisfies length1-p)))) 1) (def-type-prop-test characterp 'characterp '(t) 1) (def-type-prop-test alpha-char-p 'alpha-char-p '(character) 1) (def-type-prop-test alphanumericp 'alphanumericp '(character) 1) (def-type-prop-test digit-char 'digit-char '((or (integer 0 36) (integer 0)) (integer 2 36)) 1 :maxargs 2) (def-type-prop-test digit-char-p 'digit-char-p '(character) 1) (def-type-prop-test graphic-char-p 'graphic-char-p '(character) 1) (def-type-prop-test standard-char-p 'standard-char-p '(character) 1) (def-type-prop-test char-upcase 'char-upcase '(character) 1) (def-type-prop-test char-downcase 'char-downcase '(character) 1) (def-type-prop-test upper-case-p 'upper-case-p '(character) 1) (def-type-prop-test lower-case-p 'lower-case-p '(character) 1) (def-type-prop-test both-case-p 'both-case-p '(character) 1) (def-type-prop-test char-code 'char-code '(character) 1) (def-type-prop-test char-int 'char-int '(character) 1) (def-type-prop-test code-char 'code-char '((integer 0 #.char-code-limit)) 1) (def-type-prop-test char-name 'char-name '(character) 1) (def-type-prop-test name-char 'name-char '(string) 1) gcl-2.7.1/ansi-tests/PaxHeaders/pathname-host.lsp0000644000000000000000000000013114542551763016741 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.757790348 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname-host.lsp0000644000175000017500000000355114542551763016344 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/nthcdr.lsp0000644000000000000000000000013114542551763015453 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.757790348 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nthcdr.lsp0000644000175000017500000000243214542551763015053 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:48:36 2003 ;;;; Contains: Tests of NTHCDR (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;;; Error tests (deftest nthcdr.error.1 (check-type-error #'(lambda (x) (nthcdr x (copy-list '(a b c d)))) (typef 'unsigned-byte)) nil) (deftest nthcdr.error.6 (signals-error (nthcdr -10 (copy-tree '(a b c d))) type-error) t) (deftest nthcdr.error.7 (signals-error (nthcdr) program-error) t) (deftest nthcdr.error.8 (signals-error (nthcdr 0) program-error) t) (deftest nthcdr.error.9 (signals-error (nthcdr 0 nil nil) program-error) t) (deftest nthcdr.error.10 (signals-error (nthcdr 3 (cons 'a 'b)) type-error) t) (deftest nthcdr.error.11 (signals-error (locally (nthcdr 'a (copy-tree '(a b c d))) t) type-error) t) ;;; Non-error tests (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) gcl-2.7.1/ansi-tests/PaxHeaders/labels.lsp0000644000000000000000000000013114542551762015432 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.757790348 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/labels.lsp0000644000175000017500000002123114542551762015030 0ustar00cammcamm;-*- 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 :good))) nil)) (%f) :bad)) :good) ;;; Keyword parameter initializers are not in the blocked defined ;;; by the local function declaration (deftest labels.4a (block %f (labels ((%f (&key (x (return-from %f :good))) nil)) (%f) :bad)) :good) (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) :bad)) 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) ;;; 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) ;;; Scope of defined function names includes &OPTIONAL parameters (deftest labels.7c (labels ((%f (x &optional (b (%g x))) b) (%g (y) (+ y y))) (%f 10)) 20) ;;; Scope of defined function names includes &KEY parameters (deftest labels.7d (labels ((%f (x &key (b (%g x))) b) (%g (y) (+ y y))) (%f 10)) 20) ;;; 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 (signals-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)) program-error) t) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest labels.13 (signals-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)) program-error) t) ;;; Too few arguments (section 3.5.1.2) (deftest labels.14 (signals-error (labels ((%f (a) a)) (%f)) program-error) t) ;;; Too many arguments (section 3.5.1.3) (deftest labels.15 (signals-error (labels ((%f (a) a)) (%f 1 2)) program-error) t) ;;; Invalid keyword argument (section 3.5.1.5) (deftest labels.16 (signals-error (labels ((%f (&key a) a)) (%f '(foo))) program-error) t) ;;; 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)) ;;; 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 (1- lambda-parameters-limit) 1024)) (vars (loop repeat n collect (gensym)))) (eval `(eqlt ,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 = `(ignore-errors (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 = `(ignore-errors (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 = `(ignore-errors (labels (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) ;;; Check that LABELS does not have a tagbody (deftest labels.27 (block done (tagbody (labels ((%f () (go 10) 10 (return-from done 'bad))) (%f)) 10 (return-from done 'good))) good) ;;; Check that nil keyword arguments do not enable the default values (deftest labels.28 (labels ((%f (&key (a 'wrong)) a)) (%f :a nil)) nil) (deftest labels.29 (labels ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) (nil nil)) (deftest labels.30 (labels ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) nil) (deftest labels.31 (labels ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) (%f :a nil)) (nil nil)) (deftest labels.32 (labels ((%f (&key) 'good)) (%f :allow-other-keys nil)) good) (deftest labels.33 (labels ((%f (&key) 'good)) (%f :allow-other-keys t)) good) (deftest labels.34 (labels ((%f (&key) 'good)) (%f :allow-other-keys t :a 1 :b 2)) good) (deftest labels.35 (labels ((%f (&key &allow-other-keys) 'good)) (%f :a 1 :b 2)) good) ;;; NIL as a disallowed keyword argument (deftest labels.36 (signals-error (labels ((%f (&key) :bad)) (%f nil nil)) program-error) t) ;;; Identity of function objects ;;; Since (FUNCTION ) returns *the* functional value, it ;;; should be the case that different invocations of this form ;;; in the same lexical environment return the same value. (deftest labels.37 (labels ((f () 'foo)) (eqt #'f #'f)) t) (deftest labels.38 (labels ((f () 'foo)) (destructuring-bind (x y) (loop repeat 2 collect #'f) (eqlt x y))) t) (deftest labels.39 (labels ((f () #'f)) (eqlt (f) #'f)) t) (deftest labels.40 (let ((x (labels ((f () #'f)) #'f))) (eqlt x (funcall x))) t) ;;; Test that free declarations do not affect argument forms (deftest labels.41 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f (&optional (y x)) (declare (special x)) y)) (%f)))) :good) (deftest labels.42 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f (&key (y x)) (declare (special x)) y)) (%f)))) :good) (deftest labels.43 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels () (declare (special x))) x)) :good) (deftest labels.44 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f () (declare (special x))))) x)) :good) (deftest labels.45 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f () (declare (special x)))) x))) :good) (deftest labels.46 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f (&aux (y x)) (declare (special x)) y)) (%f)))) :good) (deftest labels.47 (let ((x :bad)) (declare (special x)) (let ((x :good)) (labels ((%f () x)) (declare (special x)) (%f)))) :good) ;;; Macros are expanded in the appropriate environment (deftest labels.48 (macrolet ((%m (z) z)) (labels () (expand-in-current-env (%m :good)))) :good) (deftest labels.49 (macrolet ((%m (z) z)) (labels ((%f () (expand-in-current-env (%m :good)))) (%f))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/format-d.lsp0000644000000000000000000000013214542551762015702 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.757790348 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-d.lsp0000644000175000017500000004063114542551762015304 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jul 31 05:19:39 2004 ;;;; Contains: Tests of the ~D format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest format.d.1 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~D" i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j))) nil) (deftest formatter.d.1 (let ((fn (formatter "~D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (formatter-call-to-string fn i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j)))) nil) (deftest format.d.2 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (format nil "~@d" i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) ;; (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j))) nil) (deftest formatter.d.2 (let ((fn (formatter "~@D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for s1 = (formatter-call-to-string fn i) for j = (read-from-string s1) repeat 1000 when (or (/= i j) (find #\. s1) ;; (find #\+ s1) (find-if #'alpha-char-p s1)) collect (list i s1 j)))) nil) (deftest format.d.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for s2 = (format nil (format nil "~~~dd" mincol) i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.d.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for format-string = (format nil "~~~dd" mincol) ; for s2 = (format nil format-string i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (list i mincol s1 s2 pos))) nil) (deftest format.d.4 (with-standard-io-syntax (loop with limit = 10 with count = 0 for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@D" i) for format-string = (format nil "~~~d@d" mincol) for s2 = (format nil format-string i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (if (> (incf count) limit) "Count limit exceeded" (list i mincol s1 format-string s2 pos)) while (<= count limit))) nil) (deftest formatter.d.4 (with-standard-io-syntax (loop with limit = 10 with count = 0 for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for i = (- (random (+ x x)) x) for s1 = (format nil "~@D" i) for format-string = (format nil "~~~d@d" mincol) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (not (eql (position #\Space s2 :test-not #'eql) (- (length s2) (length s1))))))) collect (if (> (incf count) limit) "Count limit exceeded" (list i mincol s1 s2 pos)) while (<= count limit))) nil) (deftest format.d.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for s2 = (format nil (format nil "~~~d,'~cd" mincol padchar) i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest formatter.d.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for format-string = (format nil "~~~d,'~cd" mincol padchar) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn i) for pos = (search s1 s2) repeat 100 when (or (null pos) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 pos))) nil) (deftest format.d.6 (let ((fn (formatter "~v,vd"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~d" i) for s2 = (format nil "~v,vD" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.d.7 (let ((fn (formatter "~v,v@D"))) (with-standard-io-syntax (loop with limit = 10 with count = 0 for x = (ash 1 (+ 2 (random 80))) for mincol = (random 30) for padchar = (random-from-seq +standard-chars+) for i = (- (random (+ x x)) x) for s1 = (format nil "~@d" i) for s2 = (format nil "~v,v@d" mincol padchar i) for s3 = (formatter-call-to-string fn mincol padchar i) for pos = (search s1 s2) repeat 1000 when (or (null pos) (not (string= s2 s3)) (and (>= i 0) (not (eql (elt s1 0) #\+))) (and (> mincol (length s1)) (or (/= (length s2) mincol) (find padchar s2 :end (- (length s2) (length s1)) :test-not #'eql)))) collect (if (> (incf count) limit) "Count limit exceeded" (list i mincol s1 s2 s3 pos)) while (<= count limit)))) nil) ;;; Comma tests (deftest format.d.8 (let ((fn1 (formatter "~d")) (fn2 (formatter "~:d"))) (loop for i from -999 to 999 for s1 = (format nil "~d" i) for s2 = (format nil "~:d" i) for s3 = (formatter-call-to-string fn1 i) for s4 = (formatter-call-to-string fn2 i) unless (and (string= s1 s2) (string= s1 s3) (string= s1 s4)) collect (list i s1 s2 s3 s4))) nil) (deftest format.d.9 (let ((fn1 (formatter "~d")) (fn2 (formatter "~:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = #\, for s1 = (format nil "~d" i) for s2 = (format nil "~:d" i) for s3 = (formatter-call-to-string fn1 i) for s4 = (formatter-call-to-string fn2 i) repeat 1000 unless (and (string= s1 s3) (string= s2 s4) (string= s1 (remove commachar s2)) (not (eql (elt s2 0) commachar)) (or (>= i 0) (not (eql (elt s2 1) commachar))) (let ((len (length s2)) (ci+1 4)) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (find (elt s2 i) "0123456789"))))) collect (list x i commachar s1 s2 s3 s4)))) nil) (deftest format.d.10 (let ((fn (formatter "~,,v:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~d" i) for s2 = (format nil "~,,v:d" commachar i) for s3 = (formatter-call-to-string fn commachar i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.d.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~d" i) for format-string = (format nil "~~,,'~c:d" commachar) for s2 = (format nil format-string i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest formatter.d.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for s1 = (format nil "~d" i) for format-string = (format nil "~~,,'~c:d" commachar) for fn = (eval `(formatter ,format-string)) ; for s2 = (format nil format-string i) for s2 = (formatter-call-to-string fn i) repeat 100 unless (and (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 4) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2))) nil) (deftest format.d.12 (let ((fn (formatter "~,,v,v:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~d" i) for s2 = (format nil "~,,v,v:D" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (string= s2 s3) (eql (elt s1 0) (elt s2 0)) (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) (let ((len (length s2)) (ci+1 (1+ commaint)) (j (if (< i 0) 1 0))) (loop for i from (if (< i 0) 2 1) below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) (deftest format.d.13 (let ((fn (formatter "~,,v,v:@D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) for i = (- (random (+ x x)) x) for commachar = (random-from-seq +standard-chars+) for commaint = (1+ (random 20)) for s1 = (format nil "~@d" i) for s2 = (format nil "~,,v,v:@d" commachar commaint i) for s3 = (formatter-call-to-string fn commachar commaint i) repeat 1000 unless (and (eql (elt s1 0) (elt s2 0)) (eql (elt s1 1) (elt s2 1)) (let ((len (length s2)) (ci+1 (1+ commaint)) (j 1)) (loop for i from 2 below len always (if (= (mod (- len i) ci+1) 0) (eql (elt s2 i) commachar) (eql (elt s1 (incf j)) (elt s2 i)))))) collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments (def-format-test format.d.14 "~vD" (nil 100) "100") (def-format-test format.d.15 "~6,vD" (nil 100) " 100") (def-format-test format.d.16 "~,,v:d" (nil 12345) "12,345") (def-format-test format.d.17 "~,,'*,v:d" (nil 12345) "12*345") ;;; When the argument is not an integer, print as if using ~A and base 10 (deftest format.d.18 (loop for x in *mini-universe* for s1 = (format nil "~d" x) for s2 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2)) collect (list x s1 s2)) nil) (deftest format.d.19 (loop for x in *mini-universe* for s1 = (format nil "~:d" x) for s2 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2)) collect (list x s1 s2)) nil) (deftest format.d.20 (loop for x in *mini-universe* for s1 = (format nil "~@d" x) for s2 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2)) collect (list x s1 s2)) nil) (deftest format.d.21 (loop for x in *mini-universe* for s1 = (format nil "~A" x) for s2 = (format nil "~@:d" x) for s3 = (format nil "~A" x) unless (or (integerp x) (string= s1 s2) (not (string= s1 s3))) collect (list x s1 s2)) nil) ;;; Must add tests for non-integers when the parameters ;;; are specified, but it's not clear what the meaning is. ;;; Does mincol apply to the ~A equivalent? What about padchar? ;;; Are comma-char and comma-interval always ignored? ;;; # arguments (deftest format.d.22 (apply #'values (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~#d" 12345 args) collect s)) "12345" "12345" "12345" "12345" "12345" " 12345" " 12345" " 12345" " 12345" " 12345" " 12345") (deftest formatter.d.22 (apply #'values (let ((fn (formatter "~#D"))) (loop for i from 0 to 10 for args = (make-list i) ; for s = (apply #'format nil "~#d" 12345 args) for s = (with-output-to-string (stream) (assert (equal (apply fn stream 12345 args) args))) collect s))) "12345" "12345" "12345" "12345" "12345" " 12345" " 12345" " 12345" " 12345" " 12345" " 12345") (deftest format.d.23 (apply #'values (let ((fn (formatter "~,,,#:D"))) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#:d" 1234567890 args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream 1234567890 args) args))) do (assert (string= s s2)) collect s))) "1,2,3,4,5,6,7,8,9,0" "12,34,56,78,90" "1,234,567,890" "12,3456,7890" "12345,67890" "1234,567890" "123,4567890" "12,34567890" "1,234567890" "1234567890" "1234567890") (deftest format.d.24 (apply #'values (let ((fn (formatter "~,,,#:@d"))) (loop for i from 0 to 10 for args = (make-list i) for s = (apply #'format nil "~,,,#@:D" 1234567890 args) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream 1234567890 args) args))) do (assert (string= s s2)) collect s))) "+1,2,3,4,5,6,7,8,9,0" "+12,34,56,78,90" "+1,234,567,890" "+12,3456,7890" "+12345,67890" "+1234,567890" "+123,4567890" "+12,34567890" "+1,234567890" "+1234567890" "+1234567890") (def-format-test format.d.25 "~+10d" (1234) " 1234") (def-format-test format.d.26 "~+10@d" (1234) " +1234") (def-format-test format.d.27 "~-1d" (1234) "1234") (def-format-test format.d.28 "~-1000000000000000000d" (1234) "1234") (def-format-test format.d.29 "~vd" ((1- most-negative-fixnum) 1234) "1234") ;;; Randomized test (deftest format.d.30 (let ((fn (formatter "~v,v,v,vD"))) (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (if mincol (format nil "~~~d," mincol) "~,") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~dd" commaint) "d")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vd" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/functionp.lsp0000644000000000000000000000013114542551762016175 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.757790348 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/functionp.lsp0000644000175000017500000000401514542551762015574 0ustar00cammcamm;-*- 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) (report-and-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 (check-predicate #'(lambda (x) (not (and (or (numberp x) (characterp x) (symbolp x) (consp x) (typep x 'array)) (functionp x))))) nil) (deftest functionp.11 (flet ((%f () nil)) (functionp '%f)) nil) (deftest functionp.12 (flet ((%f () nil)) (not-mv (functionp #'%f))) nil) ;;; TODO: Add check-type-predicate test? (deftest functionp.order.1 (let ((i 0)) (values (notnot (functionp (progn (incf i) #'cons))) i)) t 1) (deftest functionp.error.1 (signals-error (functionp) program-error) t) (deftest functionp.error.2 (signals-error (functionp #'cons nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/pprint-dispatch.lsp0000644000000000000000000000013114542551763017302 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.757790348 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-dispatch.lsp0000644000175000017500000002034214542551763016702 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 12 13:14:53 2004 ;;;; Contains: Tests of PPRINT-DISPATCH, SET-PPRINT-DISPATCH (in-package :cl-test) (deftest pprint-dispatch.1 (loop for x in (append *universe* *cl-symbols*) for vals = (multiple-value-list (pprint-dispatch x)) for vals2 = (multiple-value-list (pprint-dispatch x *print-pprint-dispatch*)) unless (and (= (length vals) 2) (= (length vals2) 2) (destructuring-bind (fun foundp) vals (if foundp (and (or (typep fun 'function) (and (symbolp fun) (symbol-function fun))) (destructuring-bind (fun2 foundp2) vals2 (and (equal fun fun2) foundp2))) (not (cadr vals2))))) collect (list x vals vals2)) nil) #| (deftest pprint-dispatch.2 (loop for sym in *cl-symbols* for x = (list sym nil nil) for vals = (multiple-value-list (pprint-dispatch x)) for vals2 = (multiple-value-list (pprint-dispatch x *print-pprint-dispatch*)) unless (and (= (length vals) 2) (= (length vals2) 2) (destructuring-bind (fun foundp) vals (if foundp (and (or (typep fun 'function) (and (symbolp fun) (symbol-function fun))) (destructuring-bind (fun2 foundp2) vals2 (and (equal fun fun2) foundp2))) (not (cadr vals2))))) collect (list x vals vals2)) nil) |# ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change, and that it can be unset. (deftest pprint-dispatch.3 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil) (write-to-string '|X|))))) "X" nil "ABC" nil "X") ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change for any real weight, and that it can be unset. (deftest pprint-dispatch.4 (my-with-standard-io-syntax (loop for v1 in (remove-if-not #'realp *universe*) unless (equal (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (list (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f v1) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil) (write-to-string '|X|)))) '("X" nil "ABC" nil "X")) collect v1)) nil) ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change, and that it can be unset with any real weight (deftest pprint-dispatch.5 (my-with-standard-io-syntax (loop for v1 in (remove-if-not #'realp *universe*) unless (equal (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (list (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil v1) (write-to-string '|X|)))) '("X" nil "ABC" nil "X")) collect v1)) nil) ;;; Check that specifying the pprint-dispatch table argument to set-pprint-dispatch ;;; causes that table to be changed, not *print-pprint-dispatch*. (deftest pprint-dispatch.6 (my-with-standard-io-syntax (let ((other-ppd-table (copy-pprint-dispatch nil)) (*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f 0 other-ppd-table) (write-to-string '|X|) (let ((*print-pprint-dispatch* other-ppd-table)) (write-to-string '|X|)) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) nil) (write-to-string '|X|))))) "X" nil "X" "ABC" nil "ABC" nil "X") ;;; Test that the default weight of set-pprint-dispatch is 0 (deftest pprint-dispatch.7 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream))) (g #'(lambda (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(member |X| |Y|) g .0001) (write-to-string '|X|) (write-to-string '|Y|))))) "X" nil "ABC" nil "DEF" "DEF") (deftest pprint-dispatch.8 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream))) (g #'(lambda (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)))) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) f) (write-to-string '|X|) (set-pprint-dispatch '(member |X| |Y|) g -.0001) (write-to-string '|X|) (write-to-string '|Y|))))) "X" nil "ABC" nil "ABC" "DEF") ;;; Funtion designators in pprint-dispatch (defun pprint-dispatch-test-fn.1 (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)) (defun pprint-dispatch-test-fn.2 (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)) (deftest pprint-dispatch.9 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (values (write-to-string '|X|) (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.1)) (write-to-string '|X|) (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.2)) (write-to-string '|X|)))) "X" (nil) "ABC" (nil) "DEF") #| (deftest pprint-dispatch.10 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-readably* nil) (*print-escape* nil) (*print-pretty* t)) (let ((f #'(lambda (stream obj) (declare (ignore obj)) (write "ABC" :stream stream))) (g #'(lambda (stream obj) (declare (ignore obj)) (write "DEF" :stream stream))) (sym (gensym))) (setf (symbol-function sym) f) (values (write-to-string '|X|) (set-pprint-dispatch '(eql |X|) sym) (write-to-string '|X|) (progn (setf (symbol-function sym) g) (write-to-string '|X|)))))) "X" nil "ABC" "DEF") |# ;;; Error tests (deftest pprint-dispatch.error.1 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (pprint-dispatch)) program-error) t) (deftest pprint-dispatch.error.2 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (pprint-dispatch nil nil nil)) program-error) t) (deftest set-pprint-dispatch.error.1 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (set-pprint-dispatch)) program-error) t) (deftest set-pprint-dispatch.error.2 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) (set-pprint-dispatch t)) program-error) t) (deftest set-pprint-dispatch.error.3 (signals-error (let ((table (copy-pprint-dispatch nil))) (set-pprint-dispatch t 'identity 0 table nil)) program-error) t) (deftest set-pprint-dispatch.error.4 (loop for x in *mini-universe* unless (or (typep x 'real) (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) (set-pprint-dispatch t 'identity ',x)) error))) collect x) nil) (deftest set-pprint-dispatch.error.4-unsafe (loop for x in *mini-universe* unless (or (typep x 'real) (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) (declare (optimize (safety 0))) (set-pprint-dispatch t 'identity ',x)) error))) collect x) nil) gcl-2.7.1/ansi-tests/PaxHeaders/set-syntax-from-char.lsp0000644000000000000000000000013214542551763020165 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.757790348 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/set-syntax-from-char.lsp0000644000175000017500000003315414542551763017571 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 29 06:37:18 2005 ;;;; Contains: Tests of SET-SYNTAX-FROM-CHAR (in-package :cl-test) (compile-and-load "reader-aux.lsp") (defmacro def-set-syntax-from-char-test (name form &body expected-values) `(deftest ,name (with-standard-io-syntax (let ((*readtable* (copy-readtable nil))) (setf (readtable-case *readtable*) :preserve) ,form)) ,@expected-values)) ;;; Test that constituent traits are not altered when a constituent character ;;; syntax type is set (defmacro def-set-syntax-from-char-trait-test (c test-form expected-value) (setq c (typecase c (character c) ((or string symbol) (name-char (string c))) (t nil))) (when c ;; (format t "~A ~A~%" c (char-name c)) `(def-set-syntax-from-char-test ,(intern (concatenate 'string "SET-SYNTAX-FROM-CHAR-TRAIT-X-" (or (char-name c) (string c))) :cl-test) (let ((c ,c)) (values (set-syntax-from-char c #\X) ,test-form)) t ,expected-value))) (defmacro def-set-syntax-from-char-alphabetic-trait-test (c) `(def-set-syntax-from-char-trait-test ,c (let* ((*package* (find-package "CL-TEST")) (sym (read-from-string (string c)))) (list (let ((sym2 (find-symbol (string c)))) (or (eqt sym sym2) (list sym sym2))) (or (equalt (symbol-name sym) (string c)) (list (symbol-name sym) (string c))))) (t t))) (loop for c across "\\|!\"#$%&'()*,;<=>?@[]^_`~{}+-/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" do (eval `(def-set-syntax-from-char-alphabetic-trait-test ,c))) ;;; The invalid constituent character trait of invalid and whitespace characters ;;; is exposed when they are turned into constituent characters (defmacro def-set-syntax-from-char-invalid-trait-test (c) `(def-set-syntax-from-char-trait-test ,c (handler-case (let* ((*package* (find-package "CL-TEST")) (sym (read-from-string (concatenate 'string (string c) "Z")))) sym) (reader-error (c) (declare (ignore c)) :good)) :good)) (loop for name in '("Backspace" "Tab" "Newline" "Linefeed" "Page" "Return" "Space" "Rubout") do (eval `(def-set-syntax-from-char-invalid-trait-test ,name))) ;;; Turning characters into single escape characters (deftest set-syntax-from-char.single-escape.1 (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\\) (read-from-string (concatenate 'string (list c #\Z)))))) (unless (equal results '(t |Z|)) (list (list c results))))))) nil) (deftest set-syntax-from-char.single-escape.2 (loop for c across +standard-chars+ unless (eql c #\") nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\\) (read-from-string (concatenate 'string (list #\" c #\" #\")))))) (unless (equal results '(t "\"")) (list (list c results))))))) nil) (deftest set-syntax-from-char.multiple-escape (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\|) (handler-case (read-from-string (concatenate 'string (list c #\Z c))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c #\z #\|))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list #\| #\Z c))) (error (c) c))))) (unless (or (eql c #\Z) (eql c #\z) (equal results '(t |Z| |z| |Z|))) (list (list c results))))))) nil) (deftest set-syntax-from-char.semicolon (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) '1 '0)) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\;) (handler-case (read-from-string (concatenate 'string (list c2 c #\2))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c2 c #\2 #\Newline #\3))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c #\2 #\Newline c2))) (error (c) c))))) (unless (equal results (list t expected expected expected)) (list (list c results))))))) nil) (deftest set-syntax-from-char.left-paren (loop for c across +standard-chars+ unless (find c ")") nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) '(1) '(0))) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\() (handler-case (read-from-string (concatenate 'string (list c) ")")) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) ")2" (list #\Newline #\3))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) ")")) (error (c) c))))) (unless (equal results (list t nil expected expected)) (list (list c results))))))) nil) (deftest set-syntax-from-char.right-paren (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (let ((results (list (set-syntax-from-char c #\)) (handler-case (read-from-string (string c) nil nil) (reader-error (c) :good) (error (c) c))))) (unless (equal results '(t :good)) (list (list c results))))))) nil) (deftest set-syntax-from-char.single-quote (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) ''1 ''0)) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\') (handler-case (read-from-string (concatenate 'string (list c c2))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) " 2")) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2) ")")) (error (c) c))))) (unless (equal results (list t expected expected expected)) (list (list c results))))))) nil) ;;; I do not test that setting syntax from #\" allows the character to be ;;; used as the terminator of a double quoted string. It is not clear that ;;; the standard implies this. (deftest set-syntax-from-char.double-quote (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (expected (if (eql c #\0) "1" "0")) (c2 (if (eql c #\0) #\1 #\0))) (let ((results (list (set-syntax-from-char c #\") (handler-case (read-from-string (concatenate 'string (list c c2 c))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2 c #\2))) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c c2 c) ")")) (error (c) c))))) (unless (equal results (list t expected expected expected)) (list (list c results))))))) nil) (deftest set-syntax-from-char.backquote (loop for c across +standard-chars+ unless (find c ",x") nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (c2 (if (eql c #\Space) #\Newline #\Space)) (results (list (set-syntax-from-char c #\`) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string (list c #\, #\x))))) (error (c) c)) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string (list c #\, #\x c2))))) (error (c) c)) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string (list c c2 #\, #\x c2))))) (error (c) c))))) (unless (equal results '(t 0 0 0)) (list (list c results)))))) nil) (deftest set-syntax-from-char.comma (loop for c across +standard-chars+ unless (find c "`x") nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (c2 (if (eql c #\Space) #\Newline #\Space)) (results (list (set-syntax-from-char c #\,) (handler-case (read-from-string (string c)) (reader-error (c) :good) (error (c) c)) (handler-case (eval `(let ((x 0)) ,(read-from-string (concatenate 'string "`" (list c) "x")))) (error (c) c))))) (unless (equal results '(t :good 0)) (list (list c results)))))) nil) ;;; Tests of set-syntax-from-char on #\# (deftest set-syntax-from-char.sharp.1 (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (results (list (set-syntax-from-char c #\#) (if (not (eql c #\Space)) (handler-case (read-from-string (concatenate 'string (list c #\Space))) (reader-error () :good) (error (c) c)) :good) (if (not (find c "'X")) (handler-case (read-from-string (concatenate 'string (list c) "'X")) (error (c) c)) '#'|X|) (if (not (find c "(X)")) (handler-case (read-from-string (concatenate 'string (list c) "(X)")) (error (c) c)) #(|X|)) (if (not (find c ")")) (handler-case (read-from-string (concatenate 'string (list c) ")")) (reader-error (c) :good) (error (c) c)) :good) (if (not (find c "*")) (handler-case (read-from-string (concatenate 'string (list c #\*))) (error (c) c)) #*) (if (not (find c ":|")) (handler-case (let ((sym (read-from-string (concatenate 'string (list c) ":||")))) (and (symbolp sym) (null (symbol-package sym)) (symbol-name sym))) (error (c) c)) "") (handler-case (read-from-string (concatenate 'string (list c #\<))) (reader-error (c) :good) (error (c) c)) (handler-case (read-from-string (concatenate 'string (list c #\\ #\X))) (error (c) c)) (if (not (find c "1")) (handler-case (read-from-string (concatenate 'string (list c) "|1111|#1")) (error (c) c)) 1) (if (not (find c "1")) (handler-case (read-from-string (concatenate 'string (list c) "|11#|111|#11|#1")) (error (c) c)) 1) ))) (unless (equalp results '(t :good #'|X| #(|X|) :good #* "" :good #\X 1 1)) (list (list c results)))))) nil) (deftest set-syntax-from-char.sharp.2 (loop for c across +standard-chars+ nconc (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST")) (results (list (set-syntax-from-char c #\#) (if (not (find c "+XC ")) (handler-case (let ((*features* (cons ':X *features*))) (read-from-string (concatenate 'string (list c) "+X C"))) (error (c) c)) 'c) (if (not (find c "-(OR)")) (handler-case (read-from-string (concatenate 'string (list c) "-(OR)R")) (error (c) c)) 'r) (if (not (find c ".1")) (handler-case (read-from-string (concatenate 'string (list c) ".1")) (error (c) c)) 1) (if (not (find c "01aA")) (handler-case (list (read-from-string (concatenate 'string (list c) "0a1")) (read-from-string (concatenate 'string (list c) "0A1"))) (error (c) c)) '(#0a1 #0a1)) (if (not (find c "01bB")) (handler-case (list (read-from-string (concatenate 'string (list c) "b101")) (read-from-string (concatenate 'string (list c) "B011"))) (error (c) c)) '(5 3)) (if (not (find c "cC()12 ")) (handler-case (list (read-from-string (concatenate 'string (list c) "c(1 2)")) (read-from-string (concatenate 'string (list c) "C(2 1)"))) (error (c) c)) '(#c(1 2) #c(2 1))) (if (not (find c "oO0127")) (handler-case (list (read-from-string (concatenate 'string (list c) "o172")) (read-from-string (concatenate 'string (list c) "O7721"))) (error (c) c)) '(#o172 #o7721)) (if (not (find c "pP\"")) (handler-case (list (read-from-string (concatenate 'string (list c) "p\"\"")) (read-from-string (concatenate 'string (list c) "P\"\""))) (error (c) c)) '(#p"" #p"")) (if (not (find c "rR0123")) (handler-case (list (read-from-string (concatenate 'string (list c) "3r210")) (read-from-string (concatenate 'string (list c) "3R1111"))) (error (c) c)) '(#3r210 #3r1111)) ;;; Add #s test here (if (not (find c "xX04dF")) (handler-case (list (read-from-string (concatenate 'string (list c) "x40Fd")) (read-from-string (concatenate 'string (list c) "XFd04"))) (error (c) c)) '(#x40fd #xfd04)) ))) (unless (equalp results '(t c r 1 (#0a1 #0a1) (5 3) (#c(1 2) #c(2 1)) (#o172 #o7721) (#p"" #p"") (#3r210 #3r1111) (#x40fd #xfd04))) (list (list c results))) ))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/environment-functions.lsp0000644000000000000000000000013214542551762020543 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.761790366 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/environment-functions.lsp0000644000175000017500000000152614542551762020145 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 11 22:15:54 2004 ;;;; Contains: Tests of various string-returning functions from section 25 (in-package :cl-test) (defmacro def-env-tests (fn-name) (flet ((%name (suffix) (intern (concatenate 'string (symbol-name fn-name) suffix) (find-package :cl-test)))) `(progn (deftest ,(%name ".1") (let ((x (,fn-name))) (or (not x) (notnot (stringp x)))) t) (deftest ,(%name ".ERROR.1") (signals-error (,fn-name nil) program-error) t)))) (def-env-tests lisp-implementation-type) (def-env-tests lisp-implementation-version) (def-env-tests short-site-name) (def-env-tests long-site-name) (def-env-tests machine-instance) (def-env-tests machine-type) (def-env-tests machine-version) (def-env-tests software-type) (def-env-tests software-version) gcl-2.7.1/ansi-tests/PaxHeaders/declaration.lsp0000644000000000000000000000013214542551762016456 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.761790366 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/declaration.lsp0000644000175000017500000000437714542551762016067 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 29 07:16:15 2005 ;;;; Contains: Tests of the DECLARATION declarations (in-package :cl-test) (deftest declaration.1 (progn (declaim (declaration)) nil) nil) (deftest declaration.2 (progn (proclaim '(declaration)) nil) nil) (deftest declaration.3 (let ((sym (gensym)) (sym2 (gensym))) (proclaim `(declaration ,sym ,sym2)) nil) nil) ;;; For the error tests, see the page in the CLHS for TYPE: ;;; "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." ;;; Declare these only if bad declarations produce warnings. (when (block done (handler-bind ((warning #'(lambda (c) (return-from done t)))) (eval `(let () (declare (,(gensym))) nil)))) (deftest declaration.4 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (deftype ,sym () t) error))) t t) (deftest declaration.5 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (defstruct ,sym a b c) error))) t t) (deftest declaration.6 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (defclass ,sym () (a b c)) error))) t t) (deftest declaration.7 (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (define-condition ,sym (condition) (a b c)) error))) t t) (deftest declaration.8 (let ((sym (gensym))) (eval `(deftype ,sym () 'error)) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) (deftest declaration.9 (let ((sym (gensym))) (eval `(defstruct ,sym a b c)) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) (deftest declaration.10 (let ((sym (gensym))) (eval `(defclass ,sym () (a b c))) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) (deftest declaration.11 (let ((sym (gensym))) (eval `(define-condition ,sym (condition) (a b c))) (eval `(signals-error-always (proclaim '(declaration ,sym)) error))) t t) ) gcl-2.7.1/ansi-tests/PaxHeaders/unless.lsp0000644000000000000000000000013114542551763015502 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.761790366 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/unless.lsp0000644000175000017500000000313314542551763015101 0ustar00cammcamm;-*- 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) ;;; No implicit tagbody (deftest unless.10 (block done (tagbody (unless nil (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest unless.11 (macrolet ((%m (z) z)) (unless (expand-in-current-env (%m nil)) :good)) :good) (deftest unless.12 (macrolet ((%m (z) z)) (unless (expand-in-current-env (%m t)) :bad)) nil) (deftest unless.13 (macrolet ((%m (z) z)) (let ((x 1) (p nil)) (values (unless p (expand-in-current-env (%m (incf x)))) x))) 2 2) (deftest unless.error.1 (signals-error (funcall (macro-function 'unless)) program-error) t) (deftest unless.error.2 (signals-error (funcall (macro-function 'unless) '(unless t)) program-error) t) (deftest unless.error.3 (signals-error (funcall (macro-function 'unless) '(unless t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/butlast.lsp0000644000000000000000000000013014542551762015645 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.761790366 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/butlast.lsp0000644000175000017500000000452714542551762015255 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:41:14 2003 ;;;; Contains: Tests of BUTLAST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.6 (butlast '(a b c d e) (1+ most-positive-fixnum)) nil) (deftest butlast.7 (butlast '(a b c d e) most-positive-fixnum) nil) (deftest butlast.8 (butlast '(a b c d e) (1- most-positive-fixnum)) nil) (deftest butlast.9 (macrolet ((%m (z) z)) (values (butlast (expand-in-current-env (%m (list 'a 'b 'c)))) (butlast (list 'a 'b 'c 'd 'e) (expand-in-current-env (%m 2))))) (a b) (a b c)) (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) (def-fold-test butlast.fold.1 (butlast '(a b) 1)) (def-fold-test butlast.fold.2 (butlast '(a b c d e f) 3)) (def-fold-test butlast.fold.3 (butlast '(a b c d e f g h i) 7)) ;;; Error tests (deftest butlast.error.1 (signals-error (butlast (copy-tree '(a b c d)) 'a) type-error) t) (deftest butlast.error.2 (signals-error (butlast 'a 0) type-error) t) (deftest butlast.error.3 (signals-error (butlast) program-error) t) (deftest butlast.error.4 (signals-error (butlast '(a b c) 3 3) program-error) t) (deftest butlast.error.5 (signals-error (locally (butlast 'a 0) t) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/rationalize.lsp0000644000000000000000000000013114542551763016512 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.761790366 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/rationalize.lsp0000644000175000017500000000256614542551763016122 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 14:00:45 2003 ;;;; Contains: Tests of RATIONALIZE (in-package :cl-test) (deftest rationalize.error.1 (signals-error (rationalize) program-error) t) (deftest rationalize.error.2 (signals-error (rationalize 0 nil) program-error) t) (deftest rationalize.error.3 (signals-error (rationalize 0 0) program-error) t) (deftest rationalize.error.4 (check-type-error #'rationalize #'realp) nil) (deftest rationalize.1 (loop for x in (loop for r in *reals* when (or (not (floatp r)) (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) collect r) for r = (rationalize x) unless (and (rationalp r) (if (floatp x) (= (float r x) x) (eql x r))) collect (list x r)) nil) (deftest rationalize.2 (loop for type in '(short-float single-float double-float long-float) collect (loop for i from -10000 to 10000 for x = (coerce i type) for r = (rationalize x) count (not (eql r i)))) (0 0 0 0)) (deftest rationalize.3 (loop for type in '(short-float single-float double-float long-float) for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) nconc (loop for x = (random-from-interval bound) for r = (rationalize x) for x2 = (float r x) repeat 1000 unless (and (rationalp r) (= x x2)) collect (list x r x2))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep.lsp0000644000000000000000000000013114542551763016044 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.761790366 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep.lsp0000644000175000017500000001150714542551763015447 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 29 17:28:19 2003 ;;;; Contains: Tests of SUBTYPEP (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; 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 (signals-error (subtypep) program-error) t) (deftest subtypep.error.2 (signals-error (subtypep t) program-error) t) (deftest subtypep.error.3 (signals-error (subtypep t t nil nil) program-error) t) ;;; 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) ;;; Extended characters (deftest subtypep.extended-char.1 (if (subtypep* 'character 'base-char) (subtypep* 'extended-char nil) (values t t)) t t) (deftest subtypep.extended-char.2 (if (subtypep* 'extended-char nil) (subtypep* 'character 'base-char) (values t t)) t t) (deftest subtypep.extended-char.3 (check-equivalence 'extended-char '(and character (not base-char))) nil) ;;; Some and, or combinations (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.7.1/ansi-tests/PaxHeaders/handler-case.lsp0000644000000000000000000000013114542551762016516 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.761790366 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/handler-case.lsp0000644000175000017500000000777614542551762016136 0ustar00cammcamm;-*- 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 (error "an error") (error () t)) t) (deftest handler-case.2 (handler-case (error "an error") (warning () nil) (error () t)) t) (deftest handler-case.3 (handler-case (error "an error") (error (c) (and (typep c 'error) t)) (error () 'bad) (condition () 'bad2)) t) (deftest handler-case.4 (handler-case (error "an error") (warning (c) c) (error (c) (and (typep c 'error) t)) (error () 'bad) (condition () 'bad2)) t) (deftest handler-case.5 (handler-case (error "an error") (#.(find-class 'error) (c) (and (typep c 'error) t)) (error () 'bad)) t) (deftest handler-case.6 (handler-case (values) (error () nil))) (deftest handler-case.7 (handler-case 'foo (condition () 'bar)) foo) ;;; (deftest handler-case.8 ;;; (handler-case 'foo (t () 'bar)) ;;; foo) (deftest handler-case.9 (handler-case (values 1 2 3 4 5 6 7 8) (condition () nil)) 1 2 3 4 5 6 7 8) ;;; (deftest handler-case.10 ;;; (handler-case ;;; (error "foo") ;;; (t () 'good)) ;;; good) (deftest handler-case.11 (labels ((%f () (declare (special *c*)) (and (typep *c* 'condition) t)) (%g () (let ((*c* nil)) (declare (special *c*)) (%h))) (%h () (handler-case (error "foo") (error (*c*) (declare (special *c*)) (%f))))) (%g)) t) (deftest handler-case.12 (handler-case (error "foo") (nil () nil) (error (c) (notnot-mv (typep c 'simple-error)))) t) (deftest handler-case.13 (handler-case (error "foo") (error (c) (values)))) (deftest handler-case.14 (handler-case (error "foo") (error (c) (values 1 2 3 4 5 6 7 8))) 1 2 3 4 5 6 7 8) (deftest handler-case.15 (handler-case (handler-case (error "foo") (warning () 'bad)) (error () 'good)) good) (deftest handler-case.16 (handler-case (handler-case (error "foo") (error () 'good)) (error () 'bad)) good) (deftest handler-case.17 (let ((i 0)) (values (handler-case (handler-case (error "foo") (error () (incf i) (error "bar"))) (error () 'good)) i)) good 1) (deftest handler-case.18 (let ((i 0)) (values (handler-case (handler-case (error "foo") (error (c) (incf i) (error c))) (error () 'good)) i)) good 1) (deftest handler-case.19 (handler-case (error "foo") (error (c) ;; Test that declarations can go here (declare (optimize (safety 3))) (declare (type condition c)) (declare (ignore c)) t)) t) (deftest handler-case.20 (handler-case 10 (:no-error (x) (+ x 3))) 13) (deftest handler-case.21 (handler-case (values) (:no-error () 'foo)) foo) (deftest handler-case.22 (handler-case (values 1 2 3 4 5) (:no-error (a b c d e) (list e d c b a))) (5 4 3 2 1)) (deftest handler-case.23 (signals-error (handler-case (values 1 2) (:no-error (x) x)) program-error) t) (deftest handler-case.24 (signals-error (handler-case (values) (:no-error (x) x)) program-error) t) (deftest handler-case.25 (handler-case (handler-case (values) (error () 'bad) (:no-error () (error "foo"))) (error () 'good)) good) (deftest handler-case.26 (handler-case (values 1 'a 1.0) (error () 'bad) (:no-error (a b c) ;; Test that declarations can go here (declare (type integer a)) (declare (type symbol b)) (declare (type number c)) (declare (ignore a c)) b)) a) (deftest handler-case.27 (handler-case (error "foo") (error ())) nil) (deftest handler-case.28 (handler-case (error "foo") (error () (declare (optimize speed)))) nil) ;;; Free declaration scope (deftest handler-case.29 (let ((x :bad)) (declare (special x)) (let ((x :good)) (handler-case nil (:no-error (z &aux (y x)) (declare (special x) (ignore z)) y)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/print-unreadable-object.lsp0000644000000000000000000000013114542551763020671 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.761790366 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-unreadable-object.lsp0000644000175000017500000000771214542551763020277 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 12 06:06:01 2004 ;;;; Contains: Tests of PRINT-UNREADABLE-OBJECT (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test print-unreadable-object.1 (loop for x in *mini-universe* for return-vals = nil for s = (with-output-to-string (s) (setq return-vals (multiple-value-list (print-unreadable-object (x s))))) unless (and (equal return-vals '(nil)) (equal s "#<>")) collect (list x return-vals s)) nil) (def-pprint-test print-unreadable-object.2 (loop for x in *mini-universe* for return-vals1 = nil for return-vals2 = nil for s1 = (with-output-to-string (s) (setq return-vals1 (multiple-value-list (print-unreadable-object (x s :type t))))) for s2 = (with-output-to-string (s) (setq return-vals2 (multiple-value-list (print-unreadable-object (x s :type t) (write-char #\X s))))) unless (and (equal return-vals1 '(nil)) (equal return-vals2 '(nil)) (string= s1 "#<" :end1 2) (string= s1 s2 :end1 (- (length s1) 1) :end2 (- (length s2) 2)) (string= s2 " X>" :start1 (- (length s2) 3))) collect (list x return-vals1 return-vals2 s1 s2)) nil) (def-pprint-test print-unreadable-object.3 (loop for x in *mini-universe* for return-vals1 = nil for return-vals2 = nil for s1 = (with-output-to-string (s) (setq return-vals1 (multiple-value-list (print-unreadable-object (x s :identity t) (write "FOO" :stream s) (values 1 2 3 4 5) ;; test if this is ignored )))) for s2 = (with-output-to-string (s) (setq return-vals2 (multiple-value-list (print-unreadable-object (x s :identity t) )))) unless (and (equal return-vals1 '(nil)) (equal return-vals2 '(nil)) (string= s1 "#) (eql (char s2 (1- (length s2))) #\>) (string= s1 s2 :start2 3 :start1 6)) collect (list x return-vals1 return-vals2 s1 s2)) nil) (def-pprint-test print-unreadable-object.4 (loop for x in *mini-universe* for return-vals = nil for s = (with-output-to-string (s) (setq return-vals (multiple-value-list (print-unreadable-object (x s :identity t :type t) (write "FOO" :stream s) (values) ;; test if this is ignored )))) unless (and (equal return-vals '(nil)) (string= s "#<" :end1 2) (eql (char s (1- (length s))) #\>) (>= (count #\Space s) 2)) collect (list x return-vals s)) nil) ;;; TODO Tests that the :identity and :type arguments are evaluated ;;; TODO Tests where :type, :identity are provided, but are nil ;;; TODO Test that the type/identity parts of the output are the same ;;; for the both-printed case as they are in the only-one printed case, ;;; and that only a single space occurs between them if FORMS is omitted. ;;; Error cases (deftest print-unreadable-object.error.1 (with-standard-io-syntax (let ((*print-readably* t)) (loop for x in *mini-universe* for form = `(with-output-to-string (*standard-output*) (assert (signals-error (print-unreadable-object (',x *standard-output*)) print-not-readable))) unless (equal (eval form) "") collect x))) nil) ;;; Stream designators (deftest print-unreadable-object.t.1 (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (let ((*print-readably* nil)) (assert (equal (multiple-value-list (print-unreadable-object (1 t))) '(nil))))))) "#<>") (deftest print-unreadable-object.nil.1 (with-output-to-string (*standard-output*) (let ((*print-readably* nil)) (assert (equal (multiple-value-list (print-unreadable-object (1 nil))) '(nil))))) "#<>") gcl-2.7.1/ansi-tests/PaxHeaders/with-condition-restarts.lsp0000644000000000000000000000013214542551763020776 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.761790366 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-condition-restarts.lsp0000644000175000017500000000417214542551763020400 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 04:06:06 2003 ;;;; Contains: Tests of WITH-CONDITION-RESTARTS (in-package :cl-test) (deftest with-condition-restarts.1 (let (a b c (i 0)) (values (with-condition-restarts (progn (setf a (incf i)) (make-condition 'error)) (progn (setf b (incf i)) nil) (setf c (incf i))) a b c i)) 3 1 2 3 3) (deftest with-condition-restarts.2 (with-condition-restarts (make-condition 'error) nil (values))) (deftest with-condition-restarts.3 (with-condition-restarts (make-condition 'error) nil (values 'a 'b 'c 'd 'e 'f)) a b c d e f) (deftest with-condition-restarts.4 (block done (tagbody (with-condition-restarts (make-condition 'error) nil (go 10) 10 (return-from done 'bad)) 10 (return-from done 'good))) good) (deftest with-condition-restarts.5 (let ((c (make-condition 'error))) (restart-case (with-condition-restarts c (list (find-restart 'foo)) 'good) (foo () 'bad))) good) (deftest with-condition-restarts.6 (let ((c (make-condition 'error)) (c2 (make-condition 'error))) (handler-bind ((error #'(lambda (c) (invoke-restart (find-restart 'foo c2))))) (restart-case (with-condition-restarts c (list (find-restart 'foo)) (signal c2)) (foo () 'bad) (foo () 'good)))) good) (deftest with-condition-restarts.7 (let ((c (make-condition 'error)) (c2 (make-condition 'error))) (handler-bind ((error #'(lambda (c) (invoke-restart 'foo)))) (restart-case (with-condition-restarts c (list (find-restart 'foo)) (signal c2)) (foo () 'good) (foo () 'bad)))) good) ;;; test that the association of a restart with a condition ;;; has dynamic extent (deftest with-condition-restarts.8 (let ((c (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (progn (with-condition-restarts c (list (find-restart 'foo))) (invoke-restart (find-restart 'foo c2))) (foo () 'good) (foo () 'bad))) good) gcl-2.7.1/ansi-tests/PaxHeaders/bit-xor.lsp0000644000000000000000000000013014542551762015553 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.761790366 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-xor.lsp0000644000175000017500000001532014542551762015154 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:35:46 2003 ;;;; Contains: Tests of BIT-XOR (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-xor (expand-in-current-env (%m #*0011)) #*0101)) #*0110) (deftest bit-xor.21 (macrolet ((%m (z) z)) (bit-xor #*1010 (expand-in-current-env (%m #*1100)))) #*0110) (deftest bit-xor.22 (macrolet ((%m (z) z)) (bit-xor #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*11001001) (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) (def-fold-test bit-xor.fold.1 (bit-xor #*00101 #*10100)) ;;; Random tests (deftest bit-xor.random.1 (bit-random-test-fn #'bit-xor #'logxor) nil) ;;; Error tests (deftest bit-xor.error.1 (signals-error (bit-xor) program-error) t) (deftest bit-xor.error.2 (signals-error (bit-xor #*000) program-error) t) (deftest bit-xor.error.3 (signals-error (bit-xor #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/array-displacement.lsp0000644000000000000000000000013214542551762017755 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.765790384 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-displacement.lsp0000644000175000017500000000746214542551762017364 0ustar00cammcamm;-*- 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.15 (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) (macrolet ((%m (z) z)) (multiple-value-bind (x y) (array-displacement (expand-in-current-env (%m b))) (values (eqlt x a) y)))) t 2) ;;; FIXME: Add tests for other kinds of specialized arrays ;;; (character, other integer types, float types, complex types) (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 (signals-error (array-displacement) program-error) t) (deftest array-displacement.error.2 (signals-error (array-displacement #(a b c) nil) program-error) t) (deftest array-displacement.error.3 (check-type-error #'array-displacement #'arrayp) nil) (deftest array-displacement.error.4 (signals-type-error x nil (array-displacement x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/consp.lsp0000644000000000000000000000013214542551762015313 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.765790384 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/consp.lsp0000644000175000017500000000227614542551762014720 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 21:27:16 2003 ;;;; Contains: Tests of CONSP (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;; 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 (check-predicate #'(lambda (x) (or (and (consp x) (not (atom x))) (and (not (consp x)) (atom x))))) nil) ;; Everything in type cons satisfies consp, and vice versa (deftest consp-cons-universe (check-type-predicate 'consp 'cons) nil) (deftest consp.order.1 (let ((i 0)) (values (consp (incf i)) i)) nil 1) ;;; Error tests (deftest consp.error.1 (signals-error (consp) program-error) t) (deftest consp.error.2 (signals-error (consp 'a 'b) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/broadcast-stream-streams.lsp0000644000000000000000000000013014542551762021076 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.765790384 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/broadcast-stream-streams.lsp0000644000175000017500000000122614542551762020477 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cos.lsp0000644000000000000000000000013214542551762014755 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.765790384 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cos.lsp0000644000175000017500000000635314542551762014362 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 9 20:53:42 2004 ;;;; Contains: Tests of COS (in-package :cl-test) (deftest cos.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (cos i)) for y = (car rlist) always (and (null (cdr rlist)) (<= -1 y 1) (or (rationalp y) (typep y 'single-float)))) t) (deftest cos.2 (loop for x = (- (random 2000.0s0) 1000.0s0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'short-float))) t) (deftest cos.3 (loop for x = (- (random 2000.0f0) 1000.0f0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'single-float))) t) (deftest cos.4 (loop for x = (- (random 2000.0d0) 1000.0d0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'double-float))) t) (deftest cos.5 (loop for x = (- (random 2000.0l0) 1000.0l0) for rlist = (multiple-value-list (cos x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'long-float))) t) (deftest cos.6 (let ((r (cos 0))) (or (eqlt r 1) (eqlt r 1.0))) t) (deftest cos.7 (cos 0.0s0) 1.0s0) (deftest cos.8 (cos 0.0) 1.0) (deftest cos.9 (cos 0.0d0) 1.0d0) (deftest cos.10 (cos 0.0l0) 1.0l0) (deftest cos.11 (loop for i from 1 to 100 unless (approx= (cos i) (cos (coerce i 'single-float))) collect i) nil) (deftest cos.12 (approx= (cos (coerce (/ pi 2) 'single-float)) 0.0) t) (deftest cos.13 (approx= (cos (coerce (/ pi -2) 'single-float)) 0.0) t) (deftest cos.14 (approx= (cos (coerce (/ pi 2) 'short-float)) 0s0) t) (deftest cos.15 (approx= (cos (coerce (/ pi -2) 'short-float)) 0s0) t) (deftest cos.16 (approx= (cos (coerce (/ pi 2) 'double-float)) 0d0) t) (deftest cos.17 (approx= (cos (coerce (/ pi -2) 'double-float)) 0d0) t) (deftest cos.18 (approx= (cos (coerce (/ pi 2) 'long-float)) 0l0) t) (deftest cos.19 (approx= (cos (coerce (/ pi -2) 'long-float)) 0l0) t) (deftest cos.20 (loop for r = (- (random 2000) 1000) for i = (- (random 20) 10) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.21 (loop for r = (- (random 2000.0s0) 1000.0s0) for i = (- (random 20.0s0) 10.0s0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.22 (loop for r = (- (random 2000.0f0) 1000.0f0) for i = (- (random 20.0f0) 10.0f0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.23 (loop for r = (- (random 2000.0d0) 1000.0d0) for i = (- (random 20.0d0) 10.0d0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) (deftest cos.24 (loop for r = (- (random 2000.0l0) 1000.0l0) for i = (- (random 20.0l0) 10.0l0) for y = (cos (complex r i)) repeat 1000 always (numberp y)) t) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest cos.error.1 (signals-error (cos) program-error) t) (deftest cos.error.2 (signals-error (cos 0.0 0.0) program-error) t) (deftest cos.error.3 (check-type-error #'cos #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/package-used-by-list.lsp0000644000000000000000000000013114542551763020103 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.765790384 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-used-by-list.lsp0000644000175000017500000000370114542551763017503 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:56:28 2004 ;;;; Contains: Tests of PACKAGE-USED-BY-LIST (in-package :cl-test) ;;; Most tests of this function are in files for other package-related operators ;;; Specialized sequence tests (defmacro def-package-used-by-list-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-used-by-list p))) nil)) (def-package-used-by-list-test package-used-by-list.1 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.2 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-used-by-list-test package-used-by-list.3 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-used-by-list-test package-used-by-list.4 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.5 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.6 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-used-by-list-test package-used-by-list.7 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-used-by-list.error.1 (signals-error (package-used-by-list) program-error) t) (deftest package-used-by-list.error.2 (signals-error (package-used-by-list "CL" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/random-type-prop-tests-10.lsp0000644000000000000000000000013114542551763020764 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.765790384 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-type-prop-tests-10.lsp0000644000175000017500000000570714542551763020374 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Random type prop tests, part 10 (sequences, cont.) (in-package :cl-test) ;;; SEARCH (def-type-prop-test search.1 'search (list 'sequence 'sequence) 2) (def-type-prop-test search.2 'search (list 'bit-vector 'bit-vector) 2) (def-type-prop-test search.3 'search (list '(vector * 1) 'sequence) 2) (def-type-prop-test search.4 'search (list '(vector * 2) 'sequence '(eql :from-end) '(or null t)) 4) (def-type-prop-test search.5 'search (list 'sequence 'sequence '(eql :key) (list 'member 'identity nil #'identity 'not #'not)) 4) (def-type-prop-test search.6 'search (list #'(lambda () (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2))))) #'(lambda (s) (declare (ignore s)) (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2)))))) 2) (def-type-prop-test search.7 'search (list #'(lambda () (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2))))) #'(lambda (s) (declare (ignore s)) (make-sequence-type (random 10) (let ((i1 (make-random-integer)) (i2 (make-random-integer))) `(integer ,(min i1 i2) ,(max i1 i2))))) '(eql :test) (list 'member 'eql #'eql 'equal #'equal '= #'= '/= #'/= #'(lambda (x y) (= (logand x 1) (logand y 1))))) 4) (def-type-prop-test search.8 'search (labels ((%random-char-type () (random-from-seq #(base-char standard-char character))) (%random-char-sequence-type (&rest ignored) (declare (ignore ignored)) (make-sequence-type (random 10) (%random-char-type)))) (list #'%random-char-sequence-type #'%random-char-sequence-type '(member :test :test-not) (let ((char-compare-funs '(char= char/= char< char> char<= char>= char-equal char-not-equal char-lessp char-greaterp char-not-lessp char-not-greaterp))) `(member ,@char-compare-funs ,@(mapcar #'symbol-function char-compare-funs))))) 4) (def-type-prop-test search.9 'search (list 'sequence 'sequence '(eql :start1) #'(lambda (s1 s2 k) (declare (ignore s2 k)) (let ((len (length s1))) `(integer 0 ,len)))) 4) (def-type-prop-test search.10 'search (list 'sequence 'sequence '(eql :end1) #'(lambda (s1 s2 k) (declare (ignore s2 k)) (let ((len (length s1))) `(integer 0 ,len)))) 4) (def-type-prop-test search.11 'search (list 'sequence 'sequence '(eql :start2) #'(lambda (s1 s2 k) (declare (ignore s1 k)) (let ((len (length s2))) `(integer 0 ,len)))) 4) (def-type-prop-test search.12 'search (list 'sequence 'sequence '(eql :end2) #'(lambda (s1 s2 k) (declare (ignore s1 k)) (let ((len (length s2))) `(integer 0 ,len)))) 4) gcl-2.7.1/ansi-tests/PaxHeaders/defpackage.lsp0000644000000000000000000000013214542551762016243 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.765790384 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defpackage.lsp0000644000175000017500000004214614542551762015650 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:09:18 1998 ;;;; Contains: Tests of DEFPACKAGE (in-package :cl-test) (compile-and-load "package-aux.lsp") (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 (let () (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 (progn (set-up-packages) (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 (let () (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 (let () (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 (let () (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") (signals-error (defpackage "H" (:use) (:size 10) (:size 20)) program-error)) t) ;; Repeated documentation field should cause a program-error (deftest defpackage.14 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:documentation "foo") (:documentation "bar")) program-error)) t) ;; When a nickname refers to an existing package or nickname, ;; signal a package-error (deftest defpackage.15 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:nicknames "A")) package-error)) t) (deftest defpackage.16 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:nicknames "Q")) package-error)) t) ;; 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"))) (signals-error (defpackage "H" (:use) (:shadow "A") (:shadowing-import-from "G" "A")) program-error)) t) ;; :shadow and :import-from (deftest defpackage.18 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:shadow "A") (:import-from "G" "A")) program-error)) t) ;; :shadow and :intern (deftest defpackage.19 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:shadow "A") (:intern "A")) program-error)) t) ;; :shadowing-import-from and :import-from (deftest defpackage.20 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:shadowing-import-from "G" "A") (:import-from "G" "A")) program-error)) t) ;; :shadowing-import-from and :intern (deftest defpackage.21 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:shadowing-import-from "G" "A") (:intern "A")) program-error)) t) ;; :import-from and :intern (deftest defpackage.22 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (signals-error (defpackage "H" (:use) (:import-from "G" "A") (:intern "A")) program-error)) t) ;; Names given to :export and :intern must be disjoint, ;; otherwise signal a program-error (deftest defpackage.23 (progn (safely-delete-package "H") (signals-error (defpackage "H" (:use) (:export "A") (:intern "A")) program-error)) t) ;; :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 (let () (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)) (def-macro-test defpackage.error.1 (defpackage :nonexistent-package (:use)))gcl-2.7.1/ansi-tests/PaxHeaders/class-precedence-lists.lsp0000644000000000000000000000013014542551762020523 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.765790384 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/class-precedence-lists.lsp0000644000175000017500000001734414542551762020134 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 20:18:29 2003 ;;;; Contains: Tests that builtin classes have the right CPLs (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (unless #| (fboundp 'class-precedence-list-foo) |# nil (report-and-ignore-errors (defgeneric class-precedence-list-foo (x) (:method-combination list) . #.(loop for s in *cl-types-that-are-classes-symbols* collect `(:method list ((x ,s)) ',s)))))) (defmacro def-cpl-test (objform expected-cpl &optional name) (let* ((ordered (loop for e = expected-cpl then (cdr e) for x = (car e) for y = (cadr e) while y always (subtypep x y)))) `(deftest ,(or name (intern (concatenate 'string (symbol-name (first expected-cpl)) "-CPL") :cl-test)) (let* ((obj ,objform) (cpl (class-precedence-list-foo obj))) (or ,(if ordered nil `(and (not (eql (class-of obj) (find-class ',(first expected-cpl)))) (progn (format t "~%Note: ~S not a direct instance of ~A~%" ',objform ',(first expected-cpl)) t))) (and ,(if ordered t `(eql (first cpl) ',(first expected-cpl))) (is-noncontiguous-sublist-of ',expected-cpl cpl)))) t))) ;;; Condition types (defmacro def-cond-cpl-test (expected-cpl) `(def-cpl-test (make-condition ',(first expected-cpl)) ,expected-cpl)) (def-cond-cpl-test (arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (cell-error error serious-condition condition t)) (def-cond-cpl-test (condition t)) (def-cond-cpl-test (control-error error serious-condition condition t)) (def-cond-cpl-test (division-by-zero arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (end-of-file stream-error error serious-condition condition t)) (def-cond-cpl-test (error serious-condition condition t)) (def-cond-cpl-test (file-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-inexact arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-invalid-operation arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-overflow arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (floating-point-underflow arithmetic-error error serious-condition condition t)) (def-cond-cpl-test (package-error error serious-condition condition t)) (def-cond-cpl-test (parse-error error serious-condition condition t)) (def-cond-cpl-test (print-not-readable error serious-condition condition t)) (def-cond-cpl-test (program-error error serious-condition condition t)) (def-cond-cpl-test (reader-error parse-error stream-error error serious-condition condition t)) (def-cond-cpl-test (serious-condition condition t)) (def-cond-cpl-test (simple-condition condition t)) (def-cond-cpl-test (simple-error simple-condition error serious-condition condition t)) (def-cond-cpl-test (simple-type-error simple-condition type-error error serious-condition condition t)) (def-cond-cpl-test (simple-warning simple-condition warning condition t)) (def-cond-cpl-test (storage-condition serious-condition condition t)) (def-cond-cpl-test (stream-error error serious-condition condition t)) (def-cond-cpl-test (style-warning warning condition t)) (def-cond-cpl-test (type-error error serious-condition condition t)) (def-cond-cpl-test (unbound-slot cell-error error serious-condition condition t)) (def-cond-cpl-test (unbound-variable cell-error error serious-condition condition t)) (def-cond-cpl-test (undefined-function cell-error error serious-condition condition t)) (def-cond-cpl-test (warning condition t)) (def-cpl-test (make-array '(2 3 4)) (array t)) (def-cpl-test (make-array '(10) :element-type 'bit :adjustable t :fill-pointer 5) (bit-vector vector array sequence t)) (def-cpl-test (make-broadcast-stream) (broadcast-stream stream t)) (def-cpl-test (class-of 'symbol) (built-in-class class standard-object t)) (def-cpl-test #\a (character t) character-cpl.1) (def-cpl-test #c(1.0 2.0) (complex number t) complex-cpl.1) (def-cpl-test #c(1 2) (complex number t) complex-cpl.2) (def-cpl-test #c(1/2 2/3) (complex number t) complex-cpl.3) (def-cpl-test (make-concatenated-stream) (concatenated-stream stream t)) (def-cpl-test '(a b c) (cons list sequence t)) (def-cpl-test (let ((out (make-string-output-stream))) (make-echo-stream (make-string-input-stream "foo") out)) (echo-stream stream t)) (def-cpl-test (open "class-precedence-lists.lsp" :direction :probe) (file-stream stream t)) (def-cpl-test 1.0s0 (float real number t) float-cpl.1) (def-cpl-test 1.0f0 (float real number t) float-cpl.2) (def-cpl-test 1.0d0 (float real number t) float-cpl.3) (def-cpl-test 1.0l0 (float real number t) float-cpl.4) (def-cpl-test #'car (function t)) ;; (def-cpl-test #'make-instance (generic-function function t)) (def-cpl-test (make-hash-table) (hash-table t) hash-table-cpl.1) (def-cpl-test (make-hash-table :test 'eq) (hash-table t) hash-table-cpl.2) (def-cpl-test (make-hash-table :test 'equal) (hash-table t) hash-table-cpl.3) (def-cpl-test 0 (integer rational real number t) integer-cpl.1) (def-cpl-test (1+ most-positive-fixnum) (integer rational real number t) integer-cpl.2) (def-cpl-test (1- most-negative-fixnum) (integer rational real number t) integer-cpl.3) (def-cpl-test nil (list sequence t) list-cpl.1) (def-cpl-test '(a b c) (list sequence t) list-cpl.2) ;;; Insert a test for LOGICAL-PATHNAME here ;;; (def-cpl-test ????? (logical-pathname pathname t)) ;;; (def-cpl-test (find-method #'class-name nil (list (find-class 'class))) ;;; (method t)) ;;; Insert test for METHOD-COMBINATION here (def-cpl-test nil (null symbol list sequence t)) (def-cpl-test (find-package "CL") (package t)) (def-cpl-test #p"foo" (pathname t)) (def-cpl-test *random-state* (random-state t)) (def-cpl-test 5/3 (ratio rational real number t)) (def-cpl-test *readtable* (readtable t)) (defclass cpl-example-class () ()) (def-cpl-test (find-class 'cpl-example-class) (standard-class class standard-object t)) (defgeneric cpl-example-gf (x y)) (def-cpl-test #'cpl-example-gf (standard-generic-function generic-function function t)) (def-cpl-test (eval '(defmethod cpl-example-gf ((x t) (y t)) (list y x))) (standard-method method standard-object t)) (def-cpl-test (make-array '(10) :element-type 'character :initial-element #\a :fill-pointer t :adjustable t) (string vector array sequence t) string-cpl.1) (def-cpl-test "abcd" (string vector array sequence t) string-cpl.2) (def-cpl-test (make-string-input-stream "abcdef") (string-stream stream t)) (defstruct cpl-example-structure-class a b c) ;;; No test for STRUCTURE-OBJECT (def-cpl-test 'a (symbol t)) (defparameter *cpl-input-stream* (make-string-input-stream "foofoofoofoo")) (def-cpl-test (make-synonym-stream '*cpl-input-stream*) (synonym-stream stream t)) (defparameter *cpl-output-stream* (make-string-output-stream)) (def-cpl-test (make-two-way-stream *cpl-input-stream* *cpl-output-stream*) (two-way-stream stream t)) (def-cpl-test (make-array '(10) :fill-pointer t :adjustable t :initial-element '(a b c)) (vector array sequence t)) gcl-2.7.1/ansi-tests/PaxHeaders/multiple-value-list.lsp0000644000000000000000000000013114542551763020107 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.765790384 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/multiple-value-list.lsp0000644000175000017500000000350114542551763017505 0ustar00cammcamm;-*- 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.5 (multiple-value-list (values 'a)) (a)) (deftest multiple-value-list.6 (multiple-value-list (values 'a 'b)) (a b)) (deftest multiple-value-list.7 (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest multiple-value-list.8 (macrolet ((%m (z) z)) (multiple-value-list (expand-in-current-env (%m 1)))) (1)) (deftest multiple-value-list.9 (macrolet ((%m (z) z)) (multiple-value-list (expand-in-current-env (%m (values 1 2 3))))) (1 2 3)) ;;; Test that the argument is evaluated just once (deftest multiple-value-list.order.1 (let ((i 0)) (values (multiple-value-list (incf i)) i)) (1) 1) ;;; Error tests (deftest multiple-value-list.error.1 (signals-error (funcall (macro-function 'multiple-value-list)) program-error) t) (deftest multiple-value-list.error.2 (signals-error (funcall (macro-function 'multiple-value-list) '(multiple-value-list nil)) program-error) t) (deftest multiple-value-list.error.3 (signals-error (funcall (macro-function 'multiple-value-list) '(multiple-value-list nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-sequence.lsp0000644000000000000000000000013214542551763016715 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.765790384 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-sequence.lsp0000644000175000017500000003215114542551763016315 0ustar00cammcamm;-*- 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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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) #+:ansi-tests-strict-initial-element (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)) #+:ansi-tests-strict-initial-element (deftest make-sequence.26 (equalp (make-sequence 'string 5) (make-string 5)) t) (deftest make-sequence.27 (let ((len 10)) (loop for i from 1 to 40 for etype = `(unsigned-byte ,i) for type = `(vector ,etype) for vec = (make-sequence type len :initial-element 0) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) 0))) collect (list i etype type vec))) nil) (deftest make-sequence.28 (let ((len 10)) (loop for i from 1 to 40 for etype = `(signed-byte ,i) for type = `(vector ,etype) for vec = (make-sequence type len :initial-element 0) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) 0))) collect (list i etype type vec))) nil) (deftest make-sequence.29 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) for type = `(vector ,etype) for elem = (coerce 1 etype) for vec = (make-sequence type len :initial-element elem) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) elem))) collect (list etype type vec))) nil) (deftest make-sequence.30 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float integer rational) for etype = `(complex ,cetype) for type = `(vector ,etype) for elem = (complex (coerce 1 cetype) (coerce -1 cetype)) for vec = (make-sequence type len :initial-element elem) unless (and (typep vec type) (loop for i below len always (eql (elt vec i) elem))) collect (list etype type vec))) nil) ;;; Other type specifiers (deftest make-sequence.31 (make-sequence '(simple-string) 10 :initial-element #\X) "XXXXXXXXXX") (deftest make-sequence.32 (make-sequence '(simple-string 10) 10 :initial-element #\X) "XXXXXXXXXX") (deftest make-sequence.33 (make-sequence '(string) 10 :initial-element #\X) "XXXXXXXXXX") (deftest make-sequence.34 (make-sequence '(vector) 10 :initial-element nil) #(nil nil nil nil nil nil nil nil nil nil)) (deftest make-sequence.35 (make-sequence '(simple-vector) 10 :initial-element nil) #(nil nil nil nil nil nil nil nil nil nil)) (deftest make-sequence.36 (make-sequence '(vector * *) 10 :initial-element nil) #(nil nil nil nil nil nil nil nil nil nil)) ;;; Bit vectors (deftest make-sequence.37 (make-sequence 'bit-vector 5 :initial-element 0) #*00000) (deftest make-sequence.38 (make-sequence 'bit-vector 7 :initial-element 1) #*1111111) (deftest make-sequence.39 (make-sequence 'bit-vector 0) #*) (deftest make-sequence.40 (make-sequence '(bit-vector) 4 :initial-element 1) #*1111) (deftest make-sequence.41 (make-sequence '(bit-vector *) 10 :initial-element 0) #*0000000000) (deftest make-sequence.42 (make-sequence '(bit-vector 5) 5 :initial-element 0) #*00000) (deftest make-sequence.43 (make-sequence 'simple-bit-vector 5 :initial-element 0) #*00000) (deftest make-sequence.44 (make-sequence 'simple-bit-vector 7 :initial-element 1) #*1111111) (deftest make-sequence.45 (make-sequence 'simple-bit-vector 0) #*) (deftest make-sequence.46 (make-sequence '(simple-bit-vector) 4 :initial-element 1) #*1111) (deftest make-sequence.47 (make-sequence '(simple-bit-vector *) 10 :initial-element 0) #*0000000000) (deftest make-sequence.48 (make-sequence '(simple-bit-vector 5) 5 :initial-element 0) #*00000) (deftest make-sequence.49 (if (subtypep (class-of nil) 'sequence) (make-sequence (class-of nil) 0) nil) nil) (deftest make-sequence.50 (if (subtypep (class-of '(nil nil nil)) 'sequence) (make-sequence (class-of '(nil nil nil)) 3 :initial-element nil) '(nil nil nil)) (nil nil nil)) (deftest make-sequence.51 (loop for i from 1 to 40 for vec = (make-array 1 :element-type `(unsigned-byte ,i) :initial-element 1) for class = (class-of vec) nconc (if (subtypep class 'vector) (let ((vec2 (make-sequence class 1 :initial-element 1))) (unless (equalp vec vec) (list (list i vec class vec2)))) nil)) nil) (deftest make-sequence.52 (let ((class (class-of "aaaa"))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.53 (let ((class (class-of (make-array 4 :element-type 'base-char :fill-pointer 4 :adjustable t :initial-contents "aaaa")))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.54 (let ((class (class-of (make-array 4 :element-type 'character :fill-pointer 4 :adjustable t :initial-contents "aaaa")))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.55 (let ((class (class-of (make-array 4 :element-type 'character :initial-contents "aaaa")))) (if (subtypep class 'vector) (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.56 (loop for i from 1 to 40 for vec = (make-array 1 :element-type `(unsigned-byte ,i) :adjustable t :fill-pointer 1 :initial-element 1) for class = (class-of vec) nconc (if (subtypep class 'vector) (let ((vec2 (make-sequence class 1 :initial-element 1))) (unless (equalp vec vec) (list (list i vec class vec2)))) nil)) nil) (deftest make-sequence.57 (make-sequence (find-class 'list) 4 :initial-element 'x) (x x x x)) (deftest make-sequence.58 (make-sequence (find-class 'cons) 4 :initial-element 'x) (x x x x)) ;;; 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 (signals-error-always (make-sequence 'symbol 10) type-error) t t) (deftest make-sequence.error.2 (signals-error (make-sequence 'null 1) type-error) t) (deftest make-sequence.error.3 (signals-error (make-sequence '(vector * 4) 3) type-error) t) (deftest make-sequence.error.4 (signals-error (make-sequence '(vector * 2) 3) type-error) t) (deftest make-sequence.error.5 (signals-error (make-sequence '(string 4) 3) type-error) t) (deftest make-sequence.error.6 (signals-error (make-sequence '(simple-string 2) 3) type-error) t) (deftest make-sequence.error.7 (signals-error (make-sequence 'cons 0) type-error) t) (deftest make-sequence.error.8 (signals-error (make-sequence) program-error) t) (deftest make-sequence.error.9 (signals-error (make-sequence 'list) program-error) t) (deftest make-sequence.error.10 (signals-error (make-sequence 'list 10 :bad t) program-error) t) (deftest make-sequence.error.11 (signals-error (make-sequence 'list 10 :bad t :allow-other-keys nil) program-error) t) (deftest make-sequence.error.12 (signals-error (make-sequence 'list 10 :initial-element) program-error) t) (deftest make-sequence.error.13 (signals-error (make-sequence 'list 10 0 0) program-error) t) (deftest make-sequence.error.14 (signals-error-always (locally (make-sequence 'symbol 10) t) type-error) t t) (deftest make-sequence.error.15 :notes (:result-type-element-type-by-subtype) (if (subtypep '(or (vector bit) (vector t)) 'vector) (signals-error (make-sequence '(or (vector bit) (vector t)) 10 :initial-element 0) error) t) t) (deftest make-sequence.error.16 (signals-error-always (make-sequence (find-class 'integer) 0) type-error) t t) ;;; 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) ;;; Const fold tests (def-fold-test make-sequence.fold.1 (make-sequence 'list 5 :initial-element 'a)) (def-fold-test make-sequence.fold.2 (make-sequence 'vector 5 :initial-element 'a)) (def-fold-test make-sequence.fold.3 (make-sequence 'bit-vector 5 :initial-element 0)) (def-fold-test make-sequence.fold.4 (make-sequence 'string 5 :initial-element #\a)) ;;; FIXME: Add tests for upgrading of character subtypes gcl-2.7.1/ansi-tests/PaxHeaders/random-class-aux.lsp0000644000000000000000000000013114542551763017347 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.769790401 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-class-aux.lsp0000644000175000017500000000217214542551763016750 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 10 07:14:30 2004 ;;;; Contains: Aux. functions for random tests on classes (in-package :cl-test) (defun random-class-1-fn (&key (n 10) (rep 1000)) "Randomly break and recreate a linear chain of class definitions" (assert (typep n '(integer 1)) (n) "N is ~A" n) (assert (typep rep 'unsigned-byte) (rep) "REP is ~A" rep) (let ((class-names (make-array n :initial-contents (loop for i from 1 to n collect (make-symbol (format nil "CLASS-NAME-~D" i)))))) (unwind-protect (let ((parents (make-array n :initial-element nil))) ;; Create classes (loop for name across class-names do (eval `(defclass ,name () nil))) (loop for i = (1+ (random (1- n))) for name = (elt class-names i) for parent = (elt parents i) repeat rep do (if parent (progn (setf (elt parents i) nil) (eval `(defclass ,name () nil))) (eval `(defclass ,name (,(setf (elt parents i) (elt class-names (1- i)))) nil ))))) (loop for name across class-names do (setf (find-class name) nil))))) gcl-2.7.1/ansi-tests/PaxHeaders/read.lsp0000644000000000000000000000013114542551763015104 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.769790401 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read.lsp0000644000175000017500000000621114542551763014503 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 31 07:52:06 2004 ;;;; Contains: Tests of READ (in-package :cl-test) ;;; Input stream designators (deftest read.1 (block done (with-input-from-string (is "1 2 3") (with-output-to-string (os) (with-open-stream (*terminal-io* (make-two-way-stream is os)) (return-from done (read t)))))) 1) (deftest read.2 (with-input-from-string (*standard-input* "1 2 3") (read nil)) 1) (deftest read.3 (with-input-from-string (*standard-input* "1 2 3") (read)) 1) (deftest read.4 (with-input-from-string (s "1 2 3") (read s)) 1) ;;; eof handling (deftest read.5 (with-input-from-string (s "") (read s nil)) nil) (deftest read.6 (with-input-from-string (s "") (read s nil 'foo)) foo) (deftest read.7 (with-input-from-string (s "1") (read s)) 1) (deftest read.8 (let ((*package* (find-package "CL-TEST"))) (with-input-from-string (s "X") (read s))) |X|) (deftest read.9 (with-input-from-string (s "1.2") (read s)) 1.2) (deftest read.10 (with-input-from-string (s "1.0s0") (read s)) 1.0s0) (deftest read.11 (with-input-from-string (s "1.0f0") (read s)) 1.0f0) (deftest read.12 (with-input-from-string (s "1.0d0") (read s)) 1.0d0) (deftest read.13 (with-input-from-string (s "1.0l0") (read s)) 1.0l0) (deftest read.14 (with-input-from-string (s "()") (read s)) nil) (deftest read.15 (with-input-from-string (s "(1 2 3)") (read s)) (1 2 3)) ;;; Throwing away whitespace chars (deftest read.16 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read s) :|ABC|)) (read-char s))) #\X) (deftest read.17 (with-standard-io-syntax (with-input-from-string (s ":ABC X") (assert (eq (read s) :|ABC|)) (read-char s))) #\Space) (deftest read.18 (with-standard-io-syntax (with-input-from-string (s ":ABC(") (assert (eq (read s) :|ABC|)) (read-char s))) #\() ;;; eof value (deftest read.19 (with-input-from-string (s "") (read s nil 'foo)) foo) ;;; Error tests (deftest read.error.1 (signals-error (with-input-from-string (s "") (read s)) end-of-file) t) (deftest read.error.2 (signals-error (with-input-from-string (s "") (read s)) stream-error) t) (deftest read.error.3 (signals-error (with-input-from-string (s "") (read s t)) stream-error) t) (deftest read.error.4 (signals-error (with-input-from-string (s "(") (read s nil)) end-of-file) t) (deftest read.error.5 (signals-error (with-input-from-string (s "(") (read s t)) end-of-file) t) (deftest read.error.6 (signals-error (with-input-from-string (s "#(") (read s t)) end-of-file) t) (deftest read.error.7 (signals-error (with-input-from-string (s "#S(") (read s t)) end-of-file) t) ;;; Note -- cannot easily test calls with RECURSIVE-P set to T ;;; These have to be done from reader macro functions so that READ is not ;;; called without having any requisite dynamic environment created ;;; around the call. (deftest read.error.8 (signals-error (with-input-from-string (s "1 2 3") (read s nil nil nil nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/read-char-no-hang.lsp0000644000000000000000000000013114542551763017344 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.769790401 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/read-char-no-hang.lsp0000644000175000017500000000475014542551763016751 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/packages-06.lsp0000644000000000000000000000013114542551763016172 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.769790401 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-06.lsp0000644000175000017500000001114214542551763015570 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/concatenated-stream-streams.lsp0000644000000000000000000000013014542551762021564 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.769790401 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/concatenated-stream-streams.lsp0000644000175000017500000000313214542551762021163 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/ensure-generic-function.lsp0000644000000000000000000000013214542551762020727 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.769790401 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ensure-generic-function.lsp0000644000175000017500000001373514542551762020336 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Mar 27 21:29:53 2003 ;;;; Contains: Tests for ENSURE-GENERIC-FUNCTION (in-package :cl-test) (deftest ensure-generic-function.1 (if (typep #'car 'generic-function) t (signals-error (ensure-generic-function 'car) error)) t) (deftest ensure-generic-function.2 (signals-error (ensure-generic-function 'defclass) error) t) (deftest ensure-generic-function.3 (signals-error (ensure-generic-function 'tagbody) error) t) (deftest ensure-generic-function.4 (let ((f 'egf-fun-4)) (when (fboundp f) (fmakunbound f)) (values (fboundp f) (notnot-mv (typep (ensure-generic-function f) 'generic-function)) (notnot-mv (typep (ensure-generic-function f) 'generic-function)) (notnot-mv (typep (symbol-function f) 'generic-function)))) nil t t t) (deftest ensure-generic-function.5 (let ((f 'egf-fun-5)) (when (fboundp f) (fmakunbound f)) (values (fboundp f) (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) 'generic-function)) ;; Test of incongruent generic function lambda list when no ;; methods exist (notnot-mv (typep (ensure-generic-function f :lambda-list '(x y)) 'generic-function)) (notnot-mv (typep (symbol-function f) 'generic-function)))) nil t t t) (deftest ensure-generic-function.6 (let ((f 'egf-fun-6)) (when (fboundp f) (fmakunbound f)) (values (fboundp f) (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) 'generic-function)) (notnot-mv (eval `(defmethod ,f ((a t)(b t)(c t)) (list a b c)))) ;; Test of incongruent generic function lambda list when no ;; methods exist (eval `(signals-error (ensure-generic-function ',f :lambda-list '(x y)) error)))) nil t t t) (deftest ensure-generic-function.7 (let ((f 'egf-fun-7)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method ((x symbol)) (list x :a)) (:method ((x integer)) (list x :b)) (:method ((x t)) (list x :c)))))) (values (mapcar fn '(x 2 3/2)) (eqlt fn (ensure-generic-function f :lambda-list '(x))) (mapcar fn '(x 2 3/2))))) ((x :a) (2 :b) (3/2 :c)) t ((x :a) (2 :b) (3/2 :c))) (deftest ensure-generic-function.8 (let ((f 'egf-fun-8)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x y) (:method ((x t) (y symbol)) 1) (:method ((x symbol) (y t)) 2))))) (values (mapcar fn '(a a 3) '(b 4 b)) (eqlt fn (ensure-generic-function f :lambda-list '(x y) :argument-precedence-order '(y x))) (mapcar fn '(a a 3) '(b 4 b))))) (2 2 1) t (1 2 1)) (deftest ensure-generic-function.9 (let ((f 'egf-fun-9)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method-combination +) (:method + ((x t)) 1) (:method + ((x symbol)) 2) (:method + ((x (eql nil))) 4))))) (values (mapcar fn '(3/2 a nil)) (eqlt fn (ensure-generic-function f :lambda-list '(x) :method-class 'standard-method)) (mapcar fn '(3/2 a nil)) (eqlt fn (ensure-generic-function f :lambda-list '(x) :method-class (find-class 'standard-method))) (mapcar fn '(3/2 a nil))))) (1 3 7) t (1 3 7) t (1 3 7)) (deftest ensure-generic-function.10 (let ((f 'egf-fun-10)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method ((x t)) 1))))) (values (funcall fn 'a) (eqlt fn (ensure-generic-function f :lambda-list '(x) :generic-function-class 'standard-generic-function)) (funcall fn 'a) (eqlt fn (ensure-generic-function f :lambda-list '(x) :generic-function-class (find-class 'standard-generic-function))) (funcall fn 'a)))) 1 t 1 t 1) (deftest ensure-generic-function.11 (let ((f 'egf-fun-11)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:method ((x t)) 1))))) (values (funcall fn 'a) (eqlt fn (eval `(macrolet ((%m (&environment env) (ensure-generic-function ',f :lambda-list '(x) :environment env))) (%m)))) (funcall fn 'a)))) 1 t 1) (deftest ensure-generic-function.12 (let ((f 'egf-fun-12)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) (:documentation "foo") (:method ((x t)) 1))))) (values (funcall fn 'a) (or (documentation f 'function) "foo") (eqlt fn (ensure-generic-function f :lambda-list '(x) :documentation "bar")) (or (documentation f 'function) "bar") (funcall fn 'a)))) 1 "foo" t "bar" 1) (deftest ensure-generic-function.13 (let ((f 'egf-fun-13)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x y) (declare (optimize safety (speed 0) (debug 0) (space 0))) (:method ((x t) (y t)) (list x y)))))) (values (funcall fn 'a 'b) (eqlt fn (ensure-generic-function f :lambda-list '(x y) :declare '((optimize (safety 0) (debug 2) speed (space 1))))) (funcall fn 'a 1)))) (a b) t (a 1)) (deftest ensure-generic-function.14 (let ((f '(setf egf-fun-14))) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (val x) (:method ((val t) (x cons)) (setf (car x) val)))))) (values (let ((z (cons 'a 'b))) (list (setf (egf-fun-14 z) 'c) z)) (eqlt fn (ensure-generic-function f :lambda-list '(val x))) (let ((z (cons 'a 'b))) (list (setf (egf-fun-14 z) 'c) z))))) (c (c . b)) t (c (c . b))) ;;; Many more tests are needed for other combinations of keyword parameters (deftest ensure-generic-function.error.1 (signals-error (ensure-generic-function) program-error) t) (deftest ensure-generic-function.error.2 (signals-error (ensure-generic-function (gensym) :lambda-list) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/unbound-slot.lsp0000644000000000000000000000013114542551763016622 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.769790401 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/unbound-slot.lsp0000644000175000017500000000143514542551763016224 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 4 20:14:26 2003 ;;;; Contains: Tests for UNBOUND-SLOT, UNBOUND-SLOT-INSTANCE (in-package :cl-test) (defclass ubs-class-01 () ((a :initarg :a))) (deftest unbound-slot.1 (let ((obj (make-instance 'ubs-class-01))) (handler-case (slot-value obj 'a) (unbound-slot (c) (values (typep* c 'cell-error) (eqt (unbound-slot-instance c) obj) (cell-error-name c))))) t t a) (defclass ubs-class-02 () ((b :allocation :class))) (deftest unbound-slot.2 (let ((obj (make-instance 'ubs-class-02))) (handler-case (slot-value obj 'b) (unbound-slot (c) (values (typep* c 'cell-error) (eqt (unbound-slot-instance c) obj) (cell-error-name c))))) t t b) gcl-2.7.1/ansi-tests/PaxHeaders/optimize.lsp0000644000000000000000000000013114542551763016031 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.769790401 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/optimize.lsp0000644000175000017500000000221214542551763015425 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 09:31:34 2005 ;;;; Contains: Tests of the OPTIMIZE declaration (in-package :cl-test) (deftest optimize.1 (locally (declare (optimize)) nil) nil) (deftest optimize.2 (locally (declare (optimize speed)) nil) nil) (deftest optimize.3 (locally (declare (optimize space)) nil) nil) (deftest optimize.4 (locally (declare (optimize safety)) nil) nil) (deftest optimize.5 (locally (declare (optimize debug)) nil) nil) (deftest optimize.6 (locally (declare (optimize compilation-speed)) nil) nil) (deftest optimize.7 (loop for d in '(speed space safety debug compilation-speed) nconc (loop for n from 0 to 3 for form = `(locally (declare (optimize (,d ,n))) t) for val = (eval form) unless (eql val t) collect (list d n val))) nil) (deftest optimize.8 (loop for d in '(speed space safety debug compilation-speed) nconc (loop for n from 0 to 3 for form = `(lambda () (declare (optimize (,d ,n))) t) for val = (funcall (compile nil form)) unless (eql val t) collect (list d n val))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/map-into.lsp0000644000000000000000000000013214542551763015716 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.769790401 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/map-into.lsp0000644000175000017500000003134514542551763015322 0ustar00cammcamm;-*- 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") (deftest map-into-string.13 (do-special-strings (s (copy-seq "12345") nil) (let ((s2 (map-into s #'identity "abcde"))) (assert (eq s s2)) (assert (string= s2 "abcde")))) nil) (deftest map-into-string.14 (do-special-strings (s "abcde" nil) (let* ((s1 (copy-seq "123456")) (s2 (map-into s1 #'identity s))) (assert (eq s1 s2)) (assert (string= s2 "abcde6")))) nil) ;;; 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) ;;; Other specialized vectors (deftest map-into.specialized-vector.1 (do-special-integer-vectors (v #(1 2 3 4) nil) (let ((result (list nil nil nil nil))) (assert (eq (map-into result #'identity v) result)) (assert (equal result '(1 2 3 4))))) nil) (deftest map-into.specialized-vector.2 (do-special-integer-vectors (v #(1 2 3) nil) (let ((result (list nil nil nil nil))) (assert (eq (map-into result #'identity v) result)) (assert (equal result '(1 2 3 nil))))) nil) (deftest map-into.specialized-vector.3 (do-special-integer-vectors (v #(1 1 0 1 1) nil) (let ((result (list nil nil nil nil))) (assert (eq (map-into result #'identity v) result)) (assert (equal result '(1 1 0 1))))) nil) (deftest map-into.specialized-vector.4 (do-special-integer-vectors (v #(1 2 1 2 2) nil) (let ((v2 #(2 1 2 2 1))) (assert (eq (map-into v #'identity v2) v)) (assert (equalp v #(2 1 2 2 1))))) nil) (deftest map-into.specialized-vector.5 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for i below len collect (coerce i etype)) for vec = (make-array len :initial-contents vals :element-type etype) for target = (loop repeat len collect nil) for result = (map-into target #'identity vec) unless (and (eq target result) (= (length result) len) (= (length vec) len) (equal vals result)) collect (list etype vals vec result))) nil) (deftest map-into.specialized-vector.6 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :initial-contents vals :element-type etype) for target = (loop repeat len collect nil) for result = (map-into target #'identity vec) unless (and (eq target result) (= (length result) len) (= (length vec) len) (equal vals result)) collect (list etype vals vec result))) nil) (deftest map-into.specialized-vector.7 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for i below len collect (coerce i etype)) for target = (make-array len :initial-contents vals :element-type etype) for result = (map-into target #'identity vals) unless (and (eq target result) (= (length result) len) (every #'= result vals)) collect (list etype vals result))) nil) (deftest map-into.specialized-vector.8 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float) for etype = `(complex ,cetype) for vals = (loop for i from 1 to len collect (complex (coerce i cetype) (coerce (- i) cetype))) for target = (make-array len :initial-contents vals :element-type etype) for result = (map-into target #'identity vals) unless (and (eq target result) (= (length result) len) (every #'= result vals)) collect (list etype vals result))) nil) ;;; Error cases (deftest map-into.error.1 (check-type-error #'(lambda (x) (map-into x (constantly nil))) #'sequencep) nil) ;;; 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 (and (locally (declare (optimize (safety 3))) (handler-case (eval '(map-into nil #'identity 'a)) (type-error () nil))) :bad) nil) (deftest map-into.error.3 (check-type-error #'(lambda (x) (map-into (copy-seq '(a b c)) #'cons '(d e f) x)) #'sequencep) nil) (deftest map-into.error.4 (signals-error (map-into) program-error) t) (deftest map-into.error.5 (signals-error (map-into (list 'a 'b 'c)) program-error) t) (deftest map-into.error.6 (signals-error (locally (map-into 'a #'(lambda () nil)) t) type-error) t) (deftest map-into.error.7 (signals-error (map-into (list 'a 'b 'c) #'cons '(a b c)) program-error) t) (deftest map-into.error.8 (signals-error (map-into (list 'a 'b 'c) #'car '(a b c)) type-error) t) ;;; 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.7.1/ansi-tests/PaxHeaders/truncate.lsp0000644000000000000000000000013114542551763016016 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.769790401 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/truncate.lsp0000644000175000017500000000716014542551763015421 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 05:13:26 2003 ;;;; Contains: Tests of TRUNCATE (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "truncate-aux.lsp") (deftest truncate.error.1 (signals-error (truncate) program-error) t) (deftest truncate.error.2 (signals-error (truncate 1.0 1 nil) program-error) t) ;;; (deftest truncate.1 (truncate.1-fn) nil) (deftest truncate.2 (truncate.2-fn) nil) (deftest truncate.3 (truncate.3-fn 2.0s4) nil) (deftest truncate.4 (truncate.3-fn 2.0f4) nil) (deftest truncate.5 (truncate.3-fn 2.0d4) nil) (deftest truncate.6 (truncate.3-fn 2.0l4) nil) (deftest truncate.7 (truncate.7-fn) nil) (deftest truncate.8 (truncate.8-fn) nil) (deftest truncate.9 (truncate.9-fn) nil) (deftest truncate.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (truncate x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest truncate.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (truncate (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest truncate.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest truncate.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (truncate x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/defmacro.lsp0000644000000000000000000000013214542551762015751 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.769790401 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defmacro.lsp0000644000175000017500000002117314542551762015353 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 12:35:24 2003 ;;;; Contains: Tests of DEFMACRO (in-package :cl-test) (deftest defmacro.error.1 (signals-error (funcall (macro-function 'defmacro)) program-error) t) (deftest defmacro.error.2 (signals-error (funcall (macro-function 'defmacro) '(defmacro nonexistent-macro ())) program-error) t) (deftest defmacro.error.3 (signals-error (funcall (macro-function 'defmacro) '(defmacro nonexistent-macro ()) nil nil) program-error) t) ;;; FIXME ;;; Need to add non-error tests (deftest defmacro.1 (progn (assert (eq (defmacro defmacro.1-macro (x y) `(list 1 ,x 2 ,y 3)) 'defmacro.1-macro)) (assert (macro-function 'defmacro.1-macro)) (eval `(defmacro.1-macro 'a 'b))) (1 a 2 b 3)) (deftest defmacro.2 (progn (assert (eq (defmacro defmacro.2-macro (x y) (return-from defmacro.2-macro `(cons ,x ,y))) 'defmacro.2-macro)) (assert (macro-function 'defmacro.2-macro)) (eval `(defmacro.2-macro 'a 'b))) (a . b)) ;;; The macro function is defined in the lexical environment in which ;;; the defmacro form occurs. (deftest defmacro.3 (let (fn) (let ((x 0)) (setq fn #'(lambda (n) (setq x n))) (defmacro defmacro.3-macro () `',x)) (values (eval '(defmacro.3-macro)) (funcall fn 'a) (eval '(defmacro.3-macro)))) 0 a a) ;;; Declarations are allowed. ;;; Free special declarations do not apply to the forms ;;; in the lambda list (deftest defmacro.4 (let ((y :good)) (assert (eq (defmacro defmacro.4-macro (&optional (x y)) (declare (special y)) x) 'defmacro.4-macro)) (let ((y :bad)) (declare (special y)) (values (macroexpand-1 '(defmacro.4-macro))))) :good) (deftest defmacro.5 (progn (assert (eq (defmacro defmacro.5-macro () (declare) (declare) "a doc string" (declare) t) 'defmacro.5-macro)) (eval `(defmacro.5-macro))) t) ;;; &whole argument, top level (deftest defmacro.6 (progn (defmacro defmacro.6-macro (&whole w arg) `(list ',w ',arg)) (eval `(defmacro.6-macro x))) ((defmacro.6-macro x) x)) ;;; &whole argument in destructuring (deftest defmacro.7 (progn (defmacro defmacro.7-macro (arg1 (&whole w arg2)) `(list ',w ',arg1 ',arg2)) (eval `(defmacro.7-macro x (y)))) ((y) x y)) ;;; keyword parameters (deftest defmacro.8 (progn (defmacro defmacro.8-macro (&key foo bar) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.8-macro :foo x) (defmacro.8-macro :bar y) (defmacro.8-macro :bar a :foo b) (defmacro.8-macro :bar a :foo b :bar c)))) ((x nil) (nil y) (b a) (b a))) ;;; keyword parameters with default value (deftest defmacro.9 (progn (defmacro defmacro.9-macro (&key (foo 1) (bar 2)) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.9-macro :foo x) (defmacro.9-macro :bar y) (defmacro.9-macro :foo nil) (defmacro.9-macro :bar nil) (defmacro.9-macro :bar a :foo b) (defmacro.9-macro :bar a :foo b :bar c)))) ((x 2) (1 y) (nil 2) (1 nil) (b a) (b a))) ;;; keyword parameters with supplied-p parameter (deftest defmacro.10 (progn (defmacro defmacro.10-macro (&key (foo 1 foo-p) (bar 2 bar-p)) `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p))) (mapcar #'eval '((defmacro.10-macro) (defmacro.10-macro :foo x) (defmacro.10-macro :bar y) (defmacro.10-macro :foo nil) (defmacro.10-macro :bar nil) (defmacro.10-macro :foo x :bar y) (defmacro.10-macro :bar y :foo x) (defmacro.10-macro :bar a :bar b) (defmacro.10-macro :foo a :foo b)))) ((1 nil 2 nil) (x t 2 nil) (1 nil y t) (nil t 2 nil) (1 nil nil t) (x t y t) (x t y t) (1 nil a t) (a t 2 nil))) ;;; key arguments in destructuring (deftest defmacro.11 (progn (defmacro defmacro.11-macro ((&key foo bar)) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.11-macro nil) (defmacro.11-macro (:foo x)) (defmacro.11-macro (:bar y)) (defmacro.11-macro (:foo x :bar y :foo z)) (defmacro.11-macro (:bar y :bar z :foo x))))) ((nil nil) (x nil) (nil y) (x y) (x y))) ;;; key arguments in destructuring and defaults (deftest defmacro.12 (progn (let ((foo-default 1) (bar-default 2)) (defmacro defmacro.12-macro ((&key (foo foo-default) (bar bar-default))) `(list ',foo ',bar))) (mapcar #'eval '((defmacro.12-macro nil) (defmacro.12-macro (:foo x)) (defmacro.12-macro (:bar y)) (defmacro.12-macro (:foo x :bar y :foo z)) (defmacro.12-macro (:bar y :bar z :foo x))))) ((1 2) (x 2) (1 y) (x y) (x y))) ;;; key arguments in destructuring and supplied-p parameter (deftest defmacro.13 (progn (let ((foo-default 1) (bar-default 2)) (defmacro defmacro.13-macro ((&key (foo foo-default foo-p) (bar bar-default bar-p))) `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p)))) (mapcar #'eval '((defmacro.13-macro nil) (defmacro.13-macro (:foo x)) (defmacro.13-macro (:bar y)) (defmacro.13-macro (:foo nil :bar nil :foo 4 :bar 14)) (defmacro.13-macro (:foo 1 :bar 2)) (defmacro.13-macro (:foo x :bar y :foo z)) (defmacro.13-macro (:bar y :bar z :foo x))))) ((1 nil 2 nil) (x t 2 nil) (1 nil y t) (nil t nil t) (1 t 2 t) (x t y t) (x t y t))) ;;; rest parameter (deftest defmacro.14 (progn (defmacro defmacro.14-macro (foo &rest bar) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.14-macro x) (defmacro.14-macro x y) (defmacro.14-macro x y z)))) ((x nil) (x (y)) (x (y z)))) ;;; rest parameter with destructuring (deftest defmacro.15 (progn (defmacro defmacro.15-macro (foo &rest (bar . baz)) `(list ',foo ',bar ',baz)) (eval '(defmacro.15-macro x y z))) (x y (z))) ;;; rest parameter w. whole (deftest defmacro.16 (progn (defmacro defmacro.16-macro (&whole w foo &rest bar) `(list ',w ',foo ',bar)) (mapcar #'eval '((defmacro.16-macro x) (defmacro.16-macro x y) (defmacro.16-macro x y z)))) (((defmacro.16-macro x) x nil) ((defmacro.16-macro x y) x (y)) ((defmacro.16-macro x y z) x (y z)))) ;;; env parameter (deftest defmacro.17 (progn (defmacro defmacro.17-macro (x &environment env) `(quote ,(macroexpand x env))) (eval `(macrolet ((%m () :good)) (defmacro.17-macro (%m))))) :good) (deftest defmacro.17a (progn (defmacro defmacro.17a-macro (&environment env x) `(quote ,(macroexpand x env))) (eval `(macrolet ((%m () :good)) (defmacro.17a-macro (%m))))) :good) ;;; &optional with supplied-p parameter ;;; Note: this is required to be T if the parameter is present (3.4.4.1.2) (deftest defmacro.18 (progn (defmacro defmacro.18-macro (x &optional (y 'a y-p) (z 'b z-p)) `(list ',x ',y ',y-p ',z ',z-p)) (mapcar #'eval '((defmacro.18-macro p) (defmacro.18-macro p q) (defmacro.18-macro p q r)))) ((p a nil b nil) (p q t b nil) (p q t r t))) ;;; Optional with destructuring (deftest defmacro.19 (progn (defmacro defmacro.19-macro (&optional ((x . y) '(a . b))) `(list ',x ',y)) (mapcar #'eval '((defmacro.19-macro) (defmacro.19-macro (c d))))) ((a b) (c (d)))) ;;; Allow other keys (deftest defmacro.20 (progn (defmacro defmacro.20-macro (&key x y z &allow-other-keys) `(list ',x ',y ',z)) (mapcar #'eval '((defmacro.20-macro) (defmacro.20-macro :x a) (defmacro.20-macro :y b) (defmacro.20-macro :z c) (defmacro.20-macro :x a :y b) (defmacro.20-macro :z c :y b) (defmacro.20-macro :z c :x a) (defmacro.20-macro :z c :x a :y b) (defmacro.20-macro nil nil) (defmacro.20-macro :allow-other-keys nil) (defmacro.20-macro :allow-other-keys nil :foo bar) (defmacro.20-macro :z c :z nil :x a :abc 0 :y b :x t)))) ((nil nil nil) (a nil nil) (nil b nil) (nil nil c) (a b nil) (nil b c) (a nil c) (a b c) (nil nil nil) (nil nil nil) (nil nil nil) (a b c))) (deftest defmacro.21 (progn (defmacro defmacro.21-macro (&key x y z) `(list ',x ',y ',z)) (mapcar #'eval '((defmacro.21-macro) (defmacro.21-macro :x a) (defmacro.21-macro :y b) (defmacro.21-macro :z c) (defmacro.21-macro :x a :y b) (defmacro.21-macro :z c :y b) (defmacro.21-macro :z c :x a) (defmacro.21-macro :z c :x a :y b) (defmacro.21-macro :allow-other-keys nil) (defmacro.21-macro :allow-other-keys t :foo bar)))) ((nil nil nil) (a nil nil) (nil b nil) (nil nil c) (a b nil) (nil b c) (a nil c) (a b c) (nil nil nil) (nil nil nil))) gcl-2.7.1/ansi-tests/PaxHeaders/logtest.lsp0000644000000000000000000000013214542551763015653 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.773790419 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logtest.lsp0000644000175000017500000000171114542551763015251 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 11 23:22:46 2003 ;;;; Contains: Tests for LOGTEST (in-package :cl-test) ;;; Error tests (deftest logtest.error.1 (signals-error (logtest) program-error) t) (deftest logtest.error.2 (signals-error (logtest 0) program-error) t) (deftest logtest.error.3 (signals-error (logtest 0 0 nil) program-error) t) (deftest logtest.error.4 (check-type-error #'(lambda (x) (logtest x -1)) #'integerp) nil) (deftest logtest.error.5 (check-type-error #'(lambda (x) (logtest -1 x)) #'integerp) nil) ;;; Non-error tests (deftest logtest.1 (loop for x = (logand (random-fixnum) (random-fixnum)) for y = (logand (random-fixnum) (random-fixnum)) repeat 10000 unless (if (logtest x y) (not (zerop (logand x y))) (zerop (logand x y))) collect (list x y)) nil) (deftest logtest.2 (logtest 1 2) nil) (deftest logtest.3 (notnot-mv (logtest 8 (logior 8 4))) t) gcl-2.7.1/ansi-tests/PaxHeaders/cltest.system0000644000000000000000000000013014542551762016213 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.773790419 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cltest.system0000644000175000017500000000505314542551762015616 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/eql.lsp0000644000000000000000000000013214542551762014752 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.773790419 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/eql.lsp0000644000175000017500000000262214542551762014352 0ustar00cammcamm;-*- 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 (check-predicate #'(lambda (x) (eql x x))) nil) (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) ;;; Error tests for EQL (deftest eql.error.1 (signals-error (eql) program-error) t) (deftest eql.error.2 (signals-error (eql nil) program-error) t) (deftest eql.error.3 (signals-error (eql nil nil nil) program-error) t) ;;; Error tests for EQ (deftest eq.error.1 (signals-error (eq) program-error) t) (deftest eq.error.2 (signals-error (eq nil) program-error) t) (deftest eq.error.3 (signals-error (eq nil nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-tilde.lsp0000644000000000000000000000013214542551762016560 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.773790419 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-tilde.lsp0000644000175000017500000000343614542551762016164 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 28 00:27:00 2004 ;;;; Contains: Tests of format directive ~~ (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.~.1 "~~" nil "~") (deftest format.~.2 (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for format-string = (format nil "~~~D~~" i) for s2 = (format nil format-string) unless (string= s s2) collect (list i s s2)) nil) (deftest formatter.~.2 (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for format-string = (format nil "~~~D~~" i) for fn = (eval `(formatter ,format-string)) for s2 = (formatter-call-to-string fn) unless (string= s s2) collect (list i s s2)) nil) (def-format-test format.~.3 "~v~" (0) "") (deftest format.~.4 (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for s2 = (format nil "~V~" i) unless (string= s s2) collect (list i s s2)) nil) (deftest formatter.~.4 (let ((fn (formatter "~v~"))) (loop for i from 0 to 100 for s = (make-string i :initial-element #\~) for s2 = (formatter-call-to-string fn i) unless (string= s s2) collect (list i s s2))) nil) (deftest format.~.5 (loop for i from 0 to (min (- call-arguments-limit 3) 100) for s = (make-string i :initial-element #\~) for args = (make-list i) for s2 = (apply #'format nil "~#~" args) unless (string= s s2) collect (list i s s2)) nil) (deftest formatter.~.5 (let ((fn (formatter "~#~"))) (loop for i from 0 to (min (- call-arguments-limit 3) 100) for s = (make-string i :initial-element #\~) for args = (make-list i) for s2 = (with-output-to-string (stream) (assert (equal (apply fn stream args) args))) unless (string= s s2) collect (list i s s2))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/get-output-stream-string.lsp0000644000000000000000000000013114542551762021102 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.773790419 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/get-output-stream-string.lsp0000644000175000017500000000136414542551762020505 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/symbol-function.lsp0000644000000000000000000000013114542551763017321 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.773790419 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/symbol-function.lsp0000644000175000017500000000174114542551763016723 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 13 07:38:43 2004 ;;;; Contains: Tests of SYMBOL-FUNCTION (in-package :cl-test) (deftest symbol-function.1 (let ((sym (gensym)) (f #'(lambda () (values 1 2 3)))) (values (eqt (setf (symbol-function sym) f) f) (multiple-value-list (eval (list sym))))) t (1 2 3)) ;;; Error cases (deftest symbol-function.error.1 (signals-error (symbol-function) program-error) t) (deftest symbol-function.error.2 (signals-error (symbol-function 'cons nil) program-error) t) (deftest symbol-function.error.3 (check-type-error #'symbol-function #'symbolp) nil) (deftest symbol-function.error.4 (check-type-error #'(lambda (x) (setf (symbol-function x) #'identity)) #'symbolp) nil) (deftest symbol-function.error.5 (let ((sym (gensym))) (handler-case (progn (symbol-function sym) nil) (undefined-function (c) (assert (eq (cell-error-name c) sym)) :good))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/readtable-case.lsp0000644000000000000000000000013114542551763017025 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.773790419 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/readtable-case.lsp0000644000175000017500000000360414542551763016427 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 1 18:43:46 2005 ;;;; Contains: Tests of READTABLE-CASE (in-package :cl-test) (deftest readtable-case.1 (with-standard-io-syntax (readtable-case *readtable*)) :upcase) (deftest readtable-case.2 (with-standard-io-syntax (let ((rt (copy-readtable))) (readtable-case rt))) :upcase) (deftest readtable-case.3 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :upcase) (readtable-case rt))) :upcase :upcase) (deftest readtable-case.4 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :downcase) (readtable-case rt))) :downcase :downcase) (deftest readtable-case.5 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :preserve) (readtable-case rt))) :preserve :preserve) (deftest readtable-case.6 (let ((rt (copy-readtable))) (values (setf (readtable-case rt) :invert) (readtable-case rt))) :invert :invert) (deftest readtable-case.7 (let ((rt (copy-readtable))) (loop for rtc in '(:upcase :downcase :preserve :invert) do (setf (readtable-case rt) rtc) nconc (let ((rt2 (copy-readtable rt))) (unless (eq (readtable-case rt2) rtc) (list rtc rt2))))) nil) ;;; Error cases (deftest readtable-case.error.1 (signals-error (readtable-case) program-error) t) (deftest readtable-case.error.2 (signals-error (readtable-case *readtable* nil) program-error) t) (deftest readtable-case.error.3 (check-type-error #'readtable-case (typef 'readtable)) nil) (deftest readtable-case.error.4 (check-type-error #'(lambda (x) (let ((rt (copy-readtable))) (setf (readtable-case rt) x))) (typef '(member :upcase :downcase :preserve :invert))) nil) (deftest readtable-case.error.5 (check-type-error #'(lambda (x) (setf (readtable-case x) :upcase)) (typef 'readtable)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/unread-char.lsp0000644000000000000000000000013114542551763016362 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.773790419 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/unread-char.lsp0000644000175000017500000000342214542551763015762 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/random-types.lsp0000644000000000000000000000013114542551763016613 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.773790419 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random-types.lsp0000644000175000017500000002422314542551763016215 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 6 05:04:45 2003 ;;;; Contains: Generating random types and testing relationships on them (in-package :cl-test) (compile-and-load "types-aux.lsp") (compile-and-load "random-aux.lsp") (compile-and-load "random-int-form.lsp") (defparameter *random-types* nil) (defun make-random-type (size) (if (<= size 1) (rcase (1 nil) (1 t) (1 `(eql ,(let ((r (ash 1 (random 45)))) (random-from-interval r (- r))))) (1 (random-from-seq #(integer unsigned-byte ratio rational real float short-float single-float double-float long-float complex symbol cons function))) (1 (let* ((len (random *maximum-random-int-bits*)) (r1 (ash 1 len)) (r2 (+ r1 r1)) (x (- (random r2) r1)) (y (- (random r2) r1)) (lo (min x y)) (hi (max x y))) `(integer ,lo ,hi))) (1 (make-random-real-type)) ;; (1 (make-random-complex-type)) ) (rcase (2 (let* ((op (random-from-seq #(cons cons and or))) (nargs (if (eq op 'cons) 2 (1+ (random (min size 4))))) (sizes (random-partition (1- size) nargs))) `(,op ,@(mapcar #'make-random-type sizes)))) (1 `(not ,(make-random-type (1- size)))) ; (1 (make-random-function-type size)) ))) (defun make-random-real-type () (rcase (1 (random-from-seq '(integer unsigned-byte short-float single-float double-float long-float rational real))) (1 (destructuring-bind (lo hi) (make-random-integer-range) (rcase (4 `(integer ,lo ,hi)) (1 `(integer ,lo)) (1 `(integer ,lo *)) (2 `(integer * ,hi))))) (1 (let ((r1 (random-real)) (r2 (random-real))) `(real ,(min r1 r2) ,(max r2 r2)))) ;;; Add more cases here )) (defun make-random-complex-type () `(complex ,(make-random-real-type))) (defun make-random-function-type (size) (let* ((sizes (random-partition (1- size) 2)) (types (mapcar #'make-random-type sizes))) `(function (,(car types)) ,(cadr types)))) (defun size-of-type (type) (if (consp type) (case (car type) (complex (1+ (size-of-type (cadr type)))) ((array simple-array) (1+ (size-of-type (cadr type)))) (vector (1+ (size-of-type (cadr type)))) (complex (1+ (size-of-type (cadr type)))) ((cons or and not) (reduce #'+ (cdr type) :initial-value 1 :key #'size-of-type)) (t 1)) 1)) (defun mutate-type (type) (let* ((size (size-of-type type)) (r (random size))) (flet ((%f () (rcase (6 (make-random-type (random (1+ size)))) (2 `(not ,type)) (1 `(and ,(make-random-type 1) ,type)) (1 `(and ,type ,(make-random-type 1))) (1 `(or ,(make-random-type 1) ,type)) (1 `(or ,type ,(make-random-type 1))))) (%random-int () (let ((bits (1+ (min (random 20) (random 20))))) (- (ash 1 bits) (random (ash 1 (1+ bits))))))) (if (or (and (= r 0) (coin)) (not (consp type))) (%f) (case (car type) ((and or not cons complex) (let ((sizes (mapcar #'size-of-type (cdr type)))) (loop with sum = 0 for e on sizes for ctype in (cdr type) for i from 0 do (setf sum (incf (car e) sum)) when (>= sum r) return (rcase (1 ctype) ;; replace with component type (1 (cons (car type) (append (subseq (cdr type) 0 i) (list (mutate-type ctype)) (subseq (cdr type) (1+ i))))))))) ((array simple-array vector) (let ((ctype (if (cdr type) (cadr type) t))) (rcase (1 (if (eql ctype *) t ctype)) (1 (cons (car type) (cons (mutate-type ctype) (cddr type))))))) ((unsigned-byte) (if (integerp (cadr type)) (rcase (1 'unsigned-byte) (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20)))))) (%f))) ((integer) (let ((lo-delta (%random-int)) (hi-delta (%random-int)) (old-lo (or (cadr type) '*)) (old-hi (or (caddr type) '*))) (flet ((%inc (old delta) (if (or (coin) (not (integerp old))) delta (+ old delta)))) (rcase (1 `(integer ,old-lo *)) (1 `(integer * ,old-hi)) (1 (let ((new-lo (%inc old-lo lo-delta))) (if (or (null (cdr type)) (null (cddr type)) (not (integerp old-hi))) `(integer ,new-lo ,@(cddr type)) ;; caddr is integer (if (<= new-lo old-hi) `(integer ,new-lo ,old-hi) `(integer ,old-hi ,new-lo))))) (1 (let ((new-hi (%inc old-hi hi-delta))) (if (or (null (cdr type)) (null (cddr type)) (not (integerp old-lo))) `(integer ,old-lo ,new-hi) (if (<= old-lo new-hi) `(integer ,old-lo ,new-hi) `(integer ,new-hi ,old-lo))))) (1 (let ((new-lo (%inc old-lo lo-delta)) (new-hi (%inc old-hi hi-delta))) (if (<= new-lo new-hi) `(integer ,new-lo ,new-hi) `(integer ,new-hi ,new-lo)))))))) (t (%f))))))) (defun test-random-types (n size) (loop for t1 = (make-random-type size) for t2 = (make-random-type size) for i from 0 below n ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2)) do (when (and (= (mod i 100) 0) (> i 0)) (format t "~A " i) (finish-output *standard-output*)) when (test-types t1 t2) collect (list t1 t2) finally (terpri))) (defun test-random-mutated-types (n size &key (reps 1)) (loop for t1 = (make-random-type size) for t2 = (let ((x t1)) (loop repeat reps do (setq x (mutate-type x))) x) for i from 0 below n ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2)) do (when (and (= (mod i 100) 0) (> i 0)) (format t "~A " i) (finish-output *standard-output*)) when (test-types t1 t2) collect (list t1 t2) finally (terpri))) (defun test-types (t1 t2) (multiple-value-bind (sub success) (subtypep t1 t2) (when success (if sub (check-all-subtypep t1 t2) (let ((nt1 `(not ,t1)) (nt2 `(not ,t2))) (subtypep nt2 nt1)))))) (defun prune-type (tp try-fn) (declare (type function try-fn)) (flet ((try (x) (funcall try-fn x))) (cond ((member tp '(nil t))) ((symbolp tp) (try nil) (try t)) ((consp tp) (try nil) (try t) (let ((op (first tp)) (args (rest tp))) (case op ((cons) (try 'cons) (prune-list args #'prune-type #'(lambda (args) (try `(cons ,@args))))) ((integer) (try op) (try '(eql 0)) (when (= (length args) 2) (let ((arg1 (first args)) (arg2 (second args))) (when (and (integerp arg1) (integerp arg2)) (try `(eql ,arg1)) (try `(eql ,arg2)) (when (and (< arg1 0) (<= 0 arg2)) (try `(integer 0 ,arg2))) (when (and (<= arg1 0) (< 0 arg2)) (try `(integer ,arg1 0))) (when (> (- arg2 arg1) 1) (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2)) (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2))))))))) ((real float ratio single-float double-float short-float long-float) (try op)) ((or and) (mapc try-fn args) (loop for i from 0 below (length args) do (try `(,op ,@(subseq args 0 i) ,@(subseq args (1+ i))))) (prune-list args #'prune-type #'(lambda (args) (try (cons op args))))) ((not) (let ((arg (first args))) (try arg) (when (and (consp arg) (eq (car arg) 'not)) (try (second arg))) (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) ((member) (dolist (arg (cdr tp)) (try `(eql ,arg))) (when (cddr tp) (try `(member ,@(cddr tp))))) ((eql) (assert (= (length args) 1)) (let ((arg (first args))) (unless (= arg 0) (try `(eql 0)) (cond ((< arg -1) (try `(eql ,(ceiling arg 2)))) ((> arg 1) (try `(eql ,(floor arg 2)))))))) ))))) (values)) (defun prune-type-pair (pair &optional (fn #'test-types)) (declare (type function fn)) (let ((t1 (first pair)) (t2 (second pair)) changed) (loop do (flet ((%try2 (new-tp) (when (funcall fn t1 new-tp) (print "Success in first loop") (print new-tp) (setq t2 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t2 #'%try2))) do (flet ((%try1 (new-tp) (when (funcall fn new-tp t2) (print "Success in second loop") (print new-tp) (setq t1 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t1 #'%try1))) while changed do (setq changed nil)) (list t1 t2))) (defun test-type-triple (t1 t2 t3) ;; Returns non-nil if a problem is found (catch 'problem (multiple-value-bind (sub1 success1) (subtypep t1 t2) (when success1 (if sub1 (append (check-all-subtypep t1 `(or ,t2 ,t3)) (check-all-subtypep `(and ,t1 ,t3) t2)) (or (subtypep `(or ,t1 ,t3) t2) (subtypep t1 `(and ,t2 ,t3)))))))) (defun test-random-types3 (n size) (loop for t1 = (make-random-type (1+ (random size))) for t2 = (make-random-type (1+ (random size))) for t3 = (make-random-type (1+ (random size))) for i from 1 to n ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2 t3)) do (when (and (= (mod i 100) 0) (> i 0)) (format t "~A " i) (finish-output *standard-output*)) when (test-type-triple t1 t2 t3) collect (list t1 t2 t3) finally (terpri))) (defun prune-type-triple (pair &optional (fn #'test-type-triple)) (declare (type function fn)) (let ((t1 (first pair)) (t2 (second pair)) (t3 (third pair)) changed) (loop do (flet ((%try2 (new-tp) (when (funcall fn t1 new-tp t3) (print "Success in first loop") (print new-tp) (setq t2 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t2 #'%try2))) do (flet ((%try1 (new-tp) (when (funcall fn new-tp t2 t3) (print "Success in second loop") (print new-tp) (setq t1 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t1 #'%try1))) do (flet ((%try3 (new-tp) (when (funcall fn t1 t2 new-tp) (print "Success in second loop") (print new-tp) (setq t3 new-tp changed t) (throw 'success nil)))) (catch 'success (prune-type t3 #'%try3))) while changed do (setq changed nil)) (list t1 t2 t3))) gcl-2.7.1/ansi-tests/PaxHeaders/push.lsp0000644000000000000000000000013114542551763015150 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.773790419 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/push.lsp0000644000175000017500000000264114542551763014552 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:05:34 2003 ;;;; Contains: Tests of PUSH (in-package :cl-test) (compile-and-load "cons-aux.lsp") ;;; 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)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest push.4 (macrolet ((%m (z) z)) (let ((x nil)) (values (push (expand-in-current-env (%m 1)) x) x))) (1) (1)) (deftest push.5 (macrolet ((%m (z) z)) (let ((x nil)) (values (push 1 (expand-in-current-env (%m x))) x))) (1) (1)) (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) (deftest push.order.2 (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 push.order.3 (let ((x '(a b c))) (values (push (progn (setq x '(d e)) 'z) x) x)) (z d e) (z d e)) (def-macro-test push.error.1 (push x y)) ;;; Need to add push vs. various accessors gcl-2.7.1/ansi-tests/PaxHeaders/packages-14.lsp0000644000000000000000000000013114542551763016171 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.773790419 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-14.lsp0000644000175000017500000001340314542551763015571 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/vectorp.lsp0000644000000000000000000000013214542551763015654 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.777790436 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/vectorp.lsp0000644000175000017500000000212414542551763015251 0ustar00cammcamm;-*- 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 (signals-error (vectorp) program-error) t) (deftest vectorp.error.2 (signals-error (vectorp #() #()) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/nth-value.lsp0000644000000000000000000000013114542551763016074 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.777790436 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nth-value.lsp0000644000175000017500000000274014542551763015476 0ustar00cammcamm;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest nth-value.6 (macrolet ((%m (z) z)) (nth-value (expand-in-current-env (%m 1)) (values 'a 'b 'c))) b) (deftest nth-value.7 (macrolet ((%m (z) z)) (nth-value 1 (expand-in-current-env (%m (values 'a 'b 'c))))) b) ;;; Order of evaluation test (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) ;;; Error tests (deftest nth-value.error.1 (signals-error (funcall (macro-function 'nth-value)) program-error) t) (deftest nth-value.error.2 (signals-error (funcall (macro-function 'nth-value) '(nth-value 1 '(a b c))) program-error) t) (deftest nth-value.error.3 (signals-error (funcall (macro-function 'nth-value) '(nth-value 1 '(a b c)) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/output-stream-p.lsp0000644000000000000000000000013114542551763017257 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.777790436 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/output-stream-p.lsp0000644000175000017500000000157614542551763016667 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/pprint-tab.lsp0000644000000000000000000000013114542551763016251 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.777790436 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint-tab.lsp0000644000175000017500000001450014542551763015650 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jul 10 14:08:08 2004 ;;;; Contains: Tests of PPRINT-TAB (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; No effect in a non-pprint stream (def-pprint-test pprint-tab.non-pretty.1 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :line 10 3) (write "B")) "AB") (def-pprint-test pprint-tab.non-pretty.2 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :section 10 3) (write "B")) "AB") (def-pprint-test pprint-tab.non-pretty.3 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :line-relative 10 3) (write "B")) "AB") (def-pprint-test pprint-tab.non-pretty.4 (with-output-to-string (*standard-output*) (write "A") (pprint-tab :section-relative 10 3) (write "B")) "AB") (def-ppblock-test pprint-tab.non-pretty.5 (progn (write "A") (pprint-tab :line 10 3) (write "B")) "AB" :pretty nil) (def-ppblock-test pprint-tab.non-pretty.6 (progn (write "A") (pprint-tab :section 10 3) (write "B")) "AB" :pretty nil) (def-ppblock-test pprint-tab.non-pretty.7 (progn (write "A") (pprint-tab :line-relative 10 3) (write "B")) "AB" :pretty nil) (def-ppblock-test pprint-tab.non-pretty.8 (progn (write "A") (pprint-tab :section-relative 10 3) (write "B")) "AB" :pretty nil) ;;; nil designates *standard-output* (def-ppblock-test pprint-tab.nil.1 (progn (write "A") (pprint-tab :line 10 1 nil) (write "B")) "A B") ;;; t designates *terminal-io* (def-pprint-test pprint-tab.t.1 (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint-logical-block (*terminal-io* nil) (write "A" :stream t) (pprint-tab :line 10 1 t) (write "B" :stream t))))) "A B") ;;; Now test actual tabbing behavior ;;; NOTE ;;; I am assuming that when colnum <= current column, ;;; and the current column == colnum + k * colinc for some positive integer k, ;;; then pprint-tab :line will tab at least 1 space. (def-pprint-test pprint-tab.line.1 (loop for offset = (random 100) for colnum = (random 100) for colinc = (min (random 50) (random 50)) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i offset) (write #\Space)) (pprint-tab :line colnum colinc) (write #\A))) for expected-col = (cond ((< offset colnum) colnum) ((= colinc 0) offset) ((= offset colnum) (+ offset colinc)) (t (let ((k (mod (- colnum offset) colinc))) (if (= k 0) (+ offset colinc) (+ offset k))))) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list offset colnum colinc expected-col (count #\Space s) s)))) nil :margin 1000) (def-pprint-test pprint-tab.section.1 (loop for prefix-length = (random 50) for offset = (random 50) for colnum = (random 50) for colinc = (min (random 50) (random 50)) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil :prefix (make-string prefix-length :initial-element #\Space)) (dotimes (i offset) (write #\Space)) (pprint-tab :section colnum colinc) (write #\A))) for expected-col = (+ prefix-length (cond ((< offset colnum) colnum) ((= colinc 0) offset) ((= offset colnum) (+ offset colinc)) (t (let ((k (mod (- colnum offset) colinc))) (if (= k 0) (+ offset colinc) (+ offset k)))))) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list offset colnum colinc expected-col (count #\Space s) s)))) nil :margin 1000) (def-pprint-test pprint-tab.line-relative.1 (loop for offset = (random 100) for colrel = (random 100) for colinc = (1+ (min (random 50) (random 50))) for extra = (mod (- (+ offset colrel)) colinc) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil) (dotimes (i offset) (write #\Space)) (pprint-tab :line-relative colrel colinc) (write #\A))) for expected-col = (+ offset colrel extra) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list offset colrel colinc expected-col (count #\Space s) s)))) nil :margin 1000) (def-pprint-test pprint-tab.section-relative.1 (loop for prefix-length = (random 50) for offset = (random 50) for colrel = (random 50) for colinc = (1+ (min (random 50) (random 50))) for extra = (mod (- (+ offset colrel)) colinc) for s = (with-output-to-string (*standard-output*) (pprint-logical-block (*standard-output* nil :prefix (make-string prefix-length :initial-element #\Space)) (dotimes (i offset) (write #\Space)) (pprint-tab :section-relative colrel colinc) (write #\A))) for expected-col = (+ prefix-length offset colrel extra) repeat 200 nconc (unless (string= s (concatenate 'string (make-string expected-col :initial-element #\Space) "A")) (list (list prefix-length offset colrel colinc extra expected-col (count #\Space s) s)))) nil :margin 1000) ;;; Error cases (deftest pprint-tab.error.1 (signals-error (pprint-tab) program-error) t) (deftest pprint-tab.error.2 (signals-error (pprint-tab :line) program-error) t) (deftest pprint-tab.error.3 (signals-error (pprint-tab :line 1) program-error) t) (deftest pprint-tab.error.4 (signals-error (pprint-tab :line 1 1 nil nil) program-error) t) (deftest pprint-tab.error.5 (loop for x in *mini-universe* unless (or (member x '(:line :section :line-relative :section-relative)) (eval `(signals-error (pprint-tab ',x 1 1) error))) collect x) nil) (deftest pprint-tab.error.5-unsafe (loop for x in *mini-universe* unless (or (member x '(:line :section :line-relative :section-relative)) (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-tab ',x 1 1)) error))) collect x) nil) gcl-2.7.1/ansi-tests/PaxHeaders/shared-initialize.lsp0000644000000000000000000000013214542551763017577 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.777790436 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/shared-initialize.lsp0000644000175000017500000004366214542551763017210 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 29 04:09:06 2003 ;;;; Contains: Tests of SHARED-INITIALIZE (in-package :cl-test) (defclass shared-init-class-01 () ((a :initform 'x :initarg :a) (b :initform 'y :initarg :b) (c :initarg :c) d)) (deftest shared-initialize.1.1 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :b 3 :c 14)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a b c)))) (nil nil nil nil) t (t t t nil) (1 3 14)) (deftest shared-initialize.1.2 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b c d)))) (nil nil nil nil) t (nil nil nil nil)) (deftest shared-initialize.1.3 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :a 2)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) 1) (deftest shared-initialize.1.4 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :a 2 :allow-other-keys nil)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) 1) (deftest shared-initialize.1.5 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj '(a) :a 1)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) 1) (deftest shared-initialize.1.6 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj '(a))) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (nil nil nil nil) t (t nil nil nil) x) (deftest shared-initialize.1.7 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil nil nil) t (t t nil nil) x y) (deftest shared-initialize.1.8 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj t :b 10 :c 100)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) (nil nil nil nil) t (t t t nil) x 10 100) (deftest shared-initialize.1.9 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj nil :a 1 :b 10 :c 100)) (eqt obj (shared-initialize obj nil :a 5 :b 37 :c 213)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) (nil nil nil nil) t t (t t t nil) 5 37 213) (deftest shared-initialize.1.10 (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (setf (slot-value obj 'a) 1000) (values (map-slot-boundp* obj '(a b c d)) (eqt obj (shared-initialize obj '(a))) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) (t nil nil nil) t (t nil nil nil) 1000) ;;; Initforms in the lexical environment of the defclass (declaim (special *shared-init-var-02-init* *shared-init-var-02-query*)) (declaim (type function *shared-init-var-02-init* *shared-init-var-02-query*)) (let ((ainit 0) (binit 0)) (flet ((%init (a b) (setf ainit a binit b)) (%query () (list ainit binit))) (setf *shared-init-var-02-init* #'%init *shared-init-var-02-query* #'%query) (defclass shared-init-class-02 () ((a :initform (incf ainit) :initarg :a) (b :initform (incf binit) :initarg :b) (c :initarg :c) (d)) (:default-initargs :c 100)))) (deftest shared-initialize.2.1 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj t)) (slot-value obj 'a) (slot-value obj 'b) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t 6 11 (t t nil nil) (6 11)) (deftest shared-initialize.2.2 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t (nil nil nil nil) (5 10)) (deftest shared-initialize.2.3 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj '(a))) (slot-value obj 'a) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t 6 (t nil nil nil) (6 10)) (deftest shared-initialize.2.4 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj '(b))) (slot-value obj 'b) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t 11 (nil t nil nil) (5 11)) (deftest shared-initialize.2.5 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj t :a 34 :b 49)) (map-slot-value obj '(a b)) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t (34 49) (t t nil nil) (5 10)) (deftest shared-initialize.2.6 (progn (funcall *shared-init-var-02-init* 5 10) (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) (values (funcall *shared-init-var-02-query*) (eqt obj (shared-initialize obj '(a b c d) :a 34 :b 49)) (map-slot-value obj '(a b)) (map-slot-boundp* obj '(a b c d)) (funcall *shared-init-var-02-query*)))) (5 10) t (34 49) (t t nil nil) (5 10)) ;;; Defining new methods on shared-initialize (defstruct shared-init-class-03 a b c) (defmethod shared-initialize ((obj shared-init-class-03) slots-to-init &key (a nil a-p) (b nil b-p) (c nil c-p) &allow-other-keys) (declare (ignore slots-to-init)) ;; (when a-p (setf (slot-value obj 'a) a)) ;; (when b-p (setf (slot-value obj 'b) b)) ;; (when c-p (setf (slot-value obj 'c) c)) (when a-p (setf (shared-init-class-03-a obj) a)) (when b-p (setf (shared-init-class-03-b obj) b)) (when c-p (setf (shared-init-class-03-c obj) c)) obj) (deftest shared-initialize.3.1 (let ((obj (make-shared-init-class-03))) (values (eqt obj (shared-initialize obj nil :a 1 :b 5 :c 19)) (shared-init-class-03-a obj) (shared-init-class-03-b obj) (shared-init-class-03-c obj))) t 1 5 19) ;;; Inheritance (defclass shared-init-class-04a () ((a :initform 4 :initarg :a) (b :initform 8 :initarg :b))) (defclass shared-init-class-04b (shared-init-class-04a) ((c :initform 17 :initarg :c) d) (:default-initargs :a 1)) (deftest shared-initialize.4.1 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj nil :a 'x)) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'a))) t (t nil nil nil) x) (deftest shared-initialize.4.2 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b c d)))) t (nil nil nil nil)) (deftest shared-initialize.4.3 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a b c)))) t (t t t nil) (4 8 17)) (deftest shared-initialize.4.4 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(a c))) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a c)))) t (t nil t nil) (4 17)) (deftest shared-initialize.4.5 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(a c) :c 81)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a c)))) t (t nil t nil) (4 81)) (deftest shared-initialize.4.6 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(a c) :a 91)) (map-slot-boundp* obj '(a b c d)) (map-slot-value obj '(a c)))) t (t nil t nil) (91 17)) (deftest shared-initialize.4.7 (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) (values (eqt obj (shared-initialize obj '(c))) (map-slot-boundp* obj '(a b c d)) (slot-value obj 'c))) t (nil nil t nil) 17) ;;; shared-initialize and class slots (defclass shared-init-class-05 () ((a :initarg :a :allocation :class) (b :initarg :b :initform 'foo :allocation :class))) (deftest shared-initialize.5.1 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) t (nil t) foo) (deftest shared-initialize.5.2 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (eqt obj (shared-initialize obj '(b))) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) t (nil t) foo) (deftest shared-initialize.5.3 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class)) (obj2 (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (eqt obj (shared-initialize obj t :a 117)) (map-slot-boundp* obj '(a b)) (map-slot-value obj '(a b)) (map-slot-value obj2 '(a b)))) t (t t) (117 foo) (117 foo)) (deftest shared-initialize.5.4 (let* ((class (find-class 'shared-init-class-05)) (obj (allocate-instance class)) (obj2 (allocate-instance class))) (slot-makunbound obj 'a) (values (setf (slot-value obj 'b) 'bar) (eqt obj (shared-initialize obj t :a 117)) (map-slot-boundp* obj '(a b)) (map-slot-value obj '(a b)) (map-slot-value obj2 '(a b)))) bar t (t t) (117 bar) (117 bar)) ;;; Shared initargs (defclass shared-init-class-06 () ((a :initarg :i1 :initarg :i2 :initform 'x) (b :initarg :i2 :initarg :i3 :initform 'y))) (deftest shared-initialize.6.1 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b)))) (nil nil) t (nil nil)) (deftest shared-initialize.6.2 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) x y) (deftest shared-initialize.6.3 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i1 'z)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) z) (deftest shared-initialize.6.4 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.5 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i1 'w :i2 'z)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) w z) (deftest shared-initialize.6.6 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i1 'w)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.7 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i2 'w)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.8 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i2 'w :foo t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) (deftest shared-initialize.6.9 (let* ((class (find-class 'shared-init-class-06)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :allow-other-keys nil :i2 'z :i2 'w :foo t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z z) ;;; Before methods fill in slots before the default system method (defclass shared-init-class-07 () ((a :initform 'x) (b :initform 'y))) (defmethod shared-initialize :before ((obj shared-init-class-07) slot-names &rest args) (declare (ignore args slot-names)) (setf (slot-value obj 'a) 'foo) obj) (deftest shared-initialize.7.1 (let* ((class (find-class 'shared-init-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) foo) (deftest shared-initialize.7.2 (let* ((class (find-class 'shared-init-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) foo y) ;;; :around method tests (defclass shared-init-class-08 () ((a :initform 'x) (b :initform 'y))) (defmethod shared-initialize :around ((obj shared-init-class-08) slot-names &rest args &key only &allow-other-keys) (declare (ignore slot-names args)) (setf (slot-value obj 'a) 'foo) (if only obj (call-next-method))) (deftest shared-initialize.8.1 (let* ((class (find-class 'shared-init-class-08)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) foo) (deftest shared-initialize.8.2 (let* ((class (find-class 'shared-init-class-08)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) foo y) (deftest shared-initialize.8.3 (let* ((class (find-class 'shared-init-class-08)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t :only t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) foo) ;;; (defclass shared-init-class-09 () ((a :allocation :class :initform 'x) (b :initform 'y))) (deftest shared-initialize.9.1 (let* ((class (find-class 'shared-init-class-09)) (obj (allocate-instance class))) (slot-makunbound obj 'a) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj '(b))) (map-slot-boundp* obj '(a b)) (slot-value obj 'b))) (nil nil) t (nil t) y) ;;; Order of evaluation tests (deftest shared-initialize.order.1 (let ((obj (allocate-instance (find-class 'shared-init-class-01))) (i 0) x r y z w q) (values (eqt obj (shared-initialize (progn (setf x (incf i)) obj) (progn (setf r (incf i)) nil) :b (setf y (incf i)) :a (setf z (incf i)) :b (setf w (incf i)) :c (setf q (incf i)))) (map-slot-value obj '(a b c)) i x r y z w q)) t (4 3 6) 6 1 2 3 4 5 6) ;;; Error tests (deftest shared-initialize.error.1 (signals-error (shared-initialize) program-error) t) (deftest shared-initialize.error.2 (signals-error (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (shared-initialize obj)) program-error) t) (deftest shared-initialize.error.3 (signals-error (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (shared-initialize obj nil :a)) program-error) t) (deftest shared-initialize.error.4 (signals-error (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) (shared-initialize obj nil '(a b c) nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/epsilons.lsp0000644000000000000000000000013214542551762016025 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.777790436 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/epsilons.lsp0000644000175000017500000000651714542551762015434 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 20 22:05:20 2003 ;;;; Contains: Tests of the EPSILON constants (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest epsilons.1 (loop for e in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) when (= (float 1 e) (+ (float 1 e) e)) collect e) nil) (deftest epsilons.2 (loop for e in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) when (= (float 1 e) (- (float 1 e) e)) collect e) nil) (deftest epsilons.3 (loop for e in (list short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon) unless (= (float 1 e) (+ (float 1 e) (/ e 2))) collect e) nil) (deftest epsilons.4 (loop for e in (list short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon) unless (= (float 1 e) (- (float 1 e) (/ e 2))) collect e) nil) (deftest epsilons.5 (loop for (type var) in '( (short-float short-float-epsilon) (short-float short-float-negative-epsilon) (single-float single-float-epsilon) (single-float single-float-negative-epsilon) (double-float double-float-epsilon) (double-float double-float-negative-epsilon) (long-float long-float-epsilon) (long-float long-float-negative-epsilon)) for val = (symbol-value var) unless (typep val type) collect (list type var val)) nil) (deftest epsilons.6 (flet ((%check (x) (/= 1.0s0 (+ 1.0s0 x)))) (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) (if (= eps short-float-epsilon) :good (list eps short-float-epsilon)))) :good) (deftest epsilons.7 (flet ((%check (x) (/= 1.0f0 (+ 1.0f0 x)))) (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) (if (= eps single-float-epsilon) :good (list eps single-float-epsilon)))) :good) (deftest epsilons.8 (flet ((%check (x) (/= 1.0d0 (+ 1.0d0 x)))) (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) (if (= eps double-float-epsilon) :good (list eps double-float-epsilon)))) :good) (deftest epsilons.9 (flet ((%check (x) (/= 1.0l0 (+ 1.0l0 x)))) (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) (if (= eps long-float-epsilon) :good (list eps long-float-epsilon)))) :good) (deftest epsilons.10 (flet ((%check (x) (/= 1.0s0 (- 1.0s0 x)))) (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) (if (= eps short-float-negative-epsilon) :good (list eps short-float-negative-epsilon)))) :good) (deftest epsilons.11 (flet ((%check (x) (/= 1.0f0 (- 1.0f0 x)))) (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) (if (= eps single-float-negative-epsilon) :good (list eps single-float-negative-epsilon)))) :good) (deftest epsilons.12 (flet ((%check (x) (/= 1.0d0 (- 1.0d0 x)))) (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) (if (= eps double-float-negative-epsilon) :good (list eps double-float-negative-epsilon)))) :good) (deftest epsilons.13 (flet ((%check (x) (/= 1.0l0 (- 1.0l0 x)))) (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) (if (= eps long-float-negative-epsilon) :good (list eps long-float-negative-epsilon)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/stringp.lsp0000644000000000000000000000013214542551763015660 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.777790436 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/stringp.lsp0000644000175000017500000000413514542551763015261 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 29 17:32:20 2004 ;;;; Contains: Tests of STRINGP (in-package :cl-test) (deftest stringp.1 (check-type-predicate #'stringp 'string) nil) (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) (deftest stringp.9 :notes (:nil-vectors-are-strings) (notnot-mv (stringp (make-array '(0) :element-type nil))) t) (deftest stringp.10 :notes (:nil-vectors-are-strings) (notnot-mv (stringp (make-array '(37) :element-type nil))) t) (deftest stringp.11 (notnot (stringp (make-array 4 :element-type 'base-char :fill-pointer 2 :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.12 (notnot (stringp (make-array 4 :element-type 'base-char :adjustable t :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.13 (notnot (stringp (make-array 4 :element-type 'character :fill-pointer 2 :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.14 (notnot (stringp (make-array 4 :element-type 'character :adjustable t :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.15 (let ((i 0)) (values (notnot (stringp (progn (incf i) ""))) i)) t 1) ;;; Error tests (deftest stringp.error.1 (signals-error (stringp) program-error) t) (deftest stringp.error.2 (signals-error (stringp "" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/array-t.lsp0000644000000000000000000000013214542551762015550 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.777790436 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-t.lsp0000644000175000017500000001076114542551762015153 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/the.lsp0000644000000000000000000000013114542551763014751 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.777790436 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/the.lsp0000644000175000017500000000637714542551763014365 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 6 06:48:48 2003 ;;;; Contains: Tests of THE (in-package :cl-test) (deftest the.1 (the (values) (values))) (deftest the.2 (the (values) 'a) a) (deftest the.3 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.4 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.5 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.6 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e)))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.7 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (values (quote ,e) :ignored)))))) (and (eql (length x) 2) (eql (car x) e) (eql (cadr x) :ignored))))) nil) (deftest the.8 (check-predicate #'(lambda (e) (or (not (constantp e)) (eql (eval `(the ,(type-of e) ,e)) e)))) nil) (deftest the.9 (check-predicate #'(lambda (e) (or (not (constantp e)) (eql (eval `(the ,(class-of e) ,e)) e)))) nil) (deftest the.10 (check-predicate #'(lambda (e) (eql (eval `(the ,(class-of e) ',e)) e))) nil) (deftest the.11 (check-predicate #'(lambda (e) (let* ((type (type-of e)) (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e))))))) (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.12 (let ((lexpr `(lambda () (and ,@(loop for e in *mini-universe* for type = (type-of e) collect `(eqlt (quote ,e) (the ,type (quote ,e)))))))) (funcall (compile nil lexpr))) t) (deftest the.13 (let ((x 0)) (values (the (or symbol integer) (incf x)) x)) 1 1) (deftest the.14 (the (values &rest t) (values 'a 'b)) a b) (deftest the.15 (the (values &rest symbol) (values 'a 'b)) a b) (deftest the.16 (the (values &rest null) (values))) (deftest the.17 (the (values symbol integer &rest null) (values 'a 1)) a 1) (deftest the.18 (the (values symbol integer &rest t) (values 'a 1 'foo '(x y))) a 1 foo (x y)) (deftest the.19 (let () (list (the (values) (eval '(values))))) (nil)) ;;; This is from SBCL bug 261 (deftest the.20 (let () (list (the (values &optional fixnum) (eval '(values))))) (nil)) (deftest the.21 (let () (list (the (values &rest t) (eval '(values))))) (nil)) (deftest the.22 (the (values symbol integer &rest t) (eval '(values 'a 1 'foo '(x y)))) a 1 foo (x y)) (deftest the.23 (multiple-value-list (the (values symbol integer &optional fixnum) (eval '(values 'a 1)))) (a 1)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest the.24 (macrolet ((%m (z) z)) (the (integer 0 10) (expand-in-current-env (%m 4)))) 4) (deftest the.25 (macrolet ((%m (z) z)) (the (values t t) (expand-in-current-env (%m (values 1 2))))) 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/logxor.lsp0000644000000000000000000000013214542551763015504 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.777790436 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logxor.lsp0000644000175000017500000000371214542551763015105 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:30:57 2003 ;;;; Contains: Tests of LOGXOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logxor.error.1 (check-type-error #'logxor #'integerp) nil) (deftest logxor.error.2 (check-type-error #'(lambda (x) (logxor 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logxor.1 (logxor) 0) (deftest logxor.2 (logxor 1231) 1231) (deftest logxor.3 (logxor -198) -198) (deftest logxor.4 (loop for x in *integers* always (eql x (logxor x))) t) (deftest logxor.5 (loop for x in *integers* always (and (eql -1 (logxor x (lognot x))) (eql 0 (logxor x x)) (eql x (logxor x x x)))) t) (deftest logxor.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql -1 (logxor x xc)) collect x) nil) (deftest logxor.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logxor x y) repeat 1000 unless (and (if (or (and (< x 0) (>= y 0)) (and (>= x 0) (< y 0))) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (and (logbitp i x) (not (logbitp i y))) (and (not (logbitp i x)) (logbitp i y))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logxor.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element 0) (list 7131)) always (eql (apply #'logxor args) 7131)) t) (deftest logxor.order.1 (let ((i 0) a b) (values (logxor (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110)) i a b)) #b1101 2 1 2) (deftest logxor.order.2 (let ((i 0) a b c) (values (logxor (progn (setf a (incf i)) #b11011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b111000 3 1 2 3) gcl-2.7.1/ansi-tests/PaxHeaders/get.lsp0000644000000000000000000000013114542551762014747 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.777790436 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/get.lsp0000644000175000017500000000436414542551762014355 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jul 13 07:01:47 2004 ;;;; Contains: Tests of GET (in-package :cl-test) (deftest get.1 (let ((sym (gensym))) (get sym :foo)) nil) (deftest get.2 (let ((sym (gensym))) (get sym :foo :bar)) :bar) (deftest get.3 (let ((sym (gensym))) (get sym :foo (values :bar nil))) :bar) (deftest get.4 (let ((sym (gensym))) (setf (symbol-plist sym) (list :foo 1 :bar 2 :foo 3)) (values (get sym :foo) (get sym :bar))) 1 2) (deftest get.5 (let ((evaluated nil) (sym (gensym))) (assert (equal (multiple-value-list (setf (get sym :foo) 1)) '(1))) (values (get sym :foo (progn (setf evaluated t) nil)) evaluated)) 1 t) (deftest get.6 (let ((evaluated nil) (sym (gensym))) (assert (equal (multiple-value-list (setf (get sym :foo (progn (setf evaluated t) nil)) 1)) '(1))) (values (get sym :foo) evaluated)) 1 t) ;;; Order of evaluation (deftest get.order.1 (let (a b (i 0) (sym (gensym))) (setf (get sym :foo) t) (values (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo)) a b i)) t 1 2 2) (deftest get.order.2 (let (a b (i 0) (sym (gensym))) (values (setf (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo)) t) a b i (get sym :foo) )) t 1 2 2 t) (deftest get.order.3 (let (a b c (i 0) (sym (gensym))) (setf (get sym :foo) t) (values (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo) (progn (setf c (incf i)) nil)) a b c i)) t 1 2 3 3) (deftest get.order.4 (let (a b c (i 0) (sym (gensym))) (values (setf (get (progn (setf a (incf i)) sym) (progn (setf b (incf i)) :foo) (progn (setf c (incf i)) nil)) t) a b c i (get sym :foo) )) t 1 2 3 3 t) ;;; Error tests (deftest get.error.1 (signals-error (get) program-error) t) (deftest get.error.2 (signals-error (get nil) program-error) t) (deftest get.error.3 (signals-error (get nil nil nil nil) program-error) t) (deftest get.error.4 (check-type-error #'(lambda (x) (get x :foo)) #'symbolp) nil) (deftest get.error.5 (check-type-error #'(lambda (x) (setf (get x :foo) nil)) #'symbolp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/gethash.lsp0000644000000000000000000000013114542551762015613 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.777790436 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/gethash.lsp0000644000175000017500000000726514542551762015224 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 06:05:21 2003 ;;;; Contains: Tests of GETHASH (in-package :cl-test) ;;; Most testing of GETHASH is in test-hash-table-1 in hash-table-aux.lsp (deftest gethash.1 (gethash 'x (make-hash-table) 'y) y nil) (deftest gethash.2 (gethash nil (make-hash-table) 'a) a nil) (deftest gethash.3 (gethash nil (make-hash-table) 'a) a nil) (deftest gethash.4 (multiple-value-bind (value present) (gethash 'a (let ((table (make-hash-table))) (setf (gethash 'a table) 'b) table)) (values value (notnot present))) b t) (deftest gethash.5 (let ((table (make-hash-table)) (i 0)) (values (setf (gethash 'x table (incf i)) 'y) i (gethash 'x table))) y 1 y) (deftest gethash.order.1 (let ((i 0) x y (table (make-hash-table))) (setf (gethash 'a table) 'b) (values (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table)) i x y)) b 2 1 2) (deftest gethash.order.2 (let ((i 0) x y z (table (make-hash-table))) (setf (gethash 'a table) 'b) (values (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table) (progn (setf z (incf i)) 'missing)) i x y z)) b 3 1 2 3) (deftest gethash.order.3 (let ((i 0) x y (table (make-hash-table))) (values (setf (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table)) 'b) i x y (gethash 'a table))) b 2 1 2 b) (deftest gethash.order.4 (let ((i 0) x y z (table (make-hash-table))) (values (setf (gethash (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) table) (setf z (incf i))) 'b) i x y z (gethash 'a table))) b 3 1 2 3 b) ;;; Tests for 0.0, -0.0 in hash tables (deftest gethash.zero.1 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'eq))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x nil :y :x :y))) collect (list pz nz result)) nil) (deftest gethash.zero.2 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'eql))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x nil :y :x :y))) collect (list pz nz result)) nil) (deftest gethash.zero.3 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'equal))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x nil :y :x :y))) collect (list pz nz result)) nil) (deftest gethash.zero.4 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) for nz = (- pz) for result = (let ((table (make-hash-table :test 'equalp))) (list (setf (gethash pz table) :x) (gethash pz table) (gethash nz table) (setf (gethash nz table) :y) (gethash pz table) (gethash nz table))) unless (or (eql pz nz) (equal result '(:x :x :x :y :y :y))) collect (list pz nz result)) nil) ;;;; Error tests (deftest gethash.error.1 (signals-error (gethash) program-error) t) (deftest gethash.error.2 (signals-error (gethash 'foo) program-error) t) (deftest gethash.error.3 (signals-error (gethash 'foo (make-hash-table) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/file-error.lsp0000644000000000000000000000013214542551762016237 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.777790436 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/file-error.lsp0000644000175000017500000000472114542551762015641 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/pprint.lsp0000644000000000000000000000013114542551763015505 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.781790454 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pprint.lsp0000644000175000017500000000156514542551763015113 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jul 25 11:42:48 2004 ;;;; Contains: Tests of PPRINT (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; This function is mostly tested elsewhere (deftest pprint.1 (random-pprint-test 1000) nil) (deftest pprint.2 (with-standard-io-syntax (with-output-to-string (os) (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) (pprint 2 t))))) " 2") (deftest pprint.3 (with-standard-io-syntax (with-output-to-string (*standard-output*) (pprint 3 nil))) " 3") ;;; Error tests (deftest pprint.error.1 (signals-error (with-output-to-string (*standard-output*) (pprint)) program-error) t) (deftest pprint.error.2 (signals-error (with-output-to-string (s) (pprint nil s nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/multiple-value-call.lsp0000644000000000000000000000013114542551763020047 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.781790454 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/multiple-value-call.lsp0000644000175000017500000000141514542551763017447 0ustar00cammcamm;-*- 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)) ;;; Macros are expanded in the appropriate environment (deftest multiple-value-call.4 (macrolet ((%m (z) z)) (multiple-value-call (expand-in-current-env (%m #'list)) (values 1 2))) (1 2)) (deftest multiple-value-call.5 (macrolet ((%m (z) z)) (multiple-value-call 'list (expand-in-current-env (%m (values 1 2))))) (1 2)) gcl-2.7.1/ansi-tests/PaxHeaders/lognor.lsp0000644000000000000000000000013214542551763015472 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.781790454 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/lognor.lsp0000644000175000017500000000320014542551763015063 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:14:35 2003 ;;;; Contains: Tests of LOGNOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest lognor.error.1 (check-type-error #'(lambda (x) (lognor x 0)) #'integerp) nil) (deftest lognor.error.2 (check-type-error #'(lambda (x) (lognor 0 x)) #'integerp) nil) (deftest lognor.error.3 (signals-error (lognor) program-error) t) (deftest lognor.error.4 (signals-error (lognor 0) program-error) t) (deftest lognor.error.5 (signals-error (lognor 1 2 3) program-error) t) ;;; Non-error tests (deftest lognor.1 (lognor 0 0) -1) (deftest lognor.2 (lognor 0 -1) 0) (deftest lognor.3 (lognor -1 123) 0) (deftest lognor.4 (loop for x in *integers* always (and (eql (lognot x) (lognor 0 x)) (eql (lognot x) (lognor x x)) (eql 0 (lognor (lognot x) x)) (eql 0 (lognor x (lognot x))))) t) (deftest lognor.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql 0 (lognor xc x)) collect x) nil) (deftest lognor.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (lognor x y) repeat 1000 unless (and (if (and (>= x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (not (or (logbitp i x) (logbitp i y))) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest lognor.order.1 (let ((i 0) a b) (values (lognor (progn (setf a (incf i)) -2) (progn (setf b (incf i)) -3)) i a b)) 0 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/position-if.lsp0000644000000000000000000000013114542551763016431 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.781790454 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/position-if.lsp0000644000175000017500000003216614542551763016040 0ustar00cammcamm;-*- 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) (deftest position-if-vector.14 (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (position-if #'integerp v2) (position-if #'integerp v2 :from-end t))) 2 6) ;;; 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-string.14 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if #'alpha-char-p s))) (assert (eql pos 5) () "First alpha char in ~A is at position ~A" s pos))) nil) (deftest position-if-string.15 (do-special-strings (s "12345a6 78b90" nil) (let ((pos (position-if #'alpha-char-p s :from-end t))) (assert (eql pos 11) () "Last alpha char in ~A is at position ~A" s pos))) nil) (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 (check-type-error #'(lambda (x) (position-if #'identity x)) #'sequencep) nil) (deftest position-if.error.4 (signals-error (position-if 'null '(a b c . d)) type-error) t) (deftest position-if.error.5 (signals-error (position-if) program-error) t) (deftest position-if.error.6 (signals-error (position-if #'null) program-error) t) (deftest position-if.error.7 (signals-error (position-if #'null nil :key) program-error) t) (deftest position-if.error.8 (signals-error (position-if #'null nil 'bad t) program-error) t) (deftest position-if.error.9 (signals-error (position-if #'null nil 'bad t :allow-other-keys nil) program-error) t) (deftest position-if.error.10 (signals-error (position-if #'null nil 1 2) program-error) t) (deftest position-if.error.11 (signals-error (locally (position-if #'identity 'b) t) type-error) t) (deftest position-if.error.12 (signals-error (position-if #'cons '(a b c d)) program-error) t) (deftest position-if.error.13 (signals-error (position-if #'car '(a b c d)) type-error) t) (deftest position-if.error.14 (signals-error (position-if #'identity '(a b c d) :key #'cdr) type-error) t) (deftest position-if.error.15 (signals-error (position-if #'identity '(a b c d) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/backquote-aux.lsp0000644000000000000000000000013214542551762016742 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.781790454 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/backquote-aux.lsp0000644000175000017500000000304114542551762016336 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jun 11 08:04:23 2004 ;;;; Contains: Aux. functions associated with backquote tests (in-package :cl-test) ;;; Not yet finished ;;; Create random backquoted forms (defun make-random-backquoted-form (size) (my-with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package "CL-TEST"))) (read-from-string (concatenate 'string "`" (make-random-backquoted-sequence-string size)))))) (defun make-random-backquoted-sequence-string (size) (case size ((0 1) (make-random-backquoted-string size)) (t (let* ((nelements (1+ (min (random (1- size)) (random (1- size)) 9))) (sizes (random-partition (1- size) nelements)) (substrings (mapcar #'make-random-backquoted-string sizes))) (apply #'concatenate 'string "(" (car substrings) (if nil ; (and (> nelements 1) (coin)) (nconc (loop for s in (cddr substrings) collect " " collect s) (list " . " (cadr substrings) ")")) (nconc (loop for s in (cdr substrings) collect " " collect s) (list ")")))))))) ;;; Create a string that is a backquoted form (defun make-random-backquoted-string (size) (if (<= size 1) (rcase (1 "()") (1 (string (random-from-seq #.(coerce *cl-symbol-names* 'vector)))) (1 (write-to-string (- (random 2001) 1000))) (2 (concatenate 'string "," (string (random-from-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))) ) ;; size > 1 (make-random-backquoted-sequence-string size))) gcl-2.7.1/ansi-tests/PaxHeaders/slot-boundp.lsp0000644000000000000000000000013214542551763016440 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.781790454 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/slot-boundp.lsp0000644000175000017500000000406314542551763016041 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 6 05:53:32 2003 ;;;; Contains: Tests of SLOT-BOUNDP (in-package :cl-test) ;;; SLOT-BOUNDP is extensively tested in other files as well (defclass slot-boundp-class-01 () (a (b :initarg :b) (c :initform 'x))) (deftest slot-boundp.1 (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj 'a)) nil) (deftest slot-boundp.2 (let ((obj (make-instance 'slot-boundp-class-01))) (setf (slot-value obj 'a) nil) (notnot-mv (slot-boundp obj 'a))) t) (deftest slot-boundp.3 (let ((obj (make-instance 'slot-boundp-class-01 :b nil))) (notnot-mv (slot-boundp obj 'b))) t) (deftest slot-boundp.4 (let ((obj (make-instance 'slot-boundp-class-01))) (notnot-mv (slot-boundp obj 'c))) t) (deftest slot-boundp.5 (let ((obj (make-instance 'slot-boundp-class-01))) (slot-makunbound obj 'c) (slot-boundp obj 'c)) nil) ;;; Argument order test(s) (deftest slot-boundp.order.1 (let ((obj (make-instance 'slot-boundp-class-01)) (i 0) x y) (values (slot-boundp (progn (setf x (incf i)) obj) (progn (setf y (incf i)) 'a)) i x y)) nil 2 1 2) ;;; Error tests (deftest slot-boundp.error.1 (signals-error (slot-boundp) program-error) t) (deftest slot-boundp.error.2 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj)) program-error) t) (deftest slot-boundp.error.3 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj 'a nil)) program-error) t) (deftest slot-boundp.error.4 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) (slot-boundp obj 'nonexistent-slot)) error) t) ;;; SLOT-BOUNDP should signal an error on elements of built-in-classes (deftest slot-boundp.error.5 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (slot-boundp e 'foo) t) (error () nil))) collect e)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/svref.lsp0000644000000000000000000000013114542551763015316 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.781790454 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/svref.lsp0000644000175000017500000000223614542551763014720 0ustar00cammcamm;-*- 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 (signals-error (svref) program-error) t) (deftest svref.error.2 (signals-error (svref (vector 1)) program-error) t) (deftest svref.error.3 (signals-error (svref (vector 1) 0 0) program-error) t) (deftest svref.error.4 (signals-error (svref (vector 1) 0 nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/cond.lsp0000644000000000000000000000013014542551762015112 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.781790454 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cond.lsp0000644000175000017500000000345314542551762014517 0ustar00cammcamm;-*- 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)))) ;;; No implicit tagbody (deftest cond.15 (block done (tagbody (cond (t (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest cond.16 (macrolet ((%m (z) z)) (cond ((expand-in-current-env (%m nil)) :bad) (t :good))) :good) (deftest cond.17 (macrolet ((%m (z) z)) (cond (nil :bad1) ((expand-in-current-env (%m :good))) (t :bad2))) :good) ;;; Error tests (deftest cond.error.1 (signals-error (funcall (macro-function 'cond)) program-error) t) (deftest cond.error.2 (signals-error (funcall (macro-function 'cond) '(cond)) program-error) t) (deftest cond.error.3 (signals-error (funcall (macro-function 'cond) '(cond) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/vector.lsp0000644000000000000000000000013214542551763015474 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.781790454 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/vector.lsp0000644000175000017500000001451214542551763015075 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/and.lsp0000644000000000000000000000013214542551762014733 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.781790454 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/and.lsp0000644000175000017500000000254014542551762014332 0ustar00cammcamm;-*- 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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest and.10 (macrolet ((%m (z) z)) (and (expand-in-current-env (%m :a)) (expand-in-current-env (%m :b)) (expand-in-current-env (%m :c)))) :c) ;;; Error tests (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) (deftest and.error.1 (signals-error (funcall (macro-function 'and)) program-error) t) (deftest and.error.2 (signals-error (funcall (macro-function 'and) '(and)) program-error) t) (deftest and.error.3 (signals-error (funcall (macro-function 'and) '(and) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-random-element-of.lsp0000644000000000000000000000013214542551763020416 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.781790454 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-random-element-of.lsp0000644000175000017500000002243714542551763020024 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 28 20:28:03 2004 ;;;; Contains: Code to make random elements of types (in-package :cl-test) (defgeneric make-random-element-of (type) (:documentation "Create a random element of TYPE, or throw an error if it can't figure out how to do it.")) (defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys) (:documentation "Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it.")) (defmethod make-random-element-of ((type cons)) (make-random-element-of-compound-type (car type) (cdr type))) (defmethod make-random-element-of ((type (eql bit))) (random 2)) (defmethod make-random-element-of ((type (eql boolean))) (random-from-seq #(nil t))) (defmethod make-random-elememt-of ((type (eql symbol))) (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) (defmethod make-random-element-of ((type (eql unsigned-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))))) (defmethod make-random-elememt-of ((type (eql signed-byte))) (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) (- (ash 1 (random *maximum-random-int-bits*))))) (defmethod make-random-element-of ((type (eql rational))) (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) (n (random r)) (d (loop for x = (random r) unless (zerop x) do (return x)))) (if (coin) (/ n d) (- (/ n d))))) (defmethod make-random-element-of ((type (eql integer))) (let* ((b (random *maximum-random-int-bits*)) (x (ash 1 b))) (rcase (1 (+ x (make-random-element-of 'integer))) (1 (- (make-random-element-of 'integer) x)) (6 (random-from-interval (1+ x) (- x)))))) (defmethod make-random-element-of ((type (eql short-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql single-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql double-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql long-float))) (make-random-element-of (list type))) (defmethod make-random-element-of ((type (eql float))) (make-random-element-of (list (random-from-seq #'(short-float single-float double-float long-float))))) (defmethod make-random-element-of ((type (eql real))) (make-random-element-of (random-from-seq #(integer rational float)))) (defmethod make-random-element-of ((type (eql ratio))) (loop for x = (make-random-element-of 'rational) unless (integerp x) return x)) (defmethod make-random-element-of ((type complex)) (make-random-element-of '(complex real))) (defmethod make-random-element-of ((type fixnum)) (make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum))) (defmethod make-random-element-of ((type bignum)) (make-random-element-of `(or (integer * (,most-negative-fixnum)) (integer (,most-positive-fixnum))))) (defmethod make-random-element-of ((type (eql number))) (make-random-element-of (random-from-seq #(integer rational float complex)))) (defmethod make-random-element-of ((type (eql character))) (rcase (3 (random-from-seq +standard-chars+)) (2 (let ((r (random 256))) (or (code-char r) (make-random-element-of 'character)))) (1 (let ((r (random #.(ash 1 16)))) (or (code-char r) (make-random-element-of 'character)))) (1 (let ((r (random #.(ash 1 24)))) (or (code-char r) (make-random-element-of 'character)))))) (defmethod make-random-element-of ((type 'base-char)) (random-from-seq +standard-chars+)) (defmethod make-random-element-of ((type 'standard-char)) (random-from-seq +standard-chars+)) (defmethod make-random-element-of ((type (eql bit-vector))) (make-random-vector 'bit '*)) (defmethod make-random-element-of ((type (eql simple-bit-vector))) (make-random-vector 'bit '* :simple t)) (defmethod make-random-element-of ((type (eql vector))) (make-random-vector '* '*)) (defmethod make-random-element-of ((type (eql simple-vector))) (make-random-vector 't '* :simple t)) (defmethod make-random-elemnt-of ((type (eql array))) (make-random-array '* '*)) (defmethod make-random-elemnt-of ((type (eql simple-array))) (make-random-array '* '* :simple t)) (defmethod make-random-elememt-of ((type (eql string))) (make-random-string '*)) (defmethod make-random-elememt-of ((type (eql simple-string))) (make-random-string '* :simple t)) (defmethod make-random-element-of ((type (eql base-string))) (make-random-vector 'base-char '*)) (defmethod make-random-element-of ((type (eql simple-base-string))) (make-random-vector 'base-char '* :simple t)) (defmethod make-random-element-of ((type (eql cons))) (make-random-element-of '(cons t t))) (defmethod make-random-element-of ((type (eql null))) nil) (defmethod make-random-elememt-of ((type (eql list))) (let ((len (min (random 10) (random 10)))) (loop repeat len collect (make-random-element-of-type t)))) (defmethod make-random-element-of ((type (eql sequence))) (make-random-element-of '(or list vector))) ;;;; (defun make-random-vector (length &key simple (element-type '*)) (setq element-type (make-random-array-element-type element-type)) (make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length))) (defun make-random-array (dimensions &key simple (element-type '*)) (setq element-type (make-random-array-element-type element-type)) (make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length))) (defun make-random-array-element-type (elememt-type) (if (eq element-type '*) (rcase (1 'bit) (1 `(unsigned-byte (1+ (random *maximum-random-int-bits*)))) (1 `(signed-byte (1+ (random *maximum-random-int-bits*)))) (2 (random-from-seq #(character base-char standard-char))) ;; Put float, complex types here also (4 t)) element-type)) ;;;; (defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons)) (make-random-element-of (random-from-seq args))) (defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons)) (loop for e = (make-random-element-of (car args)) repeat 100 when (or (null (cdr args)) (typep e (cons 'and (cdr args)))) return x finally (error "Cannot generate a random element of ~A" (cons 'and args)))) (defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t)) (let ((lo (let ((lo (car args))) (cond ((consp lo) (1+ (car lo))) ((eq lo nil) '*) (t lo)))) (hi (let ((hi (cadr args))) (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))))) (defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t)) (make-random-element-of-float-type type args)) (defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t)) (make-random-element-of-float-type type args)) (defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t)) (make-random-element-of-float-type type args)) (defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t)) (make-random-element-of-float-type type args)) (defun make-random-element-of-float-type (type-op args) (let ((lo (car args)) (hi (cadr args)) lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) (setq lo (most-negative-float type-op)) (setq lo= t)) (t (assert (typep lo type-op)) (setq lo= t))) (cond ((consp hi) nil) ((member hi '(* nil)) (setq hi (most-positive-float type-op)) (setq hi= t)) (t (assert (typep hi type-op)) (setq hi= t))) (assert (<= lo hi)) (assert (or (< lo hi) (and lo= hi=))) (let ((limit 100000)) (cond ((or (<= hi 0) (>= lo 0) (and (<= (- limit) hi limit) (<= (- limit) lo limit))) (loop for x = (+ (random (- hi lo)) lo) do (when (or lo= (/= x lo)) (return x)))) (t (rcase (1 (random (min hi (float limit hi)))) (1 (- (random (min (float limit lo) (- lo))))))))))) (defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons)) (let ((modulus (car args))) (assert (integerp modulus)) (assert (plusp modulus)) (make-random-element-of `(integer 0 (,modulus))))) (defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t)) (if (null args) (make-random-element-of '(integer 0 *)) (let ((bits (car args))) (if (eq bits'*) (make-random-element-of '(integer 0 *)) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of `(integer 0 ,(1- (ash 1 bits))))))))) (defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons)) (assert (null (cdr args))) (car args)) (defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons)) (random-from-seq args)) gcl-2.7.1/ansi-tests/PaxHeaders/loop7.lsp0000644000000000000000000000013214542551763015232 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.785790472 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/loop7.lsp0000644000175000017500000001432714542551763014637 0ustar00cammcamm;-*- 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 (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each symbol of "LOOP.MISSING.PACKAGE" collect x) package-error)) t) (deftest loop.7.19 (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" collect x) package-error)) t) (deftest loop.7.20 (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" collect x) package-error)) t) ;;; 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")) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.7.33 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name (loop for x being the symbols of (expand-in-current-env (%m "LOOP.CL-TEST.1")) collect x)) #'string<)) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.34 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name (loop for x being the external-symbols of (expand-in-current-env (%m "LOOP.CL-TEST.1")) collect x)) #'string<)) ("A" "B" "C")) (deftest loop.7.35 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name (loop for x being the present-symbols of (expand-in-current-env (%m "LOOP.CL-TEST.2")) collect x)) #'string<)) ("X" "Y" "Z")) gcl-2.7.1/ansi-tests/PaxHeaders/logandc1.lsp0000644000000000000000000000013214542551763015662 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.785790472 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logandc1.lsp0000644000175000017500000000325414542551763015264 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 8 21:47:22 2003 ;;;; Contains: Tests of LOGANDC1 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logandc1.error.1 (check-type-error #'(lambda (x) (logandc1 x 0)) #'integerp) nil) (deftest logandc1.error.2 (check-type-error #'(lambda (x) (logandc1 0 x)) #'integerp) nil) (deftest logandc1.error.3 (signals-error (logandc1) program-error) t) (deftest logandc1.error.4 (signals-error (logandc1 0) program-error) t) (deftest logandc1.error.5 (signals-error (logandc1 1 2 3) program-error) t) ;;; Non-error tests (deftest logandc1.1 (logandc1 0 0) 0) (deftest logandc1.2 (logandc1 0 -1) -1) (deftest logandc1.3 (logandc1 0 123) 123) (deftest logandc1.4 (loop for x in *integers* always (and (eql x (logandc1 0 x)) (eql 0 (logandc1 x x)) (eql x (logandc1 (lognot x) x)) (eql (lognot x) (logandc1 x (lognot x))))) t) (deftest logandc1.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logandc1 xc x)) collect x) nil) (deftest logandc1.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logandc1 x y) repeat 1000 unless (and (if (and (>= x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (and (not (logbitp i x)) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logandc1.order.1 (let ((i 0) a b) (values (logandc1 (progn (setf a (incf i)) 0) (progn (setf b (incf i)) -1)) i a b)) -1 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/bit.lsp0000644000000000000000000000013014542551762014745 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.785790472 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit.lsp0000644000175000017500000000555714542551762014361 0ustar00cammcamm;-*- 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 (signals-error (bit) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/modules.lsp0000644000000000000000000000013114542551763015641 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.785790472 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/modules.lsp0000644000175000017500000000376414542551763015252 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 30 19:51:06 2005 ;;;; Contains: Tests of *MODULES*, PROVIDE, and REQUIRE (in-package :cl-test) (deftest modules.1 (notnot (every #'stringp *modules*)) t) (deftest modules.2 (let ((*modules* *modules*)) (provide "FOO") (notnot (member "FOO" *modules* :test #'string=))) t) (deftest modules.3 (let ((*modules* *modules*)) (provide "FOO") (provide "FOO") (count "FOO" *modules* :test #'string=)) 1) (deftest modules.4 (let ((*modules* *modules*)) (provide "FOO") (require "FOO") (values))) (deftest modules.5 (let ((*modules* *modules*)) (provide :|FOO|) (notnot (member "FOO" *modules* :test #'string=))) t) (deftest modules.6 (let ((*modules* *modules*)) (provide "FOO") (require :|FOO|) (values))) (deftest modules.7 (let ((*modules* *modules*) (fn 'modules7-fun)) (when (fboundp fn) (fmakunbound fn)) (require "MODULES-7" #p"modules7.lsp") (funcall fn)) :good) (deftest modules.8 (let ((*modules* *modules*) (fns '(modules8a-fun modules8b-fun))) (dolist (fn fns) (when (fboundp fn) (fmakunbound fn))) (require "MODULES-8" '(#p"modules8a.lsp" #p"modules8b.lsp")) (mapcar #'funcall fns)) (:good :also-good)) (deftest modules.9 (signals-error (require "AB7djaCgaaL") error) t) (deftest modules.10 (do-special-strings (s "FOO") (let ((*modules* *modules*)) (provide s) (assert (member "FOO" *modules* :test #'string=)))) nil) (deftest modules.11 (do-special-strings (s "FOO") (let ((*modules* *modules*)) (provide "FOO") (require s) (values))) nil) (deftest modules.12 (unless (member "Z" *modules* :test #'string=) (let ((*modules* *modules*)) (provide #\Z) (not (member "Z" *modules* :test #'string=)))) nil) (deftest modules.13 (unless (member "Z" *modules* :test #'string=) (let ((*modules* *modules*)) (provide "Z") (require #\Z) nil)) nil)gcl-2.7.1/ansi-tests/PaxHeaders/listp.lsp0000644000000000000000000000013114542551762015323 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.785790472 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/listp.lsp0000644000175000017500000000153614542551762014727 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:03:37 2003 ;;;; Contains: Tests of LISTP (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) nil) (deftest listp.order.1 (let ((i 0)) (values (listp (incf i)) i)) nil 1) (deftest listp.error.1 (signals-error (listp) program-error) t) (deftest listp.error.2 (signals-error (listp nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/file-string-length.lsp0000644000000000000000000000013214542551762017673 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.785790472 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/file-string-length.lsp0000644000175000017500000000343114542551762017272 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/count-if.lsp0000644000000000000000000000013214542551762015715 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.785790472 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/count-if.lsp0000644000175000017500000003415714542551762015325 0ustar00cammcamm;-*- 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) ;;; Other special vectors (deftest count-if.special-vector.1 (do-special-integer-vectors (v #(1 0 1 1 1 0 1 1 1 0 1) nil) (assert (eql (count-if #'plusp v) 8)) (assert (eql (count-if #'zerop v) 3)) (assert (eql (count-if #'plusp v :start 2) 7)) (assert (eql (count-if #'zerop v :end 9) 2))) nil) (deftest count-if.special-vector.2 (do-special-integer-vectors (v #(1 3 2 4 7 5 6 1 0 2 4) nil) (assert (eql (count-if #'evenp v) 6)) (assert (eql (count-if #'oddp v) 5)) (assert (eql (count-if #'plusp v :start 2) 8)) (assert (eql (count-if #'zerop v :end 8) 0))) nil) (deftest count-if.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) collect (coerce e etype)) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if #'zerop vec) unless (= result 3) collect (list etype vals vec result)) nil) (deftest count-if.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float integer rational) for etype = `(complex ,cetype) for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) collect (complex 0 (coerce e cetype))) for vec = (make-array (length vals) :element-type etype :initial-contents vals) for result = (count-if #'(lambda (x) (< (abs x) 5/2)) vec) unless (= result 3) collect (list etype vals vec result)) nil) ;;; 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) (deftest count-if-string.18 (do-special-strings (s "1abC3!?deZ" nil) (assert (= (count-if #'alpha-char-p s) 6))) nil) ;;; 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 (check-type-error #'(lambda (x) (count-if #'identity x)) #'sequencep) nil) (deftest count-if.error.4 (signals-error (count-if) program-error) t) (deftest count-if.error.5 (signals-error (count-if #'null) program-error) t) (deftest count-if.error.6 (signals-error (count-if #'null nil :bad t) program-error) t) (deftest count-if.error.7 (signals-error (count-if #'null nil :bad t :allow-other-keys nil) program-error) t) (deftest count-if.error.8 (signals-error (count-if #'null nil :key) program-error) t) (deftest count-if.error.9 (signals-error (count-if #'null nil 3 3) program-error) t) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if.error.10 (signals-error (count-if #'null nil :bad t :allow-other-keys nil :allow-other-keys t) program-error) t) (deftest count-if.error.11 (signals-error (locally (count-if #'identity 1) t) type-error) t) (deftest count-if.error.12 (signals-error (count-if #'cons '(a b c)) program-error) t) (deftest count-if.error.13 (signals-error (count-if #'car '(a b c)) type-error) t) (deftest count-if.error.14 (signals-error (count-if #'identity '(a b c) :key #'cdr) type-error) t) (deftest count-if.error.15 (signals-error (count-if #'identity '(a b c) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-package.lsp0000644000000000000000000000013214542551763016500 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.785790472 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-package.lsp0000644000175000017500000003507314542551763016106 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:02:43 1998 ;;;; Contains: Tests of MAKE-PACKAGE (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 (set-up-packages) (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 (set-up-packages) (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 (set-up-packages) (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 (set-up-packages) (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.8a (progn (set-up-packages) (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.8b (progn (set-up-packages) (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) (multiple-value-prog1 (values (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 t t t t) (deftest make-package.9 (progn (set-up-packages) (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '("A"))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.9a (progn (set-up-packages) (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) (multiple-value-prog1 (values (notnot (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 t t t t) (deftest make-package.9b (progn (set-up-packages) (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#\A))))) (multiple-value-prog1 (values (notnot (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 t t t t) ;; make-package with nicknames (deftest make-package.10 (progn (mapc #'safely-delete-package '("TEST1" "F")) (let ((p (make-package "TEST1" :nicknames '("F")))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("F")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t) (deftest make-package.11 (progn (mapc #'safely-delete-package '("TEST1" "G")) (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t) (deftest make-package.12 (progn (mapc #'safely-delete-package '("TEST1" "G")) (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t) (deftest make-package.13 (progn (mapc #'safely-delete-package '(#\X #\F #\G #\H)) (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "X") (set-exclusive-or (package-nicknames p) '("F" "G" "H") :test #'equal) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t nil t) ;;; Specialized sequences as designators ;;; The package name being a specialized sequence (defmacro def-make-package-test1 (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (assert (string= name "TEST1")) (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package name)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t)) (def-make-package-test1 make-package.14 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-make-package-test1 make-package.15 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'base-char)) (def-make-package-test1 make-package.16 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'character)) (def-make-package-test1 make-package.17 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-make-package-test1 make-package.18 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-make-package-test1 make-package.19 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-make-package-test1 make-package.20 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Nicknames being specialized sequences (defmacro def-make-package-test2 (test-name name-form) `(deftest ,test-name (let ((name ,name-form) (nickname "TEST1-NICKNAME")) (safely-delete-package "TEST1") (safely-delete-package nickname) (let ((p (make-package name :nicknames (list nickname)))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) (list nickname)) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t)) (def-make-package-test2 make-package.21 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-make-package-test2 make-package.22 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'base-char)) (def-make-package-test2 make-package.23 (make-array 12 :initial-contents "TEST1xxxyyyz" :fill-pointer 5 :element-type 'character)) (def-make-package-test2 make-package.24 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-make-package-test2 make-package.25 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-make-package-test2 make-package.26 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-make-package-test2 make-package.27 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "xxTEST1yyy" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; USE names being specialized sequences (defmacro def-make-package-test3 (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (set-up-packages) (safely-delete-package "TEST1") (assert (find-package name)) (let ((p (ignore-errors (make-package "TEST1" :use (list name))))) (multiple-value-prog1 (values (notnot (packagep p)) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package name))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t t t t t)) (def-make-package-test3 make-package.28 (make-array 1 :initial-contents "A" :element-type 'base-char)) (def-make-package-test3 make-package.29 (make-array 8 :initial-contents "Axxxyyyz" :fill-pointer 1 :element-type 'base-char)) (def-make-package-test3 make-package.30 (make-array 8 :initial-contents "Axxxyyyz" :fill-pointer 1 :element-type 'character)) (def-make-package-test3 make-package.31 (make-array 1 :initial-contents "A" :adjustable t :element-type 'base-char)) (def-make-package-test3 make-package.32 (make-array 1 :initial-contents "A" :adjustable t :element-type 'character)) (def-make-package-test3 make-package.33 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "xxAyyy0123" :element-type etype))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-make-package-test3 make-package.34 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "xxAzzzzyyy" :element-type etype))) (make-array 1 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;; Signal a continuable error if the package or any nicknames ;; exist as packages or nicknames of packages (deftest make-package.error.1 (progn (set-up-packages) (handle-non-abort-restart (make-package "A"))) success) (deftest make-package.error.2 (progn (set-up-packages) (handle-non-abort-restart (make-package "Q"))) success) (deftest make-package.error.3 (progn (set-up-packages) (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") (set-up-packages) (make-package "TEST1" :nicknames '("Q"))) success) (deftest make-package.error.5 (signals-error (make-package) program-error) t) (deftest make-package.error.6 (progn (safely-delete-package "MPE6") (signals-error (make-package "MPE6" :bad t) program-error)) t) (deftest make-package.error.7 (progn (safely-delete-package "MPE7") (signals-error (make-package "MPE7" :nicknames) program-error)) t) (deftest make-package.error.8 (progn (safely-delete-package "MPE8") (signals-error (make-package "MPE8" :use) program-error)) t) (deftest make-package.error.9 (progn (safely-delete-package "MPE9") (signals-error (make-package "MPE9" 'bad t) program-error)) t) (deftest make-package.error.10 (progn (safely-delete-package "MPE10") (signals-error (make-package "MPE10" 1 2) program-error)) t) (deftest make-package.error.11 (progn (safely-delete-package "MPE11") (signals-error (make-package "MPE11" 'bad t :allow-other-keys nil) program-error)) t) gcl-2.7.1/ansi-tests/PaxHeaders/logior.lsp0000644000000000000000000000013214542551763015465 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.785790472 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logior.lsp0000644000175000017500000000343614542551763015071 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:08:21 2003 ;;;; Contains: Tests of LOGIOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logior.error.1 (check-type-error #'logior #'integerp) nil) (deftest logior.error.2 (check-type-error #'(lambda (x) (logior 0 x)) #'integerp) nil) ;;; Non-error tests (deftest logior.1 (logior) 0) (deftest logior.2 (logior 1231) 1231) (deftest logior.3 (logior -198) -198) (deftest logior.4 (loop for x in *integers* always (eql x (logior x))) t) (deftest logior.5 (loop for x in *integers* always (eql -1 (logior x (lognot x)))) t) (deftest logior.6 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql -1 (logior x xc)) collect x) nil) (deftest logior.7 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logior x y) repeat 1000 unless (and (if (or (< x 0) (< y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (logbitp i x) (logbitp i y)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logior.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) for args = (nconc (make-list (1- i) :initial-element 0) (list -21231)) always (eql (apply #'logior args) -21231)) t) (deftest logior.order.1 (let ((i 0) a b) (values (logior (progn (setf a (incf i)) #b11010) (progn (setf b (incf i)) #b10110)) i a b)) #b11110 2 1 2) (deftest logior.order.2 (let ((i 0) a b c) (values (logior (progn (setf a (incf i)) #b10011) (progn (setf b (incf i)) #b10110) (progn (setf c (incf i)) #b110101)) i a b c)) #b110111 3 1 2 3) gcl-2.7.1/ansi-tests/PaxHeaders/packages-16.lsp0000644000000000000000000000013114542551763016173 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.785790472 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-16.lsp0000644000175000017500000004167014542551763015602 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/invoke-debugger.lsp0000644000000000000000000000013114542551762017245 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.785790472 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/invoke-debugger.lsp0000644000175000017500000000343714542551762016653 0ustar00cammcamm;-*- 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) (deftest invoke-debugger.error.1 (signals-error (block done (let ((*debugger-hook* #'(lambda (&rest args) (declare (ignore args)) (return-from done 'bad)))) (invoke-debugger))) program-error) t) (deftest invoke-debugger.error.2 (signals-error (block done (let ((*debugger-hook* #'(lambda (&rest args) (declare (ignore args)) (return-from done 'bad)))) (invoke-debugger (make-condition 'simple-error) nil))) program-error) t) ;;; If the debugger hook function expects the wrong number ;;; of arguments, a program-error should be thrown in safe code ;;; This error is thrown 'prior to entry to the standard debugger'. (deftest invoke-debugger.error.3 (signals-error (let ((*debugger-hook* #'(lambda () nil))) (invoke-debugger (make-condition 'simple-error))) program-error) t) (deftest invoke-debugger.error.4 (signals-error (let ((*debugger-hook* #'(lambda (c) c))) (invoke-debugger (make-condition 'simple-error))) program-error) t) (deftest invoke-debugger.error.5 (signals-error (let ((*debugger-hook* #'(lambda (c hook x) (list c hook x)))) (invoke-debugger (make-condition 'simple-error))) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-pathnames.lsp0000644000000000000000000000013214772071555017070 xustar0030 mtime=1743287149.362905223 30 atime=1744294960.789790489 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-pathnames.lsp0000644000175000017500000000162014772071555016465 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/format-goto.lsp0000644000000000000000000000013214542551762016427 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.789790489 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-goto.lsp0000644000175000017500000000505614542551762016033 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 24 06:56:13 2004 ;;;; Contains: Tests of the ~* format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; ~* (def-format-test format.*.1 "~A~*~A" (1 2 3) "13") (def-format-test format.*.2 "~A~0*~A" (1 2 3) "12" 1) (def-format-test format.*.3 "~A~v*~A" (1 0 2) "12") (def-format-test format.*.4 "~A~v*~A" (1 1 2 3) "13") (def-format-test format.*.5 "~A~v*~A" (1 nil 2 3) "13") (def-format-test format.*.6 "~A~1{~A~*~A~}~A" (0 '(1 2 3) 4) "0134") (def-format-test format.*.7 "~A~1{~A~0*~A~}~A" (0 '(1 2 3) 4) "0124") (def-format-test format.*.8 "~A~{~A~*~A~}~A" (0 '(1 2 3 4 5 6) 7) "013467") (def-format-test format.*.9 "~A~{~A~A~A~A~v*~^~A~A~A~A~}~A" (0 '(1 2 3 4 nil 6 7 8 9 #\A) 5) "01234789A5") ;;; ~:* (def-format-test format.\:*.1 "~A~:*~A" (1 2 3) "11" 2) (def-format-test format.\:*.2 "~A~A~:*~A" (1 2 3) "122" 1) (def-format-test format.\:*.3 "~A~A~0:*~A" (1 2 3) "123") (def-format-test format.\:*.4 "~A~A~2:*~A" (1 2 3) "121" 2) (def-format-test format.\:*.5 "~A~A~v:*~A" (1 2 0 3) "123") (def-format-test format.\:*.6 "~A~A~v:*~A" (6 7 2 3) "677" 2) (def-format-test format.\:*.7 "~A~A~v:*~A" (6 7 nil 3) "67NIL" 1) (def-format-test format.\:*.8 "~A~1{~A~:*~A~}~A" (0 '(1 2 3) 4) "0114") (def-format-test format.\:*.9 "~A~1{~A~A~A~:*~A~}~A" (0 '(1 2 3 4) 5) "012335") (def-format-test format.\:*.10 "~A~1{~A~A~A~2:*~A~A~}~A" (0 '(1 2 3 4) 5) "0123235") (def-format-test format.\:*.11 "~A~{~A~A~A~3:*~A~A~A~A~}~A" (0 '(1 2 3 4) 5) "012312345") (def-format-test format.\:*.12 "~A~{~A~A~A~A~4:*~^~A~A~A~A~}~A" (0 '(1 2 3 4) 5) "0123412345") (def-format-test format.\:*.13 "~A~{~A~A~A~A~v:*~^~A~}~A" (0 '(1 2 3 4 nil) 5) "01234NIL5") ;;; ~@* (def-format-test format.@*.1 "~A~A~@*~A~A" (1 2 3 4) "1212" 2) (def-format-test format.@*.2 "~A~A~1@*~A~A" (1 2 3 4) "1223" 1) (def-format-test format.@*.3 "~A~A~2@*~A~A" (1 2 3 4) "1234") (def-format-test format.@*.4 "~A~A~3@*~A~A" (1 2 3 4 5) "1245") (def-format-test format.@*.5 "~A~A~v@*~A~A" (1 2 nil 3 4) "1212" 3) (def-format-test format.@*.6 "~A~A~v@*~A~A" (1 2 1 3 4) "1221" 2) (def-format-test format.@*.7 "~A~A~v@*~A~A" (6 7 2 3 4) "6723" 1) (def-format-test format.@*.8 "~A~{~A~A~@*~A~A~}~A" (0 '(1 2) 9) "012129") (def-format-test format.@*.9 "~A~{~A~A~0@*~A~A~}~A" (0 '(1 2) 9) "012129") (def-format-test format.@*.10 "~A~1{~A~A~v@*~A~A~}~A" (0 '(1 2 nil) 9) "012129") (def-format-test format.@*.11 "~A~{~A~A~1@*~A~}~A" (0 '(1 2) 9) "01229") gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-03.lsp0000644000000000000000000000013214542551762016330 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.789790489 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-03.lsp0000644000175000017500000000131714542551762015730 0ustar00cammcamm;-*- 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) (compile-and-load "cons-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (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) gcl-2.7.1/ansi-tests/PaxHeaders/stable-sort.lsp0000644000000000000000000000013214542551763016431 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.789790489 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/stable-sort.lsp0000644000175000017500000001360714542551763016036 0ustar00cammcamm;-*- 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)) ;;; FIXME Add random test similar to sort.5 here (deftest stable-sort-vector.6 (do-special-integer-vectors (v #(1 4 7 3 2 6 5) nil) (let ((sv (stable-sort v #'<))) (assert (equalp sv #(1 2 3 4 5 6 7))))) nil) (deftest stable-sort-vector.7 (do-special-integer-vectors (v #(0 1 1 0 1 1 0 1 0) nil) (let ((sv (stable-sort v #'<))) (assert (equalp sv #(0 0 0 0 1 1 1 1 1))))) nil) (deftest stable-sort-vector.8 (do-special-integer-vectors (v #(0 -1 -1 0 -1 -1 0 -1 0) nil) (let ((sv (stable-sort v #'>))) (assert (equalp sv #(0 0 0 0 -1 -1 -1 -1 -1))))) nil) (deftest stable-sort-vector.9 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for etype in '(short-float single-float double-float long-float rational) for vals = (loop for i in ivals collect (coerce i etype)) for svals = (loop for i in sivals collect (coerce i etype)) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (stable-sort vec #'<) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) (deftest stable-sort-vector.10 (let* ((ivals '(1 4 7 3 2 6 5)) (sivals '(1 2 3 4 5 6 7)) (len (length ivals))) (loop for cetype in '(short-float single-float double-float long-float rational) for etype = `(complex ,cetype) for vals = (loop for i in ivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for svals = (loop for i in sivals collect (complex (coerce i cetype) (coerce (- i) cetype))) for vec = (make-array len :element-type etype :initial-contents vals) for svec = (stable-sort vec #'(lambda (x y) (< (abs x) (abs y)))) unless (and (eql (length svec) len) (every #'eql svals svec)) collect (list etype vals svec))) nil) ;;; Bit vectors (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") (deftest stable-sort-string.4 (do-special-strings (s "aebdc" nil) (let ((s2 (stable-sort s #'char<))) (assert (eq s s2)) (assert (string= s2 "abcde")))) nil) ;;; 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 (signals-error (stable-sort) program-error) t) (deftest stable-sort.error.2 (signals-error (stable-sort nil) program-error) t) (deftest stable-sort.error.3 (signals-error (stable-sort nil #'< :key) program-error) t) (deftest stable-sort.error.4 (signals-error (stable-sort nil #'< 'bad t) program-error) t) (deftest stable-sort.error.5 (signals-error (stable-sort nil #'< 'bad t :allow-other-keys nil) program-error) t) (deftest stable-sort.error.6 (signals-error (stable-sort nil #'< 1 2) program-error) t) (deftest stable-sort.error.7 (signals-error (stable-sort (list 1 2 3 4) #'identity) program-error) t) (deftest stable-sort.error.8 (signals-error (stable-sort (list 1 2 3 4) #'< :key #'cons) program-error) t) (deftest stable-sort.error.9 (signals-error (stable-sort (list 1 2 3 4) #'< :key #'car) type-error) t) (deftest stable-sort.error.10 (signals-error (stable-sort (list 1 2 3 4) #'elt) type-error) t) (deftest stable-sort.error.11 (check-type-error #'(lambda (x) (stable-sort x #'<)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/streamp.lsp0000644000000000000000000000013214542551763015645 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.789790489 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/streamp.lsp0000644000175000017500000000170114542551763015242 0ustar00cammcamm;-*- 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) nil) (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.7.1/ansi-tests/PaxHeaders/logical-pathname-translations.lsp0000644000000000000000000000013214542551763022116 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.789790489 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logical-pathname-translations.lsp0000644000175000017500000000025114542551763021512 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/atanh.lsp0000644000000000000000000000013214542551762015264 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.789790489 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/atanh.lsp0000644000175000017500000000531014542551762014661 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 19:26:25 2004 ;;;; Contains: Tests of ATANH (in-package :cl-test) (deftest atanh.1 (let ((result (atanh 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest atanh.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (equal (multiple-value-list (atanh zero)) (list zero)) collect type) nil) (deftest atanh.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 `(complex ,type)) unless (equal (multiple-value-list (atanh zero)) (list zero)) collect type) nil) (deftest atanh.4 (loop for den = (1+ (random 10000)) for num = (random den) for x = (/ num den) for rlist = (multiple-value-list (atanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (numberp y)) collect (list x rlist)) nil) (deftest atanh.5 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (if (eql (random 2) 0) (+ 2 (random (coerce 1000 type))) (- -2 (random (coerce 1000 type)))) for rlist = (multiple-value-list (atanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x rlist))) nil) (deftest atanh.5a (loop for type in '(short-float single-float double-float long-float) nconc (loop for x = (- (random (coerce 1.9998s0 type)) 0.9999s0) for rlist = (multiple-value-list (atanh x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) nil) (deftest atanh.6 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) for rlist = (multiple-value-list (atanh (complex x1 0.0s0))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 rlist))) nil) (deftest atanh.7 (loop for type in '(short-float single-float double-float long-float) nconc (loop for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) for rlist = (multiple-value-list (atanh (complex 0.0s0 x1))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 rlist))) nil) (deftest atanh.8 (macrolet ((%m (z) z)) (atanh (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; Add accuracy tests here ;;; Error tests (deftest atanh.error.1 (signals-error (atanh) program-error) t) (deftest atanh.error.2 (signals-error (atanh 1.0 1.0) program-error) t) (deftest atanh.error.3 (check-type-error #'atanh #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/with-simple-restart.lsp0000644000000000000000000000013214542551763020116 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.789790489 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-simple-restart.lsp0000644000175000017500000000207614542551763017521 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 04:36:52 2003 ;;;; Contains: Tests for WITH-SIMPLE-RESTART (in-package :cl-test) (deftest with-simple-restart.1 (with-simple-restart (foo "")) nil) (deftest with-simple-restart.2 (with-simple-restart (foo "") (values))) (deftest with-simple-restart.3 (with-simple-restart (foo "") (values 1 2 3 4 5 6 7 8 9 10)) 1 2 3 4 5 6 7 8 9 10) (deftest with-simple-restart.4 (block nil (tagbody (with-simple-restart (foo "") (go 10) 10 (return 'bad)) 10 (return 'good))) good) (deftest with-simple-restart.5 (with-simple-restart (foo "zzz") (invoke-restart 'foo)) nil t) (deftest with-simple-restart.6 (flet ((%f () (invoke-restart 'foo))) (with-simple-restart (foo "zzz") (%f))) nil t) (deftest with-simple-restart.7 (with-simple-restart (foo (formatter "xxx")) (invoke-restart 'foo)) nil t) (deftest with-simple-restart.8 (with-simple-restart (nil "") (invoke-restart (first (compute-restarts)))) nil t) gcl-2.7.1/ansi-tests/PaxHeaders/typecase.lsp0000644000000000000000000000013114542551763016006 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.789790489 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/typecase.lsp0000644000175000017500000000624414542551763015413 0ustar00cammcamm;-*- 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) (deftest typecase.16 (block done (tagbody (typecase 'a (symbol (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) (deftest typecase.17 (block done (tagbody (typecase 'a (integer 'bad) (t (go 10) 10 (return-from done 'bad))) 10 (return-from done 'good))) good) (deftest typecase.18 (loop for x in '(a 1 1.4 "c") collect (typecase x (t :good) (otherwise :bad))) (:good :good :good :good)) ;;; A randomized test (deftest typecase.19 (let* ((u (coerce *universe* 'vector)) (len1 (length u)) (types (coerce *cl-all-type-symbols* 'vector)) (len2 (length types))) (loop for n = (random 10) for my-types = (loop repeat n collect (elt types (random len2))) for val = (elt u (random len1)) for i = (position val my-types :test #'typep) for form = `(typecase ',val ,@(loop for i from 0 for type in my-types collect `(,type ,i)) (otherwise nil)) for j = (eval form) repeat 1000 unless (eql i j) collect (list n my-types val i form j))) nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest typecase.20 (macrolet ((%m (z) z)) (typecase (expand-in-current-env (%m 2)) ((integer 0 1) :bad1) ((integer 2 10) :good) (t :bad2))) :good) (deftest typecase.21 (macrolet ((%m (z) z)) (typecase 2 ((integer 0 1) (expand-in-current-env (%m :bad1))) ((integer 2 10) (expand-in-current-env (%m :good))) (t (expand-in-current-env (%m :bad2))))) :good) ;;; Error cases (deftest typecase.error.1 (signals-error (funcall (macro-function 'typecase)) program-error) t) (deftest typecase.error.2 (signals-error (funcall (macro-function 'typecase) '(typecase t)) program-error) t) (deftest typecase.error.3 (signals-error (funcall (macro-function 'typecase) '(typecase t) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/package-use-list.lsp0000644000000000000000000000013114542551763017327 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.793790506 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/package-use-list.lsp0000644000175000017500000000355414542551763016735 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 06:55:56 2004 ;;;; Contains: Tests of PACKAGE-USE-LIST (in-package :cl-test) ;;; Most tests of this function are in files for other package-related operators ;;; Specialized sequence tests (defmacro def-package-use-list-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) (package-use-list p))) nil)) (def-package-use-list-test package-use-list.1 (make-array 5 :element-type 'base-char :initial-contents "TEST1")) (def-package-use-list-test package-use-list.2 (make-array 10 :element-type 'base-char :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-use-list-test package-use-list.3 (make-array 10 :element-type 'character :fill-pointer 5 :initial-contents "TEST1?????")) (def-package-use-list-test package-use-list.4 (make-array 5 :element-type 'base-char :adjustable t :initial-contents "TEST1")) (def-package-use-list-test package-use-list.5 (make-array 5 :element-type 'character :adjustable t :initial-contents "TEST1")) (def-package-use-list-test package-use-list.6 (let* ((etype 'base-char) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) (def-package-use-list-test package-use-list.7 (let* ((etype 'character) (name0 (make-array 10 :element-type etype :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 2))) ;;; Error tests (deftest package-use-list.error.1 (signals-error (package-use-list) program-error) t) (deftest package-use-list.error.2 (signals-error (package-use-list "CL" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/assoc.lsp0000644000000000000000000000013214542551762015301 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.793790506 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/assoc.lsp0000644000175000017500000001522414542551762014703 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:27:20 2003 ;;;; Contains: Tests of ASSOC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (schar 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 test arguments (deftest assoc.26 (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test #'<) (11 d)) (deftest assoc.27 (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test-not #'>=) (11 d)) ;;; Special cases: the nil key does not match the nil pair (deftest assoc.30 (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h)))) (nil . e)) (deftest assoc.31 (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h)) :test #'eq)) (nil . e)) ;;; :test & :test-not together are harmless (defharmless assoc.test-and-test-not.1 (assoc 'a '((a . 1) (b . 2)) :test #'eql :test-not #'eql)) (defharmless assoc.test-and-test-not.2 (assoc 'a '((a . 1) (b . 2)) :test-not #'eql :test #'eql)) ;;; 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 (signals-error (assoc) program-error) t) (deftest assoc.error.2 (signals-error (assoc nil) program-error) t) (deftest assoc.error.3 (signals-error (assoc nil nil :bad t) program-error) t) (deftest assoc.error.4 (signals-error (assoc nil nil :key) program-error) t) (deftest assoc.error.5 (signals-error (assoc nil nil 1 1) program-error) t) (deftest assoc.error.6 (signals-error (assoc nil nil :bad t :allow-other-keys nil) program-error) t) (deftest assoc.error.7 (signals-error (assoc 'a '((a . b)) :test #'identity) program-error) t) (deftest assoc.error.8 (signals-error (assoc 'a '((a . b)) :test-not #'identity) program-error) t) (deftest assoc.error.9 (signals-error (assoc 'a '((a . b)) :key #'cons) program-error) t) (deftest assoc.error.10 (signals-error (assoc 'z '((a . b) . c)) type-error) t) (deftest assoc.error.11 (signals-error (assoc 'z '((a . b) :bad (c . d))) type-error) t) (deftest assoc.error.12 (signals-type-error x 'y (assoc 'x x)) t) gcl-2.7.1/ansi-tests/PaxHeaders/cons-test-12.lsp0000644000000000000000000000013214542551762016330 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.793790506 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-12.lsp0000644000175000017500000000375314542551762015736 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/make-string-output-stream.lsp0000644000000000000000000000013214542551763021242 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.793790506 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-string-output-stream.lsp0000644000175000017500000000732714542551763020651 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/packages-07.lsp0000644000000000000000000000013114542551763016173 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.793790506 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-07.lsp0000644000175000017500000001366514542551763015605 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/packages-15.lsp0000644000000000000000000000013114542551763016172 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.793790506 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-15.lsp0000644000175000017500000001374014542551763015576 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/multiple-value-prog1.lsp0000644000000000000000000000013114542551763020164 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.793790506 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/multiple-value-prog1.lsp0000644000175000017500000000371714542551763017573 0ustar00cammcamm;-*- 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) ;;; No implicit tagbody (deftest multiple-value-prog1.10 (block nil (tagbody (multiple-value-prog1 (values) (go 10) 10 (return 'bad)) 10 (return 'good))) good) ;;; Macros are expanded in the appropriate environment (deftest multiple-value-prog1.11 (macrolet ((%m (z) z)) (multiple-value-prog1 (expand-in-current-env (%m :good)))) :good) (deftest multiple-value-prog1.12 (macrolet ((%m (z) z)) (multiple-value-prog1 :good (expand-in-current-env (%m :foo)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/gclload1.lsp0000644000000000000000000000013214772071544015657 xustar0030 mtime=1743287140.562897139 30 atime=1744294960.793790506 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/gclload1.lsp0000644000175000017500000000302514772071544015255 0ustar00cammcamm#+:ecl (si::package-lock (find-package "COMMON-LISP") nil) #+:armedbear (require 'pprint) #+cmu (setq ext:*gc-verbose* nil) #+gcl(setq si::*code-block-reserve* (or si::*code-block-reserve* (make-array 30000000 :element-type 'character :static t)) compiler:*suppress-compiler-notes* t compiler:*suppress-compiler-warnings* t compiler:*compile-verbose* nil compiler:*compile-print* nil) #+lispworks (setq compiler::*compiler-warnings* nil) #+lispworks (make-echo-stream *standard-input* *standard-output*) #+ecl (compile nil '(lambda () nil)) #+ecl (setq c:*suppress-compiler-warnings* t c:*suppress-compiler-notes* t) #+clisp (setq custom::*warn-on-floating-point-contagion* nil) (let (*load-verbose* *load-print* *compile-verbose* *compile-print*) (load "compile-and-load.lsp")) (let (*load-verbose* *load-print* *compile-verbose* *compile-print*) (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) (compile-and-load "ansi-aux-macros.lsp") (handler-bind #-sbcl () #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) (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) gcl-2.7.1/ansi-tests/PaxHeaders/nstring-downcase.lsp0000644000000000000000000000013114542551763017456 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.793790506 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nstring-downcase.lsp0000644000175000017500000001113314542551763017054 0ustar00cammcamm;-*- 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.11 :notes (:nil-vectors-are-strings) (nstring-downcase (make-array '(0) :element-type nil)) "") (deftest nstring-downcase.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list (copy-seq s) (copy-seq (nstring-downcase s)) (copy-seq s) (progn (setf (fill-pointer s) 10) (copy-seq s)) )) (("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi"))) (deftest nstring-downcase.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list (copy-seq s) (nstring-downcase s) (copy-seq s) s0)) (("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG"))) (deftest nstring-downcase.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list (copy-seq s) (nstring-downcase s) (copy-seq s))) (("aB0cD" "ab0cd" "ab0cd") ("aB0cD" "ab0cd" "ab0cd") ("aB0cD" "ab0cd" "ab0cd"))) ;;; Order of evaluation tests (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 (signals-error (nstring-downcase) program-error) t) (deftest nstring-downcase.error.2 (signals-error (nstring-downcase (copy-seq "abc") :bad t) program-error) t) (deftest nstring-downcase.error.3 (signals-error (nstring-downcase (copy-seq "abc") :start) program-error) t) (deftest nstring-downcase.error.4 (signals-error (nstring-downcase (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest nstring-downcase.error.5 (signals-error (nstring-downcase (copy-seq "abc") :end) program-error) t) (deftest nstring-downcase.error.6 (signals-error (nstring-downcase (copy-seq "abc") 1 2) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/packages-03.lsp0000644000000000000000000000013114542551763016167 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.793790506 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-03.lsp0000644000175000017500000001167114542551763015574 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/typep.lsp0000644000000000000000000000013114542551763015332 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.793790506 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/typep.lsp0000644000175000017500000000653714542551763014744 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 23 07:13:32 2005 ;;;; Contains: Tests of TYPEP (in-package :cl-test) (deftest typep.error.1 (signals-error (typep) program-error) t) (deftest typep.error.2 (signals-error (typep nil) program-error) t) (deftest typep.error.3 (signals-error (typep nil t nil nil) program-error) t) (deftest typep.error.4 (signals-error-always (typep nil 'values) error) t t) (deftest typep.error.5 (signals-error-always (typep nil '(values)) error) t t) (deftest typep.error.6 (signals-error-always (typep nil '(values t t t t)) error) t t) (deftest typep.error.7 (signals-error-always (typep nil '(function () t)) error) t t) ;;; Non-error tests ;;; Many more tests use typep when testing other functions (deftest typep-nil-null (notnot-mv (typep nil 'null)) t) (deftest typep-t-null (typep t 'null) nil) ;;; 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) (deftest typep.18 (let ((i 0)) (values (notnot (typep (incf i) '(and (integer 0 10) (integer -5 6)))) i)) t 1) (defun typep.19-fn (reps &optional (prob .5)) (let* ((vec "abcdefghijklmnopqrstuvwxyz")) (flet ((%make-random-type () `(and character (member ,@(loop for e across vec when (< (random 1.0) prob) collect e))))) (loop for t1 = (%make-random-type) for t2 = (%make-random-type) for t3 = `(and ,t1 ,t2) for result1 = (loop for e across vec when (if (typep e t3) (or (not (typep e t1)) (not (typep e t2))) (and (typep e t1) (typep e t2))) collect e) repeat reps when result1 nconc (list result1 t1 t2 t3))))) (eval-when (:load-toplevel) (compile 'typep.19-fn)) (deftest typep.19 (typep.19-fn 1000) nil) gcl-2.7.1/ansi-tests/PaxHeaders/remove-aux.lsp0000644000000000000000000000013114542551763016261 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.797790524 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remove-aux.lsp0000644000175000017500000002242114542551763015661 0ustar00cammcamm;-*- 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)) ((and (listp type) (eql (car type) 'integer) (integerp (cadr type)) (integerp (caddr type)) (null (cdddr type))) (+ (cadr type) (random (- (1+ (caddr type)) (cadr type))))) ((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 (setf test (coerce test 'function)) #'(lambda (x) (funcall (the function test) element x))) (test-not-p (setf test-not (coerce test-not 'function)) #'(lambda (x) (not (funcall (the function 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))) (setf predicate (coerce predicate 'function)) (setf key (coerce key 'function)) ;; 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 (the function predicate) (funcall (the function 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 (rcase (2 t) (1 'bit) (1 '(integer 0 2)) (1 'symbol))) (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)) (setf tested-fn (coerce tested-fn 'function)) (setf check-fn (coerce check-fn 'function)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (the function tested-fn) element seq1 arg-list)) (seq2r (apply (the function check-fn) element seq2 arg-list))) (setq *remove-fail-args* (list* element seq 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)) (setf test (coerce test 'function)) (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 (the function 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)) (setf test (coerce test 'function)) (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 (the function 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.7.1/ansi-tests/PaxHeaders/describe.lsp0000644000000000000000000000013214542551762015751 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.797790524 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/describe.lsp0000644000175000017500000000500614542551762015350 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 13:22:13 2004 ;;;; Contains: Tests of DESCRIBE (in-package :cl-test) (defun harness-for-describe (fn) (let (s1 s2) (with-open-stream (*standard-output* (make-string-output-stream)) (with-open-stream (tio-input (make-string-input-stream "X")) (with-open-stream (tio-output (make-string-output-stream)) (with-open-stream (*terminal-io* (make-two-way-stream tio-input tio-output)) (let ((*print-circle* t) (*print-readably* nil)) (assert (null (multiple-value-list (funcall fn)))))) (setq s2 (get-output-stream-string tio-output))) (assert (equal (read-char tio-input) #\X))) (setq s1 (get-output-stream-string *standard-output*))) (values s1 s2))) (deftest describe.1 (loop for x in *universe* for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x)))) when (and (equal s1 "") (equal s2 "")) collect x) nil) (deftest describe.2 (loop for x in *universe* for s1 = nil for s2 = nil for s3 = (with-output-to-string (s) (setf (values s1 s2) (harness-for-describe #'(lambda () (describe x s))))) when (or (equal s3 "") (not (equal "" s2)) (not (equal "" s1))) collect (list x s1 s2 s3)) nil) (deftest describe.3 (loop for x in *universe* for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x t)))) when (or (equal "" s2) (not (equal "" s1))) collect (list x s1 s2)) nil) (deftest describe.4 (loop for x in *universe* for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x nil)))) when (or (equal "" s1) (not (equal "" s2))) collect (list x s1 s2)) nil) ;;; Defining methods for describe-object (defclass describe-object-test-class-01 () ((s1 :initarg :s1) (s2 :initarg :s2) (s3 :initarg :s3))) (defmethod describe-object ((obj describe-object-test-class-01) stream) (format stream "ABCDE ~A ~A ~A XYZ" (slot-value obj 's1) (slot-value obj 's2) (slot-value obj 's3))) (deftest describe.5 (let ((obj (make-instance 'describe-object-test-class-01 :s1 2 :s2 6 :s3 17))) (multiple-value-bind (str1 str2) (harness-for-describe #'(lambda () (describe obj))) (if (or (search "ABCDE 2 6 17 XYZ" str1) (search "ABCDE 2 6 17 XYZ" str2)) :good (list str1 str2)))) :good) ;;; Error cases (deftest describe.error.1 (signals-error (describe) program-error) t) (deftest describe.error.2 (signals-error (with-output-to-string (s) (describe nil s nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ignorable.lsp0000644000000000000000000000013114542551762016132 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.797790524 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/ignorable.lsp0000644000175000017500000000221714542551762015533 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 08:16:27 2005 ;;;; Contains: Tests of the IGNORABLE declaration (in-package :cl-test) (deftest ignorable.1 (let ((x 'foo)) (declare (ignorable x))) nil) (deftest ignorable.2 (let ((x 'foo)) (declare (ignorable x)) x) foo) (deftest ignorable.3 (flet ((%f () 'foo)) (declare (ignorable (function %f)))) nil) (deftest ignorable.4 (flet ((%f () 'foo)) (declare (ignorable (function %f))) (%f)) foo) ;;; TODO: add a test for (function (setf foo)) (deftest ignorable.5 (flet (((setf %f) (x y) nil)) (declare (ignorable (function (setf %f)))) :good) :good) (deftest ignorable.6 (flet (((setf %f) (x y) (setf (car y) x))) (declare (ignorable (function (setf %f)))) (let ((z (cons 'a 'b))) (values (setf (%f z) 'c) z))) c (c . b)) (deftest ignorable.7 (labels (((setf %f) (x y) nil)) (declare (ignorable (function (setf %f)))) :good) :good) (deftest ignorable.8 (labels (((setf %f) (x y) (setf (car y) x))) (declare (ignorable (function (setf %f)))) (let ((z (cons 'a 'b))) (values (setf (%f z) 'c) z))) c (c . b)) gcl-2.7.1/ansi-tests/PaxHeaders/upgraded-array-element-type.lsp0000644000000000000000000000013114542551763021506 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.797790524 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/upgraded-array-element-type.lsp0000644000175000017500000000723414542551763021113 0ustar00cammcamm;-*- 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 `(eql ,(ash 1 i))) ,@(loop for i from 0 to 32 collect `(eql ,(1- (ash 1 i)))) (eql -1) ,@(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) unless (empirical-subtypep type upgraded-type) collect (list type upgraded-type)) nil) ;; 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) unless (empirical-subtypep type upgraded-type) collect (list type upgraded-type)) nil) (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 that if Tx is a subtype of Ty, then UAET(Tx) is a subtype ;;; of UAET(Ty) (see section 15.1.2.1, paragraph 3) (deftest upgraded-array-element-type.8 (let ((upgraded-types (mapcar #'upgraded-array-element-type *upgraded-array-types-to-check*))) (loop for type1 in *upgraded-array-types-to-check* for uaet1 in upgraded-types append (loop for type2 in *upgraded-array-types-to-check* for uaet2 in upgraded-types when (and (subtypep type1 type2) (not (empirical-subtypep uaet1 uaet2))) collect (list type1 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))) (check-predicate (typef `(not ,uaet-nil)))) nil) ;;; Error tests (deftest upgraded-array-element-type.error.1 (signals-error (upgraded-array-element-type) program-error) t) (deftest upgraded-array-element-type.error.2 (signals-error (upgraded-array-element-type 'bit nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-r.lsp0000644000000000000000000000013214542551762015720 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.797790524 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-r.lsp0000644000175000017500000003240414542551762015321 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 28 00:33:02 2004 ;;;; Contains: Tests of the format directive ~R (in-package :cl-test) ;;; Test of various radixes (compile-and-load "printer-aux.lsp") (compile-and-load "roman-numerals.lsp") (deftest format.r.1 (loop for i from 2 to 36 for s = (format nil "~~~dR" i) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (format nil s x) for s2 = (with-standard-io-syntax (write-to-string x :base i :readably nil)) repeat 100 unless (string= s1 s2) collect (list i x s1 s2))) nil) (deftest formatter.r.1 (loop for i from 2 to 36 for s = (format nil "~~~dR" i) for fn = (eval `(formatter ,s)) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (formatter-call-to-string fn x) for s2 = (with-standard-io-syntax (write-to-string x :base i :readably nil)) repeat 100 unless (string= s1 s2) collect (list i x s1 s2))) nil) (def-format-test format.r.2 "~2r" (14) "1110") (def-format-test format.r.3 "~3r" (29) "1002") (deftest format.r.4 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~DR" base mincol) for s = (format nil fmt base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\Space) "10") s)) collect (list base mincol s))) nil) (deftest formatter.r.4 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~DR" base mincol) for fn = (eval `(formatter ,fmt)) for s = (formatter-call-to-string fn base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\Space) "10") s)) collect (list base mincol s))) nil) (deftest format.r.5 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~D,'*r" base mincol) for s = (format nil fmt base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\*) "10") s)) collect (list base mincol s))) nil) (deftest formatter.r.5 (loop for base from 2 to 36 nconc (loop for mincol from 0 to 20 for fmt = (format nil "~~~D,~D,'*r" base mincol) for fn = (eval `(formatter ,fmt)) for s = (formatter-call-to-string fn base) unless (if (<= mincol 2) (string= s "10") (string= (concatenate 'string (make-string (- mincol 2) :initial-element #\*) "10") s)) collect (list base mincol s))) nil) (deftest format.r.6 (loop for base from 2 to 36 for s = (format nil "~vr" base (1+ base)) unless (string= s "11") collect (list base s)) nil) (deftest formatter.r.6 (let ((fn (formatter "~vr"))) (loop for base from 2 to 36 for s = (formatter-call-to-string fn base (1+ base)) unless (string= s "11") collect (list base s))) nil) (defparameter *english-number-names* '("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen" "twenty" "twenty-one" "twenty-two" "twenty-three" "twenty-four" "twenty-five" "twenty-six" "twenty-seven" "twenty-eight" "twenty-nine" "thirty" "thirty-one" "thirty-two" "thirty-three" "thirty-four" "thirty-five" "thirty-six" "thirty-seven" "thirty-eight" "thirty-nine" "forty" "forty-one" "forty-two" "forty-three" "forty-four" "forty-five" "forty-six" "forty-seven" "forty-eight" "forty-nine" "fifty" "fifty-one" "fifty-two" "fifty-three" "fifty-four" "fifty-five" "fifty-six" "fifty-seven" "fifty-eight" "fifty-nine" "sixty" "sixty-one" "sixty-two" "sixty-three" "sixty-four" "sixty-five" "sixty-six" "sixty-seven" "sixty-eight" "sixty-nine" "seventy" "seventy-one" "seventy-two" "seventy-three" "seventy-four" "seventy-five" "seventy-six" "seventy-seven" "seventy-eight" "seventy-nine" "eighty" "eighty-one" "eighty-two" "eighty-three" "eighty-four" "eighty-five" "eighty-six" "eighty-seven" "eighty-eight" "eighty-nine" "ninety" "ninety-one" "ninety-two" "ninety-three" "ninety-four" "ninety-five" "ninety-six" "ninety-seven" "ninety-eight" "ninety-nine" "one hundred")) (deftest format.r.7 (loop for i from 0 to 100 for s1 = (format nil "~r" i) for s2 in *english-number-names* unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.7 (let ((fn (formatter "~r"))) (loop for i from 0 to 100 for s1 = (formatter-call-to-string fn i) for s2 in *english-number-names* unless (string= s1 s2) collect (list i s1 s2))) nil) (deftest format.r.7a (loop for i from 1 to 100 for s1 = (format nil "~r" (- i)) for s2 in (cdr *english-number-names*) for s3 = (concatenate 'string "negative " s2) for s4 = (concatenate 'string "minus " s2) unless (or (string= s1 s3) (string= s1 s4)) collect (list i s1 s3 s4)) nil) (def-format-test format.r.8 "~vr" (nil 5) "five") (def-format-test format.r.9 "~#r" (4 nil nil) "11" 2) (deftest format.r.10 (with-standard-io-syntax (let ((*print-radix* t)) (format nil "~10r" 123))) "123") (deftest formatter.r.10 (let ((fn (formatter "~10r"))) (with-standard-io-syntax (let ((*print-radix* t)) (values (format nil fn 123) (formatter-call-to-string fn 123))))) "123" "123") (def-format-test format.r.11 "~8@R" (65) "+101") (def-format-test format.r.12 "~2:r" (126) "1,111,110") (def-format-test format.r.13 "~3@:r" (#3r2120012102) "+2,120,012,102") (deftest format.r.14 (loop for i from 2 to 36 for s = (format nil "~~~d:R" i) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (remove #\, (format nil s x)) for y = (let ((*read-base* i)) (read-from-string s1)) repeat 100 unless (= x y) collect (list i x s1 y))) nil) (deftest format.r.15 (loop for i = (+ 2 (random 35)) for interval = (1+ (random 20)) for comma = (loop for c = (random-from-seq +standard-chars+) unless (alphanumericp c) return c) for s = (format nil "~~~d,,,'~c,~d:R" i comma interval) for x = (let ((bound (ash 1 (+ 2 (random 40))))) (- (random (* bound 2)) bound)) for s1 = (remove comma (format nil s x)) for y = (let ((*read-base* i)) (read-from-string s1)) repeat 1000 unless (or (and (eql comma #\-) (< x 0)) (= x y)) collect (list i interval comma x s1 y)) nil) (def-format-test format.r.16 "~2,,,,1000000000000000000r" (17) "10001") (def-format-test format.r.17 "~8,10:@r" (#o526104) " +526,104") (defparameter *english-ordinal-names* '("zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth" "twentieth" "twenty-first" "twenty-second" "twenty-third" "twenty-fourth" "twenty-fifth" "twenty-sixth" "twenty-seventh" "twenty-eighth" "twenty-ninth" "thirtieth" "thirty-first" "thirty-second" "thirty-third" "thirty-fourth" "thirty-fifth" "thirty-sixth" "thirty-seventh" "thirty-eighth" "thirty-ninth" "fortieth" "forty-first" "forty-second" "forty-third" "forty-fourth" "forty-fifth" "forty-sixth" "forty-seventh" "forty-eighth" "forty-ninth" "fiftieth" "fifty-first" "fifty-second" "fifty-third" "fifty-fourth" "fifty-fifth" "fifty-sixth" "fifty-seventh" "fifty-eighth" "fifty-ninth" "sixtieth" "sixty-first" "sixty-second" "sixty-third" "sixty-fourth" "sixty-fifth" "sixty-sixth" "sixty-seventh" "sixty-eighth" "sixty-ninth" "seventieth" "seventy-first" "seventy-second" "seventy-third" "seventy-fourth" "seventy-fifth" "seventy-sixth" "seventy-seventh" "seventy-eighth" "seventy-ninth" "eightieth" "eighty-first" "eighty-second" "eighty-third" "eighty-fourth" "eighty-fifth" "eighty-sixth" "eighty-seventh" "eighty-eighth" "eighty-ninth" "ninetieth" "ninety-first" "ninety-second" "ninety-third" "ninety-fourth" "ninety-fifth" "ninety-sixth" "ninety-seventh" "ninety-eighth" "ninety-ninth" "one hundredth")) (deftest format.r.18 (loop for i from 0 to 100 for s1 = (format nil "~:r" i) for s2 in *english-ordinal-names* unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.18 (let ((fn (formatter "~:r"))) (loop for i from 0 to 100 for s1 = (formatter-call-to-string fn i) for s2 in *english-ordinal-names* unless (string= s1 s2) collect (list i s1 s2))) nil) (deftest format.r.18a (loop for i from 1 to 100 for s1 = (format nil "~:r" (- i)) for s2 in (cdr *english-ordinal-names*) for s3 = (concatenate 'string "negative " s2) for s4 = (concatenate 'string "minus " s2) unless (or (string= s1 s3) (string= s1 s4)) collect (list i s1 s3 s4)) nil) (deftest format.r.19 (loop for i from 1 for s1 in *roman-numerals* for s2 = (format nil "~@R" i) unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.19 (let ((fn (formatter "~@r"))) (loop for i from 1 for s1 in *roman-numerals* for s2 = (formatter-call-to-string fn i) unless (string= s1 s2) collect (list i s1 s2))) nil) ;;; Old roman numerals (defun old-roman-numeral (x) (assert (typep x '(integer 1))) (let ((n-m 0) (n-d 0) (n-c 0) (n-l 0) (n-x 0) (n-v 0) ) (loop while (>= x 1000) do (incf n-m) (decf x 1000)) (when (>= x 500) (incf n-d) (decf x 500)) (loop while (>= x 100) do (incf n-c) (decf x 100)) (when (>= x 50) (incf n-l) (decf x 50)) (loop while (>= x 10) do (incf n-x) (decf x 10)) (when (>= x 5) (incf n-v) (decf x 5)) (concatenate 'string (make-string n-m :initial-element #\M) (make-string n-d :initial-element #\D) (make-string n-c :initial-element #\C) (make-string n-l :initial-element #\L) (make-string n-x :initial-element #\X) (make-string n-v :initial-element #\V) (make-string x :initial-element #\I)))) (deftest format.r.20 (loop for i from 1 to 4999 for s1 = (format nil "~:@r" i) for s2 = (old-roman-numeral i) unless (string= s1 s2) collect (list i s1 s2)) nil) (deftest formatter.r.20 (let ((fn (formatter "~@:R"))) (loop for i from 1 to 4999 for s1 = (formatter-call-to-string fn i) for s2 = (old-roman-numeral i) unless (string= s1 s2) collect (list i s1 s2))) nil) (deftest format.r.21 (loop for i from 1 to 4999 for s1 = (format nil "~:@r" i) for s2 = (format nil "~@:R" i) unless (string= s1 s2) collect (list i s1 s2)) nil) ;; Combinations of mincol and comma chars (def-format-test format.r.22 "~2,12,,'*:r" (#b1011101) " 1*011*101") (def-format-test format.r.23 "~3,14,'X,',:R" (#3r1021101) "XXXXX1,021,101") ;; v directive in various positions (def-format-test format.r.24 "~10,vr" (nil 12345) "12345") (deftest format.r.25 (loop for i from 0 to 5 for s = (format nil "~10,vr" i 12345) unless (string= s "12345") collect (list i s)) nil) (deftest formatter.r.25 (let ((fn (formatter "~10,vr"))) (loop for i from 0 to 5 for s = (formatter-call-to-string fn i 12345) unless (string= s "12345") collect (list i s))) nil) (def-format-test format.r.26 "~10,#r" (12345 nil nil nil nil nil) " 12345" 5) (def-format-test format.r.27 "~10,12,vr" (#\/ 123456789) "///123456789") (def-format-test format.r.28 "~10,,,v:r" (#\/ 123456789) "123/456/789") (def-format-test format.r.29 "~10,,,v:r" (nil 123456789) "123,456,789") (def-format-test format.r.30 "~8,,,,v:R" (nil #o12345670) "12,345,670") (def-format-test format.r.31 "~8,,,,v:R" (2 #o12345670) "12,34,56,70") (def-format-test format.r.32 "~16,,,,#:r" (#x12345670 nil nil nil) "1234,5670" 3) (def-format-test format.r.33 "~16,,,,1:r" (#x12345670) "1,2,3,4,5,6,7,0") ;;; Explicit signs (def-format-test format.r.34 "~+10r" (12345) "12345") (def-format-test format.r.35 "~10,+8r" (12345) " 12345") (def-format-test format.r.36 "~10,0r" (12345) "12345") (def-format-test format.r.37 "~10,-1r" (12345) "12345") (def-format-test format.r.38 "~10,-1000000000000000r" (12345) "12345") ;;; Randomized test (deftest format.r.39 (let ((fn (formatter "~v,v,v,v,vr"))) (loop for radix = (+ 2 (random 35)) for mincol = (and (coin) (random 50)) for padchar = (and (coin) (random-from-seq +standard-chars+)) for commachar = (and (coin) (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate 'string (format nil "~~~d," radix) (if mincol (format nil "~d," mincol) ",") (if padchar (format nil "'~c," padchar) ",") (if commachar (format nil "'~c," commachar) ",") (if commaint (format nil "~dr" commaint) "r")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,v,vr" radix mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn radix mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s1 s3)) collect (list radix mincol padchar commachar commaint fmt x s1 s2 s3))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/defgeneric-method-combination-aux.lsp0000644000000000000000000000013214542551762022635 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.797790524 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defgeneric-method-combination-aux.lsp0000644000175000017500000000077614542551762022245 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed May 28 14:02:42 2003 ;;;; Contains: Class definitions for defgeneric-method-combination-*.lsp (in-package :cl-test) (defclass dgmc-class-01 () ()) (defclass dgmc-class-02 (dgmc-class-01) ()) (defclass dgmc-class-03 (dgmc-class-01) ()) (defclass dgmc-class-04 (dgmc-class-02 dgmc-class-03) ()) (defclass dgmc-class-05 (dgmc-class-04) ()) (defclass dgmc-class-06 (dgmc-class-04) ()) (defclass dgmc-class-07 (dgmc-class-05 dgmc-class-06) ()) gcl-2.7.1/ansi-tests/PaxHeaders/data-and-control-flow.lsp0000644000000000000000000000013214542551762020265 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.797790524 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/data-and-control-flow.lsp0000644000175000017500000000165514542551762017672 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/simple-array.lsp0000644000000000000000000000013214542551763016577 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.801790542 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-array.lsp0000644000175000017500000001445214542551763016203 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/formatter-c.lsp0000644000000000000000000000013214542551762016414 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.801790542 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/formatter-c.lsp0000644000175000017500000000752414542551762016022 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 5 14:32:46 2004 ;;;; Contains: Tests of FORMATTER on the C directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest formatter.c.1 (let ((fn (formatter "~C"))) (loop for c across +standard-chars+ when (let* (n (ignored (loop for i below (random 5) collect i)) (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (list s ignored n))) collect it)) nil) (deftest formatter.c.1a (let ((fn (formatter "~c"))) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for ignored = (loop for j below (random 10) collect j) when (and c (eql (char-code c) (char-int c)) (let* (n (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (incf count) (list i c s ignored n)))) collect it when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest formatter.c.2 (let ((fn (formatter "~:C"))) (loop for c across +standard-chars+ when (and (graphic-char-p c) (not (eql c #\Space)) (let* (n (ignored (loop for i below (random 5) collect i)) (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (list s ignored n)))) collect it)) nil) (deftest formatter.c.2a (let ((fn (formatter "~:C"))) (loop with count = 0 for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for ignored = (loop for j below (random 10) collect j) when (and c (eql (char-code c) (char-int c)) (graphic-char-p c) (not (eql c #\Space)) (let* (n (s (with-output-to-string (stream) (setq n (multiple-value-list (apply fn stream c ignored)))))) (unless (and (string= s (string c)) (equal n (list ignored))) (incf count) (list i c s ignored n)))) collect it when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest formatter.c.4 (let ((fn (formatter "~:C")) (n nil)) (loop for c across +standard-chars+ for s = (with-output-to-string (stream) (setq n (multiple-value-list (funcall fn stream c)))) unless (or (graphic-char-p c) (and (string= s (char-name c)) (equal n '(nil)))) collect (list c (char-name c) s))) nil) (deftest formatter.c.4a (let ((fn (formatter "~:C")) (n nil)) (loop for i from 0 below (min #x10000 char-code-limit) for c = (code-char i) for s = (and c (with-output-to-string (stream) (setq n (multiple-value-list (funcall fn stream c 5))))) unless (or (not c) (graphic-char-p c) (and (string= s (char-name c)) (equal n '((5))))) collect (list c (char-name c) s))) nil) (deftest formatter.c.5 (let ((fn (formatter "~@C")) (n nil)) (loop for c across +standard-chars+ for s = (with-output-to-string (stream) (setq n (multiple-value-list (funcall fn stream c 1 2 3)))) for c2 = (read-from-string s) unless (and (eql c c2) (equal n '((1 2 3)))) collect (list c s c2))) nil) (deftest formatter.c.6 (let ((n nil) (fn (formatter "~@:c"))) (loop for c across +standard-chars+ for s1 = (with-output-to-string (stream) (setf n (multiple-value-list (funcall fn stream c 1 2)))) for s2 = (format nil "~:@C" c) unless (and (eql (search s1 s2) 0) (equal n '((1 2)))) collect (list c s1 s2 n))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/print-strings.lsp0000644000000000000000000000013114542551763017014 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.801790542 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-strings.lsp0000644000175000017500000000770514542551763016424 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 19 05:53:48 2004 ;;;; Contains: Tests of string printing (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest print.string.1 (with-standard-io-syntax (write-to-string "" :escape nil :readably nil)) "") (deftest print.string.2 (with-standard-io-syntax (loop for c across +standard-chars+ for s1 = (string c) for s2 = (write-to-string s1 :escape nil :readably nil) unless (string= s1 s2) collect (list c s1 s2))) nil) (deftest print.string.3 (with-standard-io-syntax (loop for i below 256 for c = (code-char i) when c nconc (let* ((s1 (string c)) (s2 (write-to-string s1 :escape nil :readably nil))) (unless (string= s1 s2) (list (list c s1 s2)))))) nil) (deftest print.string.4 (with-standard-io-syntax (loop for c across +standard-chars+ for s1 = (string c) for s2 = (write-to-string s1 :escape t :readably nil) unless (or (find c "\"\\") (string= (concatenate 'string "\"" s1 "\"") s2)) collect (list c s1 s2))) nil) (deftest print.string.5 (with-standard-io-syntax (write-to-string "\"" :escape t :readably nil)) "\"\\\"\"") (deftest print.string.6 (with-standard-io-syntax (write-to-string "\\" :escape t :readably nil)) "\"\\\\\"") ;;; Not affected by *print-array* (deftest print.string.7 (with-standard-io-syntax (loop for s1 in (remove-if-not #'stringp *universe*) for s2 = (write-to-string s1 :escape nil :readably nil) for s3 = (write-to-string s1 :array t :escape nil :readably nil) unless (string= s2 s3) collect (list s1 s2 s3))) nil) (deftest print.string.8 (with-standard-io-syntax (loop for s1 in (remove-if-not #'stringp *universe*) for s2 = (write-to-string s1 :escape t :readably nil) for s3 = (write-to-string s1 :array t :escape t :readably nil) unless (string= s2 s3) collect (list s1 s2 s3))) nil) ;;; Only active elements of the string are printed (deftest print.string.9 (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character :initial-contents "abcdefghij")) (result (with-standard-io-syntax (write-to-string s :escape nil :readably nil)))) (or (and (string= result "abcde") t) result)) t) (deftest print.string.10 (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character :initial-contents "aBcDefGHij")) (result (with-standard-io-syntax (write-to-string s :escape t :readably nil)))) (or (and (string= result "\"aBcDe\"") t) result)) t) (deftest print.string.11 (let* ((s (make-array '(8) :element-type 'base-char :initial-contents "abcdefgh" :adjustable t)) (result (with-standard-io-syntax (write-to-string s :escape t :readably nil)))) (or (and (string= result "\"abcdefgh\"") t) result)) t) (deftest print.string.12 (let* ((s1 (make-array '(8) :element-type 'character :initial-contents "abcdefgh")) (s2 (make-array '(4) :element-type 'character :displaced-to s1 :displaced-index-offset 2)) (result (with-standard-io-syntax (write-to-string s2 :escape t :readably nil)))) (or (and (string= result "\"cdef\"") t) result)) t) ;;; *print-array* should not affect string printing (deftest print.string.13 (with-standard-io-syntax (write-to-string "1234" :array nil :readably nil :escape t)) "\"1234\"") ;;; The ever-popular nil string (deftest print.string.nil.1 :notes (:nil-vectors-are-strings) (let ((s (make-array '(0) :element-type nil))) (write-to-string s :escape nil :readably nil)) "") (deftest print.string.nil.2 :notes (:nil-vectors-are-strings) (let ((s (make-array '(0) :element-type nil))) (write-to-string s :escape t :readably nil)) "\"\"") ;;; Random tests (deftest print.string.random.1 (trim-list (loop for len = (1+ (random 5)) for s = (coerce (loop repeat len collect (random-from-seq +standard-chars+)) 'string) repeat 1000 append (randomly-check-readability s)) 10) nil) gcl-2.7.1/ansi-tests/PaxHeaders/subtypep-member.lsp0000644000000000000000000000013114542551763017311 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.801790542 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-member.lsp0000644000175000017500000001362714542551763016721 0ustar00cammcamm;-*- 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) (compile-and-load "types-aux.lsp") ;;; 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) (deftest subtypep.member.45 (check-all-subtypep `(member #c(1 6)) `(complex (or (integer 1 2) (integer 5 6)))) nil) (deftest subtypep.member.46 (check-all-not-subtypep `(member #c(1 6)) `(or (complex (integer 1 2)) (complex (integer 5 6)))) nil) (deftest subtypep.member.47 (check-all-subtypep `(member #c(1 3/2)) `(complex (rational 1 3/2))) nil) (deftest subtypep.member.48 (check-all-not-subtypep `(member #c(1 3/2)) `(complex (rational (1) 3/2))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/nsubstitute.lsp0000644000000000000000000000013114542551763016562 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.801790542 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nsubstitute.lsp0000644000175000017500000007116314542551763016171 0ustar00cammcamm;-*- 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) (defharmless nsubstitute.test-and-test-not.1 (nsubstitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.2 (nsubstitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless nsubstitute.test-and-test-not.3 (nsubstitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.4 (nsubstitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) (defharmless nsubstitute.test-and-test-not.5 (nsubstitute #\b #\a (copy-seq "abcdab") :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.6 (nsubstitute #\b #\a (copy-seq "abcdab") :test-not #'eql :test #'eql)) (defharmless nsubstitute.test-and-test-not.7 (nsubstitute 1 0 (copy-seq #*001101001) :test #'eql :test-not #'eql)) (defharmless nsubstitute.test-and-test-not.8 (nsubstitute 0 1 (copy-seq #*1100110101) :test-not #'eql :test #'eql)) ;;;; 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-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute 'x 'c v2 :count 1) v1)) #(d a b x d a b c) #(a b c d a b x d a b c d a b c d)) (deftest nsubstitute-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) (v2 (make-array '(8) :displaced-to v1 :displaced-index-offset 3))) (values (nsubstitute 'x 'c v2 :count 1 :from-end t) v1)) #(d a b c d a b x) #(a b c d a b c d a b x d a b c d)) (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-string.32 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute #\! #\a s) "xyz!bcxyz!bc")) (assert (string= s "xyz!bcxyz!bc"))) nil) (deftest nsubstitute-string.33 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute #\! #\a s :count 1) "xyz!bcxyzabc")) (assert (string= s "xyz!bcxyzabc"))) nil) (deftest nsubstitute-string.34 (do-special-strings (s "xyzabcxyzabc" nil) (assert (string= (nsubstitute #\! #\a s :count 1 :from-end t) "xyzabcxyz!bc")) (assert (string= s "xyzabcxyz!bc"))) nil) ;;; More bit vector tests (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 (signals-error (nsubstitute) program-error) t) (deftest nsubstitute.error.2 (signals-error (nsubstitute 'a) program-error) t) (deftest nsubstitute.error.3 (signals-error (nsubstitute 'a 'b) program-error) t) (deftest nsubstitute.error.4 (signals-error (nsubstitute 'a 'b nil 'bad t) program-error) t) (deftest nsubstitute.error.5 (signals-error (nsubstitute 'a 'b nil 'bad t :allow-other-keys nil) program-error) t) (deftest nsubstitute.error.6 (signals-error (nsubstitute 'a 'b nil :key) program-error) t) (deftest nsubstitute.error.7 (signals-error (nsubstitute 'a 'b nil 1 2) program-error) t) (deftest nsubstitute.error.8 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :test #'identity) program-error) t) (deftest nsubstitute.error.9 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :test-not #'identity) program-error) t) (deftest nsubstitute.error.10 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'cons) program-error) t) (deftest nsubstitute.error.11 (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'car) type-error) t) (deftest nsubstitute.error.12 (check-type-error #'(lambda (x) (nsubstitute 1 0 x)) #'sequencep) nil) gcl-2.7.1/ansi-tests/PaxHeaders/make-string-input-stream.lsp0000644000000000000000000000013214542551763021041 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.801790542 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-string-input-stream.lsp0000644000175000017500000000510614542551763020441 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/subtypep-real.lsp0000644000000000000000000000013114542551763016765 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.801790542 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/subtypep-real.lsp0000644000175000017500000001055214542551763016367 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 18 18:38:55 2003 ;;;; Contains: Tests of SUBTYPEP on REAL types. (in-package :cl-test) (compile-and-load "types-aux.lsp") ;;; 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) (deftest subtypep.real.25 (check-all-subtypep t '(or (not (real 0 10)) (not (real -100 -50)))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/simple-array-t.lsp0000644000000000000000000000013214542551763017040 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.801790542 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-array-t.lsp0000644000175000017500000001263414542551763016444 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/places.lsp0000644000000000000000000000013114542551763015440 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.801790542 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/places.lsp0000644000175000017500000001377714542551763015056 0ustar00cammcamm;-*- 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.1 (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 incf.order.1 (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.1 (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) ;;; 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 setq.5 (let ((*x* 0)) (declare (special *x*)) (values *x* (setq *x* 1) *x*)) 0 1 1) (deftest setq.6 (let ((*x* 0)) (declare (special *x*)) (setq *x* 1)) 1) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest setq.7 (macrolet ((%m (z) z)) (let ((x nil)) (values (setq x (expand-in-current-env (%m :good))) x))) :good :good) ;;; Tests of SETF (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) (deftest setf.5 (let ((*x* 0)) (declare (special *x*)) (values *x* (setf *x* 1) *x*)) 0 1 1) (deftest setf.6 (let ((*x* 0)) (declare (special *x*)) (setf *x* 1)) 1) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest setf.7 (macrolet ((%m (z) z)) (let ((x nil)) (values x (setf (expand-in-current-env (%m x)) t) x))) nil t t) (deftest setf.8 (macrolet ((%m (z) z)) (let ((x nil)) (values x (setf x (expand-in-current-env (%m t))) x))) nil t t) gcl-2.7.1/ansi-tests/PaxHeaders/simple-vector-p.lsp0000644000000000000000000000013214542551763017220 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.801790542 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-vector-p.lsp0000644000175000017500000000272214542551763016621 0ustar00cammcamm;-*- 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 (check-type-predicate #'simple-vector-p 'simple-vector) 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 (signals-error (simple-vector-p) program-error) t) (deftest simple-vector-p.error.2 (signals-error (simple-vector-p #(a b) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/format-page.lsp0000644000000000000000000000013214542551762016373 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.801790542 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-page.lsp0000644000175000017500000000205114542551762015767 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 28 00:20:46 2004 ;;;; Contains: Tests of format with ~| directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-format-test format.page.1 "~0|" nil "") (deftest format.page.2 (let ((s (format nil "~|"))) (cond ((string= s "") nil) ((> (length s) 1) (values s :too-long)) (t (let ((c (elt s 0))) (loop for i from 2 to 100 for s = (format nil (format nil "~~~D|" i)) unless (and (= (length s) i) (every #'(lambda (c2) (char= c c2)) s)) collect i))))) nil) (deftest format.page.3 (let ((s (format nil "~|"))) (cond ((string= s "") nil) ((> (length s) 1) (values s :too-long)) (t (let ((c (elt s 0))) (loop for i from 2 to 100 for s = (format nil "~v|" i) unless (and (= (length s) i) (every #'(lambda (c2) (char= c c2)) s)) collect i))))) nil) (def-format-test format.page.4 "~V|" (0) "") (def-format-test format.page.5 "~v|" (nil) #.(format nil "~|")) gcl-2.7.1/ansi-tests/PaxHeaders/make-synonym-stream.lsp0000644000000000000000000000013214542551763020112 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.801790542 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-synonym-stream.lsp0000644000175000017500000000513414542551763017513 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/packages-01.lsp0000644000000000000000000000013114542551763016165 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.805790559 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages-01.lsp0000644000175000017500000000365214542551763015572 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/sin.lsp0000644000000000000000000000013214542551763014763 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.805790559 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/sin.lsp0000644000175000017500000000637314542551763014372 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 9 20:20:46 2004 ;;;; Contains: Tests for SIN (in-package :cl-test) (deftest sin.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (sin i)) for y = (car rlist) always (and (null (cdr rlist)) (<= -1 y 1) (or (rationalp y) (typep y 'single-float)))) t) (deftest sin.2 (loop for x = (- (random 2000.0s0) 1000.0s0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'short-float))) t) (deftest sin.3 (loop for x = (- (random 2000.0f0) 1000.0f0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'single-float))) t) (deftest sin.4 (loop for x = (- (random 2000.0d0) 1000.0d0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'double-float))) t) (deftest sin.5 (loop for x = (- (random 2000.0l0) 1000.0l0) for rlist = (multiple-value-list (sin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (<= -1 y 1) (typep y 'long-float))) t) (deftest sin.6 (let ((r (sin 0))) (or (eqlt r 0) (eqlt r 0.0))) t) (deftest sin.7 (sin 0.0s0) 0.0s0) (deftest sin.8 (sin 0.0) 0.0) (deftest sin.9 (sin 0.0d0) 0.0d0) (deftest sin.10 (sin 0.0l0) 0.0l0) (deftest sin.11 (loop for i from 1 to 100 unless (approx= (sin i) (sin (coerce i 'single-float))) collect i) nil) (deftest sin.12 (approx= (sin (coerce (/ pi 2) 'single-float)) 1.0) t) (deftest sin.13 (approx= (sin (coerce (/ pi -2) 'single-float)) -1.0) t) (deftest sin.14 (approx= (sin (coerce (/ pi 2) 'short-float)) 1.0s0) t) (deftest sin.15 (approx= (sin (coerce (/ pi -2) 'short-float)) -1.0s0) t) (deftest sin.16 (approx= (sin (coerce (/ pi 2) 'double-float)) 1.0d0) t) (deftest sin.17 (approx= (sin (coerce (/ pi -2) 'double-float)) -1.0d0) t) (deftest sin.18 (approx= (sin (coerce (/ pi 2) 'long-float)) 1.0l0) t) (deftest sin.19 (approx= (sin (coerce (/ pi -2) 'long-float)) -1.0l0) t) (deftest sin.20 (loop for r = (- (random 2000) 1000) for i = (- (random 20) 10) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.21 (loop for r = (- (random 2000.0s0) 1000.0s0) for i = (- (random 20.0s0) 10.0s0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.22 (loop for r = (- (random 2000.0f0) 1000.0f0) for i = (- (random 20.0f0) 10.0f0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.23 (loop for r = (- (random 2000.0d0) 1000.0d0) for i = (- (random 20.0d0) 10.0d0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) (deftest sin.24 (loop for r = (- (random 2000.0l0) 1000.0l0) for i = (- (random 20.0l0) 10.0l0) for y = (sin (complex r i)) repeat 1000 always (numberp y)) t) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest sin.error.1 (signals-error (sin) program-error) t) (deftest sin.error.2 (signals-error (sin 0.0 0.0) program-error) t) (deftest sin.error.3 (check-type-error #'sin #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/print-backquote.lsp0000644000000000000000000000013114542551763017301 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.805790559 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/print-backquote.lsp0000644000175000017500000000625414542551763016707 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jun 10 19:31:01 2004 ;;;; Contains: Tests of printing of backquote forms (and fragments thereof) (in-package :cl-test) (compile-and-load "printer-aux.lsp") (compile-and-load "backquote-aux.lsp") (deftest print.backquote.random.1 (let* ((x '`(a ,b ,@c (d . ,e) ,.f #(1 2 ,p ,@q ,.r s) g)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (equal x y)) (list :modified x y)))) nil) (deftest print.backquote.random.2 (let* ((x '`(,@a ,@b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.3 (let* ((x '`(,.a ,.b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.4 (let* ((x '`(,a ,b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.5 (let* ((x '`#(,a ,b)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability y :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.6 (let ((x '`(,@a ,@b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.7 (let ((x '`(,.a ,.b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.8 (let ((x '`(,a ,b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.9 (let ((x '`#(,a ,b))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.10 (let ((x '`#(,a , .b))) (loop repeat 20 nconc (randomly-check-readability x :test #'is-similar))) nil) (deftest print.backquote.random.11 (let ((x '`#(,a , @b))) (loop repeat 20 nconc (randomly-check-readability x :test #'is-similar))) nil) (deftest print.backquote.random.12 (let ((x '`#(,a ,b c))) (and (consp x) (symbolp (car x)) (loop repeat 20 nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.13 (let* ((x '`#(,a ,b c)) (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability x :test #'is-similar)) (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.14 (loop for x = (make-random-backquoted-form 100) repeat 500 nconc (randomly-check-readability x :test #'is-similar)) nil)gcl-2.7.1/ansi-tests/PaxHeaders/vector-pop.lsp0000644000000000000000000000013214542551763016270 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.805790559 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/vector-pop.lsp0000644000175000017500000000201414542551763015663 0ustar00cammcamm;-*- 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 (signals-error (let ((v (vector 1 2 3))) (if (array-has-fill-pointer-p v) (error 'type-error :datum v :expected-type nil) (vector-pop v))) type-error) t) (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 (signals-error (vector-pop) program-error) t) (deftest vector-pop.error.4 (signals-error (let ((v (make-array '(5) :fill-pointer t :initial-element 'x))) (vector-pop v nil)) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-hash-table.lsp0000644000000000000000000000013214542551763017115 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.805790559 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-hash-table.lsp0000644000175000017500000001374614542551763016526 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 21:36:33 2003 ;;;; Contains: Tests for MAKE-HASH-TABLE (in-package :cl-test) ;; (eval-when (:load-toplevel :compile-toplevel :execute) ;; (compile-and-load "hash-table-aux.lsp")) (deftest make-hash-table.1 (let ((ht (make-hash-table))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.2 (let ((ht (make-hash-table :size 0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.3 (let ((ht (make-hash-table :size 100))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.4 (let ((ht (make-hash-table :test #'eq))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.5 (let ((ht (make-hash-table :test 'eq))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.6 (let ((ht (make-hash-table :test #'eql))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.7 (let ((ht (make-hash-table :test 'eql))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.8 (let ((ht (make-hash-table :test #'equal))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.9 (let ((ht (make-hash-table :test 'equal))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.10 (let ((ht (make-hash-table :test #'equalp))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.11 (let ((ht (make-hash-table :test 'equalp))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.12 (let ((ht (make-hash-table :rehash-size 1))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.13 (let ((ht (make-hash-table :rehash-size 1000))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.14 (let ((ht (make-hash-table :rehash-size (+ 1.0f0 single-float-epsilon)))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.15 (let ((ht (make-hash-table :rehash-size 2.0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.16 (let ((ht (make-hash-table :rehash-threshold 0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.17 (let ((ht (make-hash-table :rehash-threshold 0.0s0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.18 (let ((ht (make-hash-table :rehash-threshold 0.0f0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.19 (let ((ht (make-hash-table :rehash-threshold 0.0d0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.20 (let ((ht (make-hash-table :rehash-threshold 0.0l0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.21 (let ((ht (make-hash-table :rehash-threshold 1/2))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.22 (let ((ht (make-hash-table :rehash-threshold 0.1s0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.23 (let ((ht (make-hash-table :rehash-threshold 0.2f0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.24 (let ((ht (make-hash-table :rehash-threshold 0.8d0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.25 (let ((ht (make-hash-table :rehash-threshold 0.99f0))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.26 (let ((ht (make-hash-table :rehash-threshold least-positive-short-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.27 (let ((ht (make-hash-table :rehash-threshold least-positive-single-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.28 (let ((ht (make-hash-table :rehash-threshold least-positive-double-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) (deftest make-hash-table.29 (let ((ht (make-hash-table :rehash-threshold least-positive-long-float))) (values (notnot (typep ht 'hash-table)) (notnot (hash-table-p ht)) (hash-table-count ht))) t t 0) gcl-2.7.1/ansi-tests/PaxHeaders/prin1-to-string.lsp0000644000000000000000000000013114542551763017146 xustar0030 mtime=1703597043.016022451 30 atime=1744294960.805790559 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/prin1-to-string.lsp0000644000175000017500000000104214542551763016542 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jul 26 12:18:22 2004 ;;;; Contains: Tests of PRIN1-TO-STRING (in-package :cl-test) (compile-and-load "printer-aux.lsp") (deftest prin1-to-string.1 (random-prin1-to-string-test 5) nil) (deftest prin1-to-string.2 (with-standard-io-syntax (prin1-to-string 2)) "2") ;;; Error tests (deftest prin1-to-string.error.1 (signals-error (prin1-to-string) program-error) t) (deftest prin1-to-string.error.2 (signals-error (prin1-to-string nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/integer-length.lsp0000644000000000000000000000013114542551762017104 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.805790559 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/integer-length.lsp0000644000175000017500000000256714542551762016515 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 10:10:10 2003 ;;;; Contains: Tests for INTEGER-LENGTH (in-package :cl-test) (deftest integer-length.error.1 (signals-error (integer-length) program-error) t) (deftest integer-length.error.2 (signals-error (integer-length 1 1) program-error) t) (deftest integer-length.error.3 (signals-error (integer-length 1 nil) program-error) t) (deftest integer-length.error.4 (check-type-error #'integer-length #'integerp) nil) (deftest integer-length.1 (loop for len from 0 to 100 for i = (1- (ash 1 len)) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql len len2))) t) (deftest integer-length.2 (loop for len from 0 to 100 for i = (ash 1 len) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql (1+ len) len2))) t) (deftest integer-length.3 (loop for len from 0 to 100 for i = (- (ash 1 len)) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql len len2))) t) (deftest integer-length.4 (loop for len from 0 to 100 for i = (- -1 (ash 1 len)) for vals = (multiple-value-list (integer-length i)) for len2 = (car vals) always (and (= (length vals) 1) (eql (1+ len) len2))) t) gcl-2.7.1/ansi-tests/PaxHeaders/ansi-aux-macros.lsp0000644000000000000000000000013214542551762017200 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.805790559 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ansi-aux-macros.lsp0000644000175000017500000000242014542551762016574 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jul 2 07:05:41 2003 ;;;; Contains: Macros used in ansi-aux and elsewhere. (in-package :cl-test) (declaim (optimize (safety 3))) ;;; Macros to avoid annoying sbcl warning notes (defmacro handler-case (form &rest cases) `(let () (cl:handler-case ,form ,@cases))) (defmacro handler-bind (handlers &rest body) `(let () (cl:handler-bind ,handlers (normally (progn ,@body))))) ;;; Macros for avoiding dead code warnings (defvar *should-always-be-true* t) (declaim (notinline should-never-be-called)) (defun should-never-be-called () nil) (defmacro normally (form &optional (default-form '(should-never-be-called))) `(if *should-always-be-true* ,form ,default-form)) ;;; Macro to ignore errors, but report them anyway (defparameter *report-and-ignore-errors-break* nil "When true, REPORT-AND-IGNORE-ERRORS breaks instead of discarding the error condition.") (defmacro report-and-ignore-errors (&body body) `(eval-when (:load-toplevel :compile-toplevel :execute) (#+sbcl let #+sbcl () #-sbcl progn (handler-case (progn ,@body) (error (condition) (princ condition) (terpri) (when *report-and-ignore-errors-break* (break)) (values nil condition)))))) gcl-2.7.1/ansi-tests/PaxHeaders/dispatch-macro-characters.lsp0000644000000000000000000000013214542551762021204 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.805790559 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/dispatch-macro-characters.lsp0000644000175000017500000000405714542551762020610 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 5 11:42:24 2005 ;;;; Contains: Tests of dispatch macro character functions (in-package :cl-test) (deftest make-dispatch-macro-character.1 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\!) (read-from-string "123!")))) t 123) (deftest make-dispatch-macro-character.2 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\! t) (read-from-string "123!")))) t 123!) (deftest make-dispatch-macro-character.3 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\!) (loop for c across +standard-chars+ for result = (handler-case (read-from-string (coerce (list #\! c #\X) 'string)) (reader-error (c) :good) (error (c) :bad)) unless (eql result :good) collect (list c result))))) t nil) (deftest make-dispatch-macro-character.4 (with-standard-io-syntax (let* ((rt (copy-readtable nil)) (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\! t rt) (read-from-string "!") (let ((*readtable* rt)) (read-from-string "123!"))))) t ! 123!) (deftest make-dispatch-macro-character.error.1 (let ((*readtable* (copy-readtable nil))) (signals-error (make-dispatch-macro-character) program-error)) t) (deftest make-dispatch-macro-character.error.2 (let ((*readtable* (copy-readtable nil))) (signals-error (make-dispatch-macro-character #\! t *readtable* nil) program-error)) t) ;;; GET-DISPATCH-MACRO-CHARACTER (deftest get-dispatch-macro-character.1 (loop for c across +standard-chars+ when (and (not (eql c #\#)) (handler-case (list (get-dispatch-macro-character c #\a) c) (error (cnd) nil))) collect it) nil) gcl-2.7.1/ansi-tests/PaxHeaders/change-class.lsp0000644000000000000000000000013014542551762016517 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.809790577 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/change-class.lsp0000644000175000017500000004416314542551762016127 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 3 14:23:29 2003 ;;;; Contains: Tests of CHANGE-CLASS (in-package :cl-test) (defclass change-class-class-01a () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (defclass change-class-class-01b () ((c :initarg :c2) (d :initarg :d2) (b :initarg :b2))) (deftest change-class.1.1 (let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)))) t nil (nil nil nil) nil t nil t nil (nil nil nil)) (deftest change-class.1.2 (let ((obj (make-instance 'change-class-class-01a :a 1)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)))) t nil (t nil nil) nil t nil t nil (nil nil nil)) (deftest change-class.1.3 (let ((obj (make-instance 'change-class-class-01a :b 2)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (slot-value obj 'b))) t nil (nil t nil) nil t nil t nil (t nil nil) 2) (deftest change-class.1.4 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (map-slot-boundp* obj '(a b c)) (slot-exists-p obj 'd) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil (t t t) nil t nil t nil (t t nil) (2 5)) (deftest change-class.1.5 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :b2 8 :c2 76)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (8 76)) (deftest change-class.1.6 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :b2 19 :b2 34)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (19 5)) (deftest change-class.1.7 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys nil)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.8 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.9 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys t :nonsense t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.10 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :bad 0 :allow-other-keys t :allow-other-keys nil :nonsense t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (2 5)) (deftest change-class.1.11 (handler-case (eval '(let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (declare (optimize (safety 3))) (eqt obj (change-class obj new-class :nonsense t)))) (error () :expected-error)) :expected-error) ;; test of class name as second argument (deftest change-class.1.12 (let ((obj (make-instance 'change-class-class-01a :b 1)) ;; (new-class (find-class 'change-class-class-01b)) ) (values (eqt obj (change-class obj 'change-class-class-01b :c2 3)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) (map-slot-boundp* obj '(b c d)) (map-slot-value obj '(b c)))) t nil t nil (t t nil) (1 3)) ;;; Shared slots (defclass change-class-class-02a () ((a :initarg :a :allocation :class) (b :initarg :b :allocation :class))) (defclass change-class-class-02b () ((a :initarg :a2) (b :initarg :b2))) (deftest change-class.2.1 (let ((obj (make-instance 'change-class-class-02a)) (new-class (find-class 'change-class-class-02b))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-02a) (typep* obj 'change-class-class-02b) (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b)) (map-slot-boundp* obj '(a b)))) (nil nil) t nil t (nil nil) (nil nil)) (deftest change-class.2.2 (let ((obj (make-instance 'change-class-class-02a)) (obj2 (make-instance 'change-class-class-02a)) obj3 (new-class (find-class 'change-class-class-02b))) (setf (slot-value obj 'a) 'foo) (slot-makunbound obj 'b) (values (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj2 'a) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-02a) (typep* obj 'change-class-class-02b) (map-slot-boundp* (setf obj3 (make-instance 'change-class-class-02a)) '(a b)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj2 'a) (slot-value obj3 'a) (eqt obj obj2) (eqt obj obj3) (eqt obj2 obj3) )) (t nil) foo foo t nil t (t nil) (t nil) foo foo foo nil nil nil) (deftest change-class.2.3 (let ((obj (make-instance 'change-class-class-02a)) (obj2 (make-instance 'change-class-class-02a)) (new-class (find-class 'change-class-class-02b))) (setf (slot-value obj 'a) 1 (slot-value obj 'b) 16) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-02a) (typep* obj 'change-class-class-02b) (map-slot-boundp* obj2 '(a b)) (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b)) (map-slot-boundp* obj '(a b)) (progn (slot-makunbound obj2 'a) (slot-makunbound obj2 'b) (map-slot-boundp* obj '(a b))))) (t t) t nil t (t t) (t t) (t t) (t t)) ;;; Destination slots are shared (defclass change-class-class-03a () ((a :initarg :a) (b :initarg :b))) (defclass change-class-class-03b () ((a :allocation :class :initarg :a2) (b :allocation :class :initarg :b2))) (deftest change-class.3.1 (let* ((obj (make-instance 'change-class-class-03a)) (new-class (find-class 'change-class-class-03b)) (obj2 (make-instance new-class)) obj3) (slot-makunbound obj2 'a) (slot-makunbound obj2 'b) (values (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-03a) (typep* obj 'change-class-class-03b) (typep* obj new-class) (eqt (setq obj3 (make-instance new-class)) obj) (map-slot-boundp* obj '(a b)) (map-slot-boundp* obj2 '(a b)) (map-slot-boundp* obj3 '(a b)) )) t nil t t nil (nil nil) (nil nil) (nil nil)) (deftest change-class.3.2 (let* ((obj (make-instance 'change-class-class-03a :a 1)) (new-class (find-class 'change-class-class-03b)) (obj2 (make-instance new-class)) obj3) (slot-makunbound obj2 'a) (setf (slot-value obj2 'b) 17) (values (map-slot-boundp* obj2 '(a b)) (eqt obj (change-class obj new-class)) (typep* obj 'change-class-class-03a) (typep* obj 'change-class-class-03b) (typep* obj new-class) (eqt (setq obj3 (make-instance new-class)) obj) (map-slot-boundp* obj '(a b)) (map-slot-boundp* obj2 '(a b)) (map-slot-boundp* obj3 '(a b)) (slot-value obj 'b) (slot-value obj2 'b) (slot-value obj3 'b) )) (nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17) ;;; Destination class has slot initforms (defclass change-class-class-04a () ((a :initarg :a) (b :initarg :b))) (defclass change-class-class-04b () ((a :initform 'x :initarg :a2) (c :initform 'y :initarg :c2))) (deftest change-class.4.1 (let ((obj (make-instance 'change-class-class-04a)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class)) (map-slot-boundp* obj '(a c)) (slot-value obj 'c))) t (nil t) y) (deftest change-class.4.2 (let ((obj (make-instance 'change-class-class-04a)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class :a2 'z)) (map-slot-value obj '(a c)))) t (z y)) (deftest change-class.4.3 (let ((obj (make-instance 'change-class-class-04a :a 'p :b 'q)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class)) (map-slot-value obj '(a c)))) t (p y)) (deftest change-class.4.4 (let ((obj (make-instance 'change-class-class-04a)) (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class :c2 'k)) (map-slot-boundp* obj '(a c)) (slot-value obj 'c))) t (nil t) k) (deftest change-class.4.5 (let* ((class (find-class 'change-class-class-04b)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a c)))) (nil nil) t (nil nil)) ;;; Custom methods for change-class (declaim (special *changed-class-on-class-05*)) (defclass change-class-class-05 () (a b c)) (report-and-ignore-errors (defmethod change-class ((obj change-class-class-05) (new-class (eql (find-class 'change-class-class-05))) &rest initargs &key &allow-other-keys) (declare (ignore initargs new-class)) (setq *changed-class-on-class-05* t) obj)) (deftest change-class.5 (let ((*changed-class-on-class-05* nil) (obj (make-instance 'change-class-class-05))) (values (eqt obj (change-class obj (find-class 'change-class-class-05))) *changed-class-on-class-05*)) t t) ;;; Method that invokes the standard method with call-next-method (defclass change-class-class-06 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (report-and-ignore-errors (defmethod change-class ((obj change-class-class-06) (new-class standard-class) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value obj 'a) 123) (call-next-method))) (deftest change-class.6.1 (let* ((class (find-class 'change-class-class-06)) (obj (make-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a) )) (nil nil nil) t (t nil nil) 123) (deftest change-class.6.2 (let* ((class (find-class 'change-class-class-06)) (obj (make-instance class :a 'bad))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a) )) (t nil nil) t (t nil nil) 123) ;;; Before method (defclass change-class-class-07 () ((a :initform 'x :initarg :a) (b :initform 'y :initarg :b) (c :initarg :c))) (defclass change-class-class-07b () ((a :initform 'aa :initarg :a) (d :initform 'dd :initarg :d))) (report-and-ignore-errors (defmethod change-class :before ((obj change-class-class-07) (new-class standard-class) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value obj 'a) 'z) obj)) (deftest change-class.7.1 (let* ((class (find-class 'change-class-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a))) (nil nil nil) t (t nil nil) z) (deftest change-class.7.2 (let* ((class (find-class 'change-class-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class :a 10)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a))) (nil nil nil) t (t nil nil) 10) (deftest change-class.7.3 (let* ((class (find-class 'change-class-class-07)) (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class :b 10)) (map-slot-boundp* obj '(a b c)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil nil) t (t t nil) z 10) (deftest change-class.7.4 (let* ((class (find-class 'change-class-class-07)) (new-class (find-class 'change-class-class-07b)) (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class)) (map-slot-boundp* obj '(a d)) (slot-value obj 'a) (slot-value obj 'd))) t (t t) z dd) (deftest change-class.7.5 (let* ((class (find-class 'change-class-class-07)) (new-class (find-class 'change-class-class-07b)) (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class :allow-other-keys nil)) (map-slot-boundp* obj '(a d)) (slot-value obj 'a) (slot-value obj 'd))) t (t t) z dd) (deftest change-class.7.6 (let* ((class (find-class 'change-class-class-07)) (new-class (find-class 'change-class-class-07b)) (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class :allow-other-keys t)) (map-slot-boundp* obj '(a d)) (slot-value obj 'a) (slot-value obj 'd))) t (t t) z dd) ;;; After method (report-and-ignore-errors (defclass change-class-class-08 () ((a :initarg :a) (b :initarg :b)))) (report-and-ignore-errors (defmethod change-class :after ((obj change-class-class-08) (class (eql (find-class 'change-class-class-08))) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (setf (slot-value obj 'a) 'z) obj)) (deftest change-class.8.1 (let* ((class (find-class 'change-class-class-08)) (obj (make-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a))) (nil nil) t (t nil) z) (deftest change-class.8.2 (let* ((class (find-class 'change-class-class-08)) (obj (make-instance class :a 1 :b 2))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (t t) t (t t) z 2) (deftest change-class.8.3 (let* ((class (find-class 'change-class-class-08)) (obj (make-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class :a 12 :b 17)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) (nil nil) t (t t) z 17) ;;; Put around method test here ;;; Put more inheritance tests here ;;; Error tests (deftest change-class.error.1 (signals-error (change-class) program-error) t) (deftest change-class.error.2 (signals-error (change-class (make-instance 'change-class-class-01a)) program-error) t) (deftest change-class.error.3 (signals-error (let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (change-class obj new-class :c2)) program-error) t) (deftest change-class.error.4 (signals-error (let ((obj (make-instance 'change-class-class-01a)) (new-class (find-class 'change-class-class-01b))) (change-class obj new-class '(nonsense) 'a)) program-error) t) ;;; According to the page for BUILT-IN-CLASS, using CHANGE-CLASS ;;; to change the class to/from a builtin class should raise a ;;; signal of type ERROR. (deftest change-class.error.5 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (change-class (make-instance 'change-class-class-01a) class) t) (error () nil))) collect e)) nil) (deftest change-class.error.6 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* for class = (class-of e) when (and (eq (class-of class) built-in-class) (handler-case (progn (change-class e (find-class 'change-class-class-01a)) t) (error () nil))) collect e)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/cl-symbol-names.lsp0000644000000000000000000000013014542551762017171 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.809790577 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cl-symbol-names.lsp0000644000175000017500000010361014542551762016572 0ustar00cammcamm;-*- 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))) (#-clisp progn #+clisp ext:without-package-lock #+clisp ("COMMON-LISP") (mapcar #'(lambda (str) (intern str pkg)) *cl-symbol-names*)))) (defparameter *cl-symbols-vector* (make-array (length *cl-symbols*) :initial-contents *cl-symbols*)) ;;; Symbols that name unary predicate that can be safely applied to any object (defparameter *cl-safe-predicates* '(arrayp atom bit-vector-p characterp compiled-function-p complexp consp floatp functionp hash-table-p keywordp listp not null numberp packagep pathnamep random-state-p rationalp readtablep realp simple-bit-vector-p simple-string-p simple-vector-p streamp stringp symbolp vectorp)) ;;; 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-string-length file-write-date fill 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 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 cl:handler-bind cl: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 ed))))) (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.7.1/ansi-tests/PaxHeaders/list-length.lsp0000644000000000000000000000013114542551762016422 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.809790577 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/list-length.lsp0000644000175000017500000000304614542551762016024 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:03:01 2003 ;;;; Contains: Tests of LIST-LENGTH (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (deftest list-length.4 (list-length (copy-tree '(a b c))) 3) ;; 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 (eval `(signals-type-error x ',x (list-length x))))) 0) (deftest list-length.error.2 (signals-error (list-length) program-error) t) (deftest list-length.error.3 (signals-error (list-length nil nil) program-error) t) (deftest list-length.error.4 (signals-error (list-length 'a) type-error) t) (deftest list-length.error.5 (signals-error (locally (list-length 'a) t) type-error) t) (deftest list-length-symbol (signals-error (list-length 'a) type-error) t) (deftest list-length-dotted-list (signals-error (list-length (copy-tree '(a b c d . e))) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ensure-directories-exist.lsp0000644000000000000000000000013214763573237021144 xustar0030 mtime=1741616799.673591244 30 atime=1744294960.809790577 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ensure-directories-exist.lsp0000644000175000017500000001155214763573237020546 0ustar00cammcamm;-*- 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 directory 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))) #+gcl(progn (mapc 'delete-file (directory "./scratch/*"))(si::rmdir "scratch")) (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.7.1/ansi-tests/PaxHeaders/logorc2.lsp0000644000000000000000000000013214542551763015541 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.809790577 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/logorc2.lsp0000644000175000017500000000333214542551763015140 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Sep 9 06:27:45 2003 ;;;; Contains: Tests of LOGORC2 (in-package :cl-test) (compile-and-load "numbers-aux.lsp") ;;; Error tests (deftest logorc2.error.1 (check-type-error #'(lambda (x) (logorc2 x 0)) #'integerp) nil) (deftest logorc2.error.2 (check-type-error #'(lambda (x) (logorc2 0 x)) #'integerp) nil) (deftest logorc2.error.3 (signals-error (logorc2) program-error) t) (deftest logorc2.error.4 (signals-error (logorc2 0) program-error) t) (deftest logorc2.error.5 (signals-error (logorc2 1 2 3) program-error) t) ;;; Non-error tests (deftest logorc2.1 (logorc2 0 0) -1) (deftest logorc2.2 (logorc2 -1 0) -1) (deftest logorc2.2a (logorc2 0 -1) 0) (deftest logorc2.3 (logorc2 0 123) -124) (deftest logorc2.4 (loop for x in *integers* always (and (eql -1 (logorc2 x 0)) (eql x (logorc2 x -1)) (eql -1 (logorc2 x x)) (eql x (logorc2 x (lognot x))) (eql (lognot x) (logorc2 (lognot x) x)))) t) (deftest logorc2.5 (loop for x = (random-fixnum) for xc = (lognot x) repeat 1000 unless (eql x (logorc2 x xc)) collect x) nil) (deftest logorc2.6 (loop for x = (random-from-interval (ash 1 (random 200))) for y = (random-from-interval (ash 1 (random 200))) for z = (logorc2 x y) repeat 1000 unless (and (if (or (< x 0) (>= y 0)) (< z 0) (>= z 0)) (loop for i from 1 to 210 always (if (or (not (logbitp i y)) (logbitp i x)) (logbitp i z) (not (logbitp i z))))) collect (list x y z)) nil) (deftest logorc2.order.1 (let ((i 0) a b) (values (logorc2 (progn (setf a (incf i)) 27) (progn (setf b (incf i)) -1)) i a b)) 27 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/terpri.lsp0000644000000000000000000000013114542551763015476 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.809790577 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/terpri.lsp0000644000175000017500000000231214542551763015073 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cons-test-21.lsp0000644000000000000000000000013214542551762016330 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.809790577 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-21.lsp0000644000175000017500000002160414542551762015731 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/mismatch.lsp0000644000000000000000000000013114542551763015776 xustar0030 mtime=1703597043.008022439 30 atime=1744294960.809790577 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/mismatch.lsp0000644000175000017500000004244714542551763015410 0ustar00cammcamm;-*- 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)) (deftest mistmatch-string.25 (let ((s0 "12345") (s1 "123A") (s2 "245")) (do-special-strings (s s0 nil) (assert (null (mismatch s s0))) (assert (null (mismatch s0 s))) (assert (null (mismatch s s0 :from-end t))) (assert (null (mismatch s0 s :from-end t))) (assert (eql (mismatch s s1) 3)) (assert (eql (mismatch s1 s) 3)) )) nil) ;;; test and test-not tests (defharmless mismatch.test-and-test-not.1 (mismatch '(1 2 3) '(1 2 4) :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.2 (mismatch '(1 2 3) '(1 2 4) :test-not #'eql :test #'eql)) (defharmless mismatch.test-and-test-not.3 (mismatch #(1 2 3) #(1 2 4) :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.4 (mismatch #(1 2 3) #(1 2 4) :test-not #'eql :test #'eql)) (defharmless mismatch.test-and-test-not.5 (mismatch "abc" "abd" :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.6 (mismatch "abc" "abd" :test-not #'eql :test #'eql)) (defharmless mismatch.test-and-test-not.7 (mismatch #*011 #*010 :test #'eql :test-not #'eql)) (defharmless mismatch.test-and-test-not.8 (mismatch #*011 #*010 :test-not #'eql :test #'eql)) ;;; 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 (signals-error (mismatch) program-error) t) (deftest mismatch.error.2 (signals-error (mismatch nil) program-error) t) (deftest mismatch.error.3 (signals-error (mismatch nil nil :bad t) program-error) t) (deftest mismatch.error.4 (signals-error (mismatch nil nil :bad t :allow-other-keys nil) program-error) t) (deftest mismatch.error.5 (signals-error (mismatch nil nil :key) program-error) t) (deftest mismatch.error.6 (signals-error (mismatch nil nil 1 2) program-error) t) (deftest mismatch.error.7 (signals-error (mismatch '(a b) '(a b) :test #'identity) program-error) t) (deftest mismatch.error.8 (signals-error (mismatch '(a b) '(a b) :test-not #'identity) program-error) t) (deftest mismatch.error.9 (signals-error (mismatch '(a b) '(a b) :key #'car) type-error) t) (deftest mismatch.error.10 (signals-error (mismatch '(a b) '(a b) :key #'cons) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/bit-orc1.lsp0000644000000000000000000000013014542551762015607 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.809790577 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-orc1.lsp0000644000175000017500000001565414542551762015222 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:25:28 2003 ;;;; Contains: Tests of BIT-ORC1 (in-package :cl-test) (compile-and-load "bit-aux.lsp") (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.20 (macrolet ((%m (z) z)) (bit-orc1 (expand-in-current-env (%m #*0011)) #*0101)) #*1101) (deftest bit-orc1.21 (macrolet ((%m (z) z)) (bit-orc1 #*1010 (expand-in-current-env (%m #*1100)))) #*1101) (deftest bit-orc1.22 (macrolet ((%m (z) z)) (bit-orc1 #*10100011 #*01101010 (expand-in-current-env (%m nil)))) #*01111110) (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) (deftest bit-orc1.fold.1 (flet ((%f () (declare (optimize speed (safety 0) (space 0))) (bit-orc1 #*11010 #*10100))) (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) #*10101 #*00101 #*10101) ;;; Random tests (deftest bit-orc1.random.1 (bit-random-test-fn #'bit-orc1 #'logorc1) nil) ;;; Error tests (deftest bit-orc1.error.1 (signals-error (bit-orc1) program-error) t) (deftest bit-orc1.error.2 (signals-error (bit-orc1 #*000) program-error) t) (deftest bit-orc1.error.3 (signals-error (bit-orc1 #*000 #*0100 nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/string-capitalize.lsp0000644000000000000000000000013214542551763017623 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.809790577 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/string-capitalize.lsp0000644000175000017500000001050314542551763017220 0ustar00cammcamm;-*- 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.11 :notes (:nil-vectors-are-strings) (string-capitalize (make-array '(0) :element-type nil)) "") (deftest string-capitalize.12 (loop for type in '(standard-char base-char character) for s = (make-array '(10) :element-type type :fill-pointer 5 :initial-contents "aB0cDefGHi") collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) (deftest string-capitalize.13 (loop for type in '(standard-char base-char character) for s0 = (make-array '(10) :element-type type :initial-contents "zZaB0cDefG") for s = (make-array '(5) :element-type type :displaced-to s0 :displaced-index-offset 2) collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) (deftest string-capitalize.14 (loop for type in '(standard-char base-char character) for s = (make-array '(5) :element-type type :adjustable t :initial-contents "aB0cD") collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) ;;; Order of evaluation tests (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) (def-fold-test string-capitalize.fold.1 (string-capitalize "ABCDE")) ;;; Error cases (deftest string-capitalize.error.1 (signals-error (string-capitalize) program-error) t) (deftest string-capitalize.error.2 (signals-error (string-capitalize (copy-seq "abc") :bad t) program-error) t) (deftest string-capitalize.error.3 (signals-error (string-capitalize (copy-seq "abc") :start) program-error) t) (deftest string-capitalize.error.4 (signals-error (string-capitalize (copy-seq "abc") :bad t :allow-other-keys nil) program-error) t) (deftest string-capitalize.error.5 (signals-error (string-capitalize (copy-seq "abc") :end) program-error) t) (deftest string-capitalize.error.6 (signals-error (string-capitalize (copy-seq "abc") 1 2) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/rt-package.lsp0000644000000000000000000000013214542551763016210 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.813790594 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/rt-package.lsp0000644000175000017500000000257614542551763015620 0ustar00cammcamm;-*- 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) #| (defpackage :regression-test (:use :cl) (:nicknames :rtest #-lispworks :rt) (:export #:*do-tests-when-defined* #:*compile-tests* #:*test* #:continue-testing #:deftest #:do-test #:do-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test #:defnote #:my-aref #:*catch-errors* #:disable-note )) |# (let* ((name (symbol-name :regression-test)) (pkg (find-package name))) (unless pkg (setq pkg (make-package name :nicknames (mapcar #'symbol-name '(:rtest #-lispworks :rt)) :use '(#-wcl :cl #+wcl :lisp) ))) (let ((*package* pkg)) (export (mapcar #'intern (mapcar #'symbol-name '(#:*compile-tests* #:*do-tests-when-defined* #:*test* #:continue-testing #:deftest #:do-test #:do-tests #:do-extended-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test #:defnote #:my-aref #:*catch-errors* #:*passed-tests* #:*failed-tests* #:disable-note)))))) ;; ) ;; (in-package :regression-test) gcl-2.7.1/ansi-tests/PaxHeaders/acons.lsp0000644000000000000000000000013214542551762015274 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.813790594 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/acons.lsp0000644000175000017500000000326714542551762014702 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:26:48 2003 ;;;; Contains: Tests of ACONS (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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.7 (macrolet ((%m (z) z)) (acons (expand-in-current-env (%m 'a)) 'b '(c))) ((a . b) c)) (deftest acons.8 (macrolet ((%m (z) z)) (acons 'a (expand-in-current-env (%m 'b)) '(c))) ((a . b) c)) (deftest acons.9 (macrolet ((%m (z) z)) (acons 'a 'b (expand-in-current-env (%m '(c))))) ((a . b) c)) (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) (def-fold-test acons.fold.1 (acons 'x 'y nil)) (def-fold-test acons.fold.2 (acons 1 2 '((3 . 4) (5 . 6)))) ;;; Error tests (deftest acons.error.1 (signals-error (acons) program-error) t) (deftest acons.error.2 (signals-error (acons 'a) program-error) t) (deftest acons.error.3 (signals-error (acons 'a 'b) program-error) t) (deftest acons.error.4 (signals-error (acons 'a 'b 'c 'd) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/ash.lsp0000644000000000000000000000013214542551762014744 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.813790594 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/ash.lsp0000644000175000017500000000301114542551762014335 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 08:43:03 2003 ;;;; Contains: Tests of ASH (in-package :cl-test) ;;; Error tests (deftest ash.error.1 (signals-error (ash) program-error) t) (deftest ash.error.2 (signals-error (ash 1 1 1) program-error) t) (deftest ash.error.3 (signals-error (ash 1 1 nil) program-error) t) (deftest ash.error.4 (check-type-error #'(lambda (x) (ash x 0)) #'integerp) nil) (deftest ash.error.5 (check-type-error #'(lambda (x) (ash 0 x)) #'integerp) nil) ;;; Non-error tests (deftest ash.1 (loop for x in *integers* always (eql (ash x 0) x)) t) (deftest ash.2 (loop for i = (random-fixnum) for s = (random-from-interval 40) for ishifted = (ash i s) repeat 1000 always (eql (floor (* i (expt 2 s))) ishifted)) t) (deftest ash.3 (let* ((nbits 100) (bound (expt 2 nbits))) (loop for i = (random-from-interval bound) for s = (random-from-interval (+ nbits 20)) for ishifted = (ash i s) repeat 1000 always (eql (floor (* i (expt 2 s))) ishifted))) t) (deftest ash.4 (loop for i from -1 downto -1000 always (eql (ash i i) -1)) t) (deftest ash.5 (loop for i from 1 to 100 for j = (- (ash 1 i)) always (eql (ash j j) -1)) t) (deftest ash.6 (macrolet ((%m (z) z)) (values (ash (expand-in-current-env (%m 3)) 1) (ash 1 (expand-in-current-env (%m 3))))) 6 8) (deftest ash.order.1 (let ((i 0) x y) (values (ash (progn (setf x (incf i)) 1) (progn (setf y (incf i)) 2)) i x y)) 4 2 1 2) gcl-2.7.1/ansi-tests/PaxHeaders/array-row-major-index.lsp0000644000000000000000000000013214542551762020327 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.813790594 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-row-major-index.lsp0000644000175000017500000000223514542551762017727 0ustar00cammcamm;-*- 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.4 (macrolet ((%m (z) z)) (array-row-major-index (expand-in-current-env (%m #(a b c))) 1)) 1) (deftest array-row-major-index.5 (macrolet ((%m (z) z)) (array-row-major-index #(a b c) (expand-in-current-env (%m 1)))) 1) (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 (signals-error (array-row-major-index) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/interactive-stream-p.lsp0000644000000000000000000000013114542551762020233 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.813790594 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/interactive-stream-p.lsp0000644000175000017500000000134614542551762017636 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/maplist.lsp0000644000000000000000000000013114542551763015642 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.813790594 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/maplist.lsp0000644000175000017500000000607214542551763015246 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:24:00 2003 ;;;; Contains: Tests of MAPLIST (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) (def-fold-test maplist.fold.1 (maplist 'car '(a b c d e))) (def-fold-test maplist.fold.2 (maplist #'cadr '(a b c d e))) ;;; Error tests (deftest maplist.error.1 (check-type-error #'(lambda (x) (maplist #'identity x)) #'listp) nil) (deftest maplist.error.2 (signals-error (maplist #'identity 1) type-error) t) (deftest maplist.error.3 (signals-error (maplist #'identity 1.1323) type-error) t) (deftest maplist.error.4 (signals-error (maplist #'identity "abcde") type-error) t) (deftest maplist.error.5 (signals-error (maplist) program-error) t) (deftest maplist.error.6 (signals-error (maplist #'append) program-error) t) (deftest maplist.error.7 (signals-error (locally (maplist #'identity 'a) t) type-error) t) (deftest maplist.error.8 (signals-error (maplist #'caar '(a b c)) type-error) t) (deftest maplist.error.9 (signals-error (maplist #'cons '(a b c)) program-error) t) (deftest maplist.error.10 (signals-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) t) (deftest maplist.error.11 (signals-error (maplist #'identity (list* (list 1) (list 2) 3)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/array-rank.lsp0000644000000000000000000000013214542551762016240 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.813790594 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-rank.lsp0000644000175000017500000000202714542551762015637 0ustar00cammcamm;-*- 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 (check-predicate #'(lambda (e) (or (not (typep e 'vector)) (eql (array-rank e) 1)))) nil) (deftest array-rank.3 (macrolet ((%m (z) z)) (array-rank (expand-in-current-env (%m "abc")))) 1) (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 (signals-error (array-rank) program-error) t) (deftest array-rank.error.2 (signals-error (array-rank #(a b c) nil) program-error) t) (deftest array-rank.error.3 (check-type-error #'array-rank #'arrayp) nil) (deftest array-rank.error.4 (signals-error (array-rank nil) type-error) t) (deftest array-rank.error.5 (signals-type-error x nil (locally (array-rank x) t)) t) gcl-2.7.1/ansi-tests/PaxHeaders/floor-aux.lsp0000644000000000000000000000013214542551762016105 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.813790594 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/floor-aux.lsp0000644000175000017500000000502114542551762015501 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 9 08:08:00 2003 ;;;; Contains: Aux. functions used in FLOOR tests (in-package :cl-test) (defun floor.1-fn () (loop for n = (- (random 2000000000) 1000000000) for d = (1+ (random 10000)) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (integerp r) (< -1 r d)) collect (list n d q r n2))) (defun floor.2-fn () (loop for num = (random 1000000000) for denom = (1+ (random 1000)) for n = (/ num denom) for d = (1+ (random 10000)) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (<= 0 r) (< r d) (= n n2)) collect (list n d q r n2))) (defun floor.3-fn (width) (loop for n = (- (random width) (/ width 2)) for vals = (multiple-value-list (floor n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (= n n2) (<= 0 r) (< r 1) ) collect (list n q r n2))) (defun floor.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) for denominator = (1+ (random 100000)) for n = (/ numerator denominator) for vals = (multiple-value-list (floor n)) for (q r) = vals for n2 = (+ q r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (= n n2) (<= 0 r) (< r 1) ) collect (list n q r n2))) (defun floor.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) for den1 = (1+ (random 100000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000))) for den2 = (1+ (random 1000000)) for d = (/ num2 den2) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (>= 0 r) (> r d) (= n n2)) collect (list n q d r n2))) (defun floor.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) for den1 = (1+ (random 10000000000)) for n = (/ num1 den1) for num2 = (- (1+ (random 1000000000))) for den2 = (1+ (random 10000000)) for d = (/ num2 den2) for vals = (multiple-value-list (floor n d)) for (q r) = vals for n2 = (+ (* q d) r) repeat 1000 unless (and (eql (length vals) 2) (integerp q) (rationalp r) (>= 0 r) (> r d) (= n n2)) collect (list n q d r n2))) ;;; Need float tests gcl-2.7.1/ansi-tests/PaxHeaders/pathname-type.lsp0000644000000000000000000000013114542551763016745 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.813790594 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/pathname-type.lsp0000644000175000017500000000352014542551763016344 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/load-test-file.lsp0000644000000000000000000000013114542551762017001 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.813790594 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/load-test-file.lsp0000644000175000017500000000020414542551762016374 0ustar00cammcamm(in-package :cl-test) (defun load-file-test-fun.1 () '#.*load-pathname*) (defun load-file-test-fun.2 () '#.*load-truename*) gcl-2.7.1/ansi-tests/PaxHeaders/format-t.lsp0000644000000000000000000000013214542551762015722 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.817790612 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-t.lsp0000644000175000017500000002065114542551762015324 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 21 12:45:22 2004 ;;;; Contains: Tests of the ~T format directive (in-package :cl-test) (compile-and-load "printer-aux.lsp") (def-pprint-test format.t.1 (format nil "~0,0T") "") (def-pprint-test format.t.2 (format nil "~1,0T") " ") (def-pprint-test format.t.3 (format nil "~0,1T") " ") (def-pprint-test format.t.4 (loop for i from 0 to 20 for s = (format nil "~0,vT" i) unless (string= s (make-string i :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.5 (loop for i from 0 to 20 for s = (format nil "~v,0T" i) unless (string= s (make-string i :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.6 (loop for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) s1) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space)))) for pretty = (coin) for result = (let ((*print-pretty* pretty)) (format nil (format nil "~A~~~D,~DT" s1 n2 inc))) repeat 100 unless (string= s2 result) collect (list n1 n2 inc pretty s2 result)) nil) (def-pprint-test format.t.7 (loop for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) s1) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s1 (make-string (- n2 n1) :initial-element #\Space)))) for pretty = (coin) for result = (let ((*print-pretty* pretty)) (format nil "~A~v,vt" s1 n2 inc)) repeat 100 unless (string= s2 result) collect (list n1 n2 inc pretty s2 result)) nil) (def-pprint-test format.t.8 (loop for i from 1 to 20 for s = (format nil " ~v,vT" nil i) unless (string= s (make-string (1+ i) :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.9 (loop for i from 1 to 20 for s = (format nil "~v,vT" i nil) unless (string= s (make-string i :initial-element #\Space)) collect (list i s)) nil) (def-pprint-test format.t.10 (format nil "XXXXX~2,0T") "XXXXX") ;;; @t (def-pprint-test format.@t.1 (format nil "~1,1@t") " ") (def-pprint-test format.@t.2 (loop for colnum from 0 to 20 for s1 = (format nil "~v,1@t" colnum) for s2 = (make-string colnum :initial-element #\Space) unless (string= s1 s2) collect (list colnum s1 s2)) nil) (def-pprint-test format.@t.3 (loop for colnum = (random 50) for colinc = (1+ (random 20)) for s1 = (format nil "~v,v@t" colnum colinc) for s2 = (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space) repeat 100 unless (string= s1 s2) collect (list colnum colinc s1 s2)) nil) (def-pprint-test format.@t.4 (loop for colnum = (random 50) for colinc = (1+ (random 20)) for s1 = (format nil "~v,1@T~0,v@t" colnum colinc) for s2 = (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space) repeat 100 unless (string= s1 s2) collect (list colnum colinc s1 s2)) nil) (def-pprint-test format.@t.5 (loop for colnum = (random 50) for colinc = (1+ (random 20)) for pretty = (coin) for s1 = (let ((*pretty* pretty)) (format nil (format nil "~~~d,~d@t" colnum colinc))) for s2 = (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space) repeat 100 unless (string= s1 s2) collect (list colnum colinc pretty s1 s2)) nil) ;;; Pretty printing (colon modifier) ;;; Not a pretty printing stream (def-pprint-test format.\:t.1 (format nil "XX~10:tYY") "XXYY") ;;; A pretty printing stream, but *print-pretty* is nil (def-pprint-test format.\:t.2 (with-output-to-string (s) (pprint-logical-block (s '(a b c)) (format s "XX~10:tYY"))) "XXYY" :pretty nil) (def-pprint-test format.\:t.3 (with-output-to-string (s) (pprint-logical-block (s '(a b c)) (let ((*print-pretty* nil)) (format s "XX~10:tYY")))) "XXYY") ;;; Positive tests (def-pprint-test format.\:t.4 (format nil "~<[~;~0,0:T~;]~:>" '(a)) "[]") (def-pprint-test format.\:t.5 (format nil "~<[~;~1,0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.5a (format nil "~<[~;~,0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.6 (format nil "~<[~;~0,1:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.6a (format nil "~<[~;~0,:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.6b (format nil "~<[~;~0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.7 (loop for i from 0 to 20 for s = (format nil "~" (list i)) unless (string= s (concatenate 'string "X" (make-string i :initial-element #\Space) "Y")) collect (list i s)) nil) (def-pprint-test format.\:t.8 (loop for i from 0 to 20 for s = (format nil "~" (list i)) unless (string= s (concatenate 'string "ABC" (make-string i :initial-element #\Space) "DEF")) collect (list i s)) nil) (def-pprint-test format.\:t.9 (loop for n0 = (random 10) for s0 = (make-string n0 :initial-element #\Space) for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) (concatenate 'string s0 s1)) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space)))) for result = (format nil (format nil "~A~~<~A~~~D,~D:T~~:>" s0 s1 n2 inc) '(a)) repeat 100 unless (string= s2 result) collect (list n0 n1 n2 inc s2 result)) nil) (def-pprint-test format.\:t.10 (format nil "~<[~;~2,0:T~;]~:>" '(a)) "[ ]") (def-pprint-test format.\:t.11 (format nil "~<[~;XXXX~2,0:T~;]~:>" '(a)) "[XXXX]") (def-pprint-test format.\:t.12 (loop for n0 = (random 20) for s0 = (make-string n0 :initial-element #\Space) for n1 = (random 30) for s1 = (make-string n1 :initial-element #\X) for n2 = (random 30) for inc = (random 20) for s2 = (cond ((< n1 n2) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space))) ((= inc 0) (concatenate 'string s0 s1)) (t (loop do (incf n2 inc) while (<= n2 n1)) (concatenate 'string s0 s1 (make-string (- n2 n1) :initial-element #\Space)))) for result = (format nil "~A~<~A~v,v:t~:>" s0 (list s1 n2 inc)) repeat 100 unless (string= s2 result) collect (list n1 n2 inc s2 result)) nil) ;;; see 22.3.5.2 (deftest format.\:t.error.1 (signals-error-always (format nil "~") error) t t) (deftest format.\:t.error.2 (signals-error-always (format nil "~ZZZ~4,5:tWWW") error) t t) (deftest format.\:t.error.3 (signals-error-always (format nil "AAAA~1,1:TBBB~ZZZ") error) t t) ;;; ~:@t (def-pprint-test format.\:@t.1 (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1a (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1b (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1c (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.1d (format nil "~" '(a)) "XXX YYY") (def-pprint-test format.\:@t.2 (loop for colnum from 0 to 20 for s1 = (format nil "~" (list colnum)) for s2 = (concatenate 'string "XXXX" (make-string colnum :initial-element #\Space)) unless (string= s1 s2) collect (list colnum s1 s2)) nil) (def-pprint-test format.\:@t.3 (loop for s0 = (make-string (random 20) :initial-element #\M) for colnum = (random 50) for colinc = (1+ (random 20)) for s1 = (format nil "~A~<~v,v:@t~:>" s0 (list colnum colinc)) for s2 = (concatenate 'string s0 (make-string (* colinc (ceiling colnum colinc)) :initial-element #\Space)) repeat 100 unless (string= s1 s2) collect (list colnum colinc s1 s2)) nil) ;;; Turned off if not pretty printing (def-pprint-test format.\:@t.4 (format nil "XX~10,20:@tYY") "XXYY" :pretty nil) (def-pprint-test format.\:@t.5 (with-output-to-string (s) (pprint-logical-block (s '(a b c)) (format s "XX~10,20@:tYY"))) "XXYY" :pretty nil) gcl-2.7.1/ansi-tests/PaxHeaders/condition.lsp0000644000000000000000000000013014542551762016155 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.817790612 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/condition.lsp0000644000175000017500000000521214542551762015555 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/packages.lsp0000644000000000000000000000013114542551763015747 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.817790612 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/packages.lsp0000644000175000017500000000121114542551763015341 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/atan.lsp0000644000000000000000000000013214542551762015114 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.817790612 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/atan.lsp0000644000175000017500000000730714542551762014521 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 06:01:55 2004 ;;;; Contains: Tests of ATAN (in-package :cl-test) (deftest atan.1 (let ((result (atan 0))) (or (eqlt result 0) (eqlt result 0.0))) t) (deftest atan.2 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (eql (atan zero) zero) collect type) nil) (deftest atan.3 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) unless (eql (atan zero 1) zero) collect type) nil) (deftest atan.4 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (eql (atan 0 one) zero) collect type) nil) (deftest atan.5 (loop for type in '(short-float single-float double-float long-float) for zero = (coerce 0 type) for one = (coerce 1 type) unless (eql (atan zero one) zero) collect type) nil) (deftest atan.6 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) collect (loop for x = (- (random a) b) for rlist = (multiple-value-list (atan x)) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y type)) collect (list x rlist))) (nil nil nil nil)) (deftest atan.7 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) for zero = (coerce 0 type) collect (loop for x = (- (random a) b) for rlist = (multiple-value-list (atan (complex x zero))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x rlist))) (nil nil nil nil)) (deftest atan.8 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) for zero = (coerce 0 type) collect (loop for x = (- (random a) b) for rlist = (multiple-value-list (atan (complex zero x))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x rlist))) (nil nil nil nil)) (deftest atan.9 (loop for type in '(short-float single-float double-float long-float) for a = (coerce 2000 type) for b = (coerce -1000 type) for zero = (coerce 0 type) collect (loop for x1 = (- (random a) b) for x2 = (- (random a) b) for rlist = (multiple-value-list (atan (complex x1 x2))) for y = (car rlist) repeat 1000 unless (and (null (cdr rlist)) (typep y `(complex ,type))) collect (list x1 x2 rlist))) (nil nil nil nil)) (deftest atan.10 (approx= (atan 1) (coerce (/ pi 4) 'single-float)) t) (deftest atan.11 (loop for type in '(short-float single-float double-float long-float) collect (approx= (atan (coerce 1 type)) (coerce (/ pi 4) type))) (t t t t)) (deftest atan.12 (approx= (atan -1) (coerce (/ pi -4) 'single-float)) t) (deftest atan.13 (loop for type in '(short-float single-float double-float long-float) collect (approx= (atan (coerce -1 type)) (coerce (/ pi -4) type))) (t t t t)) (deftest atan.14 (macrolet ((%m (z) z)) (atan (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest atan.error.1 (signals-error (atan) program-error) t) (deftest atan.error.2 (signals-error (atan 1 1 1) program-error) t) (deftest atan.error.3 (check-type-error #'atan #'numberp) nil) (deftest atan.error.4 (check-type-error #'(lambda (x) (atan x 1)) #'realp) nil) (deftest atan.error.5 (check-type-error #'(lambda (x) (atan 1 x)) #'realp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/beyond-ansi0000644000000000000000000000013214776006046015603 xustar0030 mtime=1744309286.150034344 30 atime=1744351538.814879383 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/0000755000175000017500000000000014776006046015256 5ustar00cammcammgcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/errors-eval-compile.lsp0000644000000000000000000000013214542551762022270 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.817790612 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/errors-eval-compile.lsp0000644000175000017500000002037414542551762021674 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 06:37:41 2005 ;;;; Contains: Tests for nonstandard exceptional conditions in section 3 (in-package :ba-test) (declaim (notinline compile-fails?)) (compile-and-load "ba-aux.lsp") ;;; Utility functions (defun compile-fails? (&rest args) (cl:handler-case (let ((vals (multiple-value-list (apply #'compile args)))) (if (and (= (length vals) 3) (cadr vals) (caadr vals)) t (apply #'values nil vals))) (error () t))) ;;; Tests of COMPILE (deftest compile.1 (loop for x in *mini-universe* unless (or (function-name-p x) (compile-fails? x)) collect x) nil) (deftest compile.2 (compile-fails? nil) t) (deftest compile.3 (let ((sym (gensym))) (eval `(defun ,sym () nil)) (loop for x in *mini-universe* unless (or (functionp x) (and (consp x) (eql (car x) 'lambda)) (compile-fails? sym x)) collect x)) nil) (deftest compile.4 (compile-fails? nil '(lambda)) t) (deftest compile.5 (compile-fails? nil '(lambda x)) t) ;;; EVAL-WHEN tests (def-all-error-test eval-when.1 'listp '(eval-when x nil)) ;;; LOAD-TIME-VALUE (def-error-test load-time-value.1 (load-time-value)) (def-error-test load-time-value.2 (load-time-value nil nil nil)) ;;; QUOTE (def-error-test quote.1 (quote)) (def-error-test quote.2 (quote . x)) (def-error-test quote.3 (quote t . x)) (def-error-test quote.4 (quote t x)) ;;; COMPILER-MACRO-FUNCTION (def-all-error-test compiler-macro-function.1 'function-name-p '(compiler-macro-function x)) (def-all-error-test compiler-macro-function.2 'function-name-p '(setf (compiler-macro-function x) #'rplacd)) ;;; DEFINE-COMPILER-MACRO (def-error-test define-compiler-macro.1 (define-compiler-macro)) (deftest define-compiler-macro.2 (let ((sym (gensym))) (eval `(signals-error (define-compiler-macro ,sym) error))) t) (def-error-test define-compiler-macro.3 (define-compiler-macro . foo)) (deftest define-compiler-macro.4 (let ((sym (gensym))) (eval `(signals-error (define-compiler-macro ,sym () . foo) error))) t) ;;; DEFMACRO (def-error-test defmacro.1 (defmacro)) (deftest defmacro.2 (let ((sym (gensym))) (eval `(signals-error (defmacro ,sym) error))) t) (def-error-test defmacro.3 (defmacro . foo)) (deftest defmacro.4 (let ((sym (gensym))) (eval `(signals-error (defmacro ,sym () . foo) error))) t) ;;; MACRO-FUNCTION (def-all-error-test macro-funtion.1 'symbolp '(macro-function x)) (def-all-error-test macro-funtion.2 'symbolp '(setf (macro-function x) (macro-function 'pop))) ;;; DEFINE-SYMBOL-MACRO (deftest define-symbol-macro.1 (let ((sym (gensym))) (eval `(signals-error (define-symbol-macro ,sym) error))) t) (deftest define-symbol-macro.2 (let ((sym (gensym))) (eval `(signals-error (define-symbol-macro ,sym t nil) error))) t) (def-all-error-test define-symbol-macro.3 'symbolp '(define-symbol-macro x)) ;;; IGNORE (def-all-error-test ignore.1 'symbol-or-function-p '(locally (declare (ignore x)) nil)) (def-error-test ignore.2 (locally (declare (ignore . foo)) nil)) ;;; IGNORABLE (def-all-error-test ignorable.1 'symbol-or-function-p '(locally (declare (ignorable x)) nil)) (def-error-test ignorable.2 (locally (declare (ignorable . foo)) nil)) ;;; DYNAMIC-EXTENT (def-all-error-test dynamic-extent.1 'symbol-or-function-p '(locally (declare (dynamic-extent x)) nil)) (def-error-test dynamic-extent.2 (locally (declare (dynamic-extent . foo)) nil)) ;;; TYPE declarations ;;; Test that violation of the type declarations is detected, and ;;; leads to an error in safe code. #-sbcl (deftest type.1 (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (y) (declare (optimize safety) (type (not ,tp) y)) y) for fn = (progn (print lambda-form) (eval `(function ,lambda-form))) unless (eval `(signals-error (funcall ',fn ',x) error)) collect x) nil) (deftest type.2 (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) (n (length utypes))) (flet ((%rtype () (elt utypes (random n)))) (loop for x in *mini-universe* for tp = (loop for tp = (%rtype) while (typep x tp) finally (return tp)) for lambda-form = `(lambda (y) (declare (optimize safety) (type ,tp y)) y) for fn = (progn ;; (print lambda-form) (eval `(function ,lambda-form))) unless (eval `(signals-error (funcall ',fn ',x) error)) collect x))) nil) (deftest type.2c (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) (n (length utypes))) (flet ((%rtype () (elt utypes (random n)))) (loop for x in *mini-universe* for tp = (loop for tp = (%rtype) while (typep x tp) finally (return tp)) for lambda-form = `(lambda (y) (declare (optimize safety) (type ,tp y)) y) for fn = (progn ;; (print lambda-form) (compile nil lambda-form)) unless (eval `(signals-error (funcall ',fn ',x) error)) collect x))) nil) (deftest type.3 (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (z) (declare (optimize safety)) (let ((y z)) (declare (type ,tp y)) y)) for fn = (progn ;; (print lambda-form) (eval `(function ,lambda-form))) unless (or (typep nil tp) (eval `(signals-error (funcall ',fn nil) error))) collect x) nil) (deftest type.3c (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (z) (declare (optimize safety)) (let ((y z)) (declare (type ,tp y)) y)) for fn = (progn ;; (print lambda-form) (compile nil lambda-form)) unless (or (typep nil tp) (eval `(signals-error (funcall ',fn nil) error))) collect x) nil) (deftest type.4 (loop for x in *mini-universe* for tp = (type-of x) for lambda-form = `(lambda (z) (declare (optimize safety)) (the ,tp z)) for fn = (progn ;; (print lambda-form) (eval `(function ,lambda-form))) unless (or (typep nil tp) (eval `(signals-error (funcall ',fn nil) error))) collect x) nil) (deftest type.5 (signals-error (let () (declare (type . foo)) nil) error) t) (deftest type.6 (signals-error (let () (declare (type integer . foo)) nil) error) t) (deftest type.7 (signals-error (let () (declare (integer . foo)) nil) error) t) (deftest type.8 (signals-error (let ((x (make-array 3 :initial-element 0 :element-type '(integer 0 2)))) (declare (optimize safety) (type (array (integer 0 2) (3)) x)) (setf (aref x 0) 3) (aref x 0)) error) t) ;; Move the type tests off to another file, eventually. ;;; INLINE (def-all-error-test inline.1 'function-name-p '(locally (declare (inline x)) nil)) (def-error-test inline.2 (locally (declare (inline . x)) nil)) ;;; NOTINLINE (def-all-error-test notinline.1 'function-name-p '(locally (declare (notinline x)) nil)) (def-error-test notinline.2 (locally (declare (notinline . x)) nil)) ;;; FTYPE (def-error-test ftype.1 (macrolet ((%m () :foo)) (declare (ftype (function (&rest t) t) %m)) (%m))) (def-error-test ftype.2 (flet ((%f () :foo)) (declare (ftype (function () (eql :bar)) %f)) (%f))) (def-error-test ftype.3 (locally (declare (ftype)) nil)) (def-error-test ftype.4 (locally (declare (ftype symbol)) nil)) (def-error-test ftype.5 (locally (declare (ftype (function () t) . foo)) nil)) (def-all-error-test ftype.6 'function-name-p '(locally (declare (ftype (function () t) x)) nil)) ;;; DECLARATIONS (def-error-test declaration.1 (proclaim '(declaration . foo))) (def-all-error-test declaration.2 'symbolp '(proclaim (declaration x))) ;;; OPTIMIZE (def-error-test optimize.1 (locally (declare (optimize .foo)) nil)) (def-all-error-test optimize.2 'symbolp '(locally (declare (optimize (x 0))) nil)) (def-all-error-test optimize.3 (typef '(mod 4)) '(locally (declare (optimize (speed x))))) ;;; SPECIAL (def-error-test special.1 (locally (declare (special . x)) nil)) (def-all-error-test special.2 'symbolp '(locally (declare (special x)) nil)) ;;; LOCALLY (def-error-test locally.1 (locally . x)) ;;; THE (def-error-test the.1 (the)) (def-error-test the.2 (the t)) (def-error-test the.3 (the t :a :b)) (def-error-test the.4 (setf (the) nil)) (def-error-test the.5 (setf (the t) nil)) (def-error-test the.6 (let (x y) (setf (the t x y) nil))) ;;; gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/errors-data-and-control-flow-1.lsp0000644000000000000000000000013214542551762024145 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.817790612 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/errors-data-and-control-flow-1.lsp0000644000175000017500000001201014542551762023535 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 30 15:38:09 2005 ;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 1 (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; APPLY (def-all-error-test apply.1 'function-designator-p '(apply x nil)) (def-all-error-test apply.2 'function-designator-p '(apply x '(1 2 3))) (def-error-test apply.3 (apply 'cons . 1)) (def-all-error-test apply.4 'listp '(apply 'cons '1 x)) ;;; DEFUN (def-error-test defun.1 (defun)) (def-error-test defun.2 (defun #.(gensym))) (def-error-test defun.3 (defun . foo)) (def-error-test defun.4 (defun #.(gensym) #.(gensym))) (def-error-test defun.5 (defun #.(gensym) () . foo)) (def-error-test defun.6 (defun #.(gensym) () "foo" "bar" (declare))) (def-error-test defun.7 (defun #.(gensym) () nil (declare))) ;;; FIXME Add lambda list tests ;;; FLET (def-error-test flet.1 (flet . foo)) (def-error-test flet.2 (flet foo)) (def-error-test flet.3 (flet (foo))) (def-error-test flet.4 (flet ((foo)))) (def-error-test flet.5 (flet ((foo . bar)))) (def-error-test flet.6 (flet () . foo)) (def-error-test flet.7 (flet ((foo () . bar)))) (def-error-test flet.8 (flet ((foo z)))) (def-error-test flet.9 (flet ((foo ((x y)))))) (def-all-error-test flet.10 'symbolp #'(lambda (x) (subst x 'x '(flet ((foo (&rest x))))))) (def-all-error-test flet.11 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(flet ((foo (&optional x))))))) (def-all-error-test flet.12 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(flet ((foo (&key x))))))) (def-error-test flet.13 (flet ((foo (&optional (x . bar)) nil)))) (def-error-test flet.14 (flet ((foo (&optional (x nil . bar)) nil)))) (def-error-test flet.15 (flet ((foo (&optional (x nil x-p . bar)) nil)))) (def-error-test flet.16 (flet ((foo (&optional (x nil x-p nil)) nil)))) (def-error-test flet.17 (flet ((foo (&key (x . bar)) nil)))) (def-error-test flet.18 (flet ((foo (&key (x nil . bar)) nil)))) (def-error-test flet.19 (flet ((foo (&key (x nil x-p . bar)) nil)))) (def-error-test flet.20 (flet ((foo (&key (x nil x-p nil)) nil)))) (def-error-test flet.21 (flet ((foo (&key ((x . bar))) nil)))) (def-error-test flet.22 (flet ((foo (&key ((x y . z))) nil)))) (def-error-test flet.23 (flet ((foo (&key ((x y z))) nil)))) (def-all-error-test flet.24 'symbolp #'(lambda (x) `(flet ((foo (&key ((,x y))) nil))))) (def-all-error-test flet.25 'symbolp #'(lambda (x) `(flet ((foo (&key ((y ,x))) nil))))) (def-error-test flet.26 (flet ((foo (&aux . bar))))) (def-error-test flet.27 (flet ((foo (&aux (x . bar)))))) (def-error-test flet.28 (flet ((foo (&aux (x nil . bar)))))) (def-error-test flet.29 (flet ((foo (&aux (x nil nil)))))) (def-error-test flet.30 (flet ((foo () "x" "y" (declare))) (foo))) (def-error-test flet.31 (flet ((foo () :bad1) (foo () :bad2)) (foo))) ;;; FIXME Add tests for disallowed lambda list keywords ;;; LABELS (def-error-test labels.1 (labels . foo)) (def-error-test labels.2 (labels foo)) (def-error-test labels.3 (labels (foo))) (def-error-test labels.4 (labels ((foo)))) (def-error-test labels.5 (labels ((foo . bar)))) (def-error-test labels.6 (labels () . foo)) (def-error-test labels.7 (labels ((foo () . bar)))) (def-error-test labels.8 (labels ((foo z)))) (def-error-test labels.9 (labels ((foo ((x y)))))) (def-all-error-test labels.10 'symbolp #'(lambda (x) (subst x 'x '(labels ((foo (&rest x))))))) (def-all-error-test labels.11 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(labels ((foo (&optional x))))))) (def-all-error-test labels.12 (typef '(or symbol cons)) #'(lambda (x) (subst x 'x '(labels ((foo (&key x))))))) (def-error-test labels.13 (labels ((foo (&optional (x . bar)) nil)))) (def-error-test labels.14 (labels ((foo (&optional (x nil . bar)) nil)))) (def-error-test labels.15 (labels ((foo (&optional (x nil x-p . bar)) nil)))) (def-error-test labels.16 (labels ((foo (&optional (x nil x-p nil)) nil)))) (def-error-test labels.17 (labels ((foo (&key (x . bar)) nil)))) (def-error-test labels.18 (labels ((foo (&key (x nil . bar)) nil)))) (def-error-test labels.19 (labels ((foo (&key (x nil x-p . bar)) nil)))) (def-error-test labels.20 (labels ((foo (&key (x nil x-p nil)) nil)))) (def-error-test labels.21 (labels ((foo (&key ((x . bar))) nil)))) (def-error-test labels.22 (labels ((foo (&key ((x y . z))) nil)))) (def-error-test labels.23 (labels ((foo (&key ((x y z))) nil)))) (def-all-error-test labels.24 'symbolp #'(lambda (x) `(labels ((foo (&key ((,x y))) nil))))) (def-all-error-test labels.25 'symbolp #'(lambda (x) `(labels ((foo (&key ((y ,x))) nil))))) (def-error-test labels.26 (labels ((foo (&aux . bar))))) (def-error-test labels.27 (labels ((foo (&aux (x . bar)))))) (def-error-test labels.28 (labels ((foo (&aux (x nil . bar)))))) (def-error-test labels.29 (labels ((foo (&aux (x nil nil)))))) (def-error-test labels.30 (labels ((foo () "x" "y" (declare))) (foo))) (def-error-test labels.31 (labels ((foo () :bad1) (foo () :bad2)) (foo))) ;;; FIXME Add tests for disallowed lambda list keywords ;;; MACROLET ;;; FIXME: add these gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/errors-iteration.lsp0000644000000000000000000000013014542551762021707 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.817790612 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/errors-iteration.lsp0000644000175000017500000000601214542551762021306 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS section 6 (Iteration) (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; DO tests (def-all-error-test do.1 'listp #'(lambda (x) `(do . ,x))) (def-all-error-test do.2 'listp #'(lambda (x) `(do () . ,x))) (def-all-error-test do.3 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(do (,x)))) (def-all-error-test do.4 'listp #'(lambda (x) `(do ((a 1 (1+ a)) . ,x)))) (def-all-error-test do.5 'listp #'(lambda (x) `(do () ,x))) (def-all-error-test do.6 'listp #'(lambda (x) `(do () (t . ,x)))) (def-all-error-test do.7 'listp #'(lambda (x) `(do () (t) . ,x))) (def-all-error-test do.8 'listp #'(lambda (x) `(do ((a . ,x)) (t)))) (def-all-error-test do.9 'listp #'(lambda (x) `(do ((a 1 . ,x)) (t)))) (def-all-error-test do.10 'listp #'(lambda (x) `(do ((a 1 (1+ a) . ,x)) (t)))) (def-error-test do.11 (do)) ;;; DO* tests (def-all-error-test do*.1 'listp #'(lambda (x) `(do* . ,x))) (def-all-error-test do*.2 'listp #'(lambda (x) `(do* () . ,x))) (def-all-error-test do*.3 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(do* (,x)))) (def-all-error-test do*.4 'listp #'(lambda (x) `(do* ((a 1 (1+ a)) . ,x)))) (def-all-error-test do*.5 'listp #'(lambda (x) `(do* () ,x))) (def-all-error-test do*.6 'listp #'(lambda (x) `(do* () (t . ,x)))) (def-all-error-test do*.7 'listp #'(lambda (x) `(do* () (t) . ,x))) (def-all-error-test do*.8 'listp #'(lambda (x) `(do* ((a . ,x)) (t)))) (def-all-error-test do*.9 'listp #'(lambda (x) `(do* ((a 1 . ,x)) (t)))) (def-all-error-test do*.10 'listp #'(lambda (x) `(do* ((a 1 (1+ a) . ,x)) (t)))) (def-error-test do*.11 (do*)) ;;; DOTIMES tests (def-error-test dotimes.1 (dotimes)) (def-all-error-test dotimes.2 'listp #'(lambda (x) `(dotimes . ,x))) (def-all-error-test dotimes.3 'symbolp #'(lambda (x) `(dotimes (,x 1)))) (def-all-error-test dotimes.4 (constantly nil) #'(lambda (x) `(dotimes (,x)))) (def-all-error-test dotimes.5 'integerp #'(lambda (x) `(dotimes (i ',x)))) (def-all-error-test dotimes.6 'listp #'(lambda (x) `(dotimes (i . ,x)))) (def-all-error-test dotimes.7 'listp #'(lambda (x) `(dotimes (i 1 . ,x)))) (def-all-error-test dotimes.8 'listp #'(lambda (x) `(dotimes (i 1) . ,x))) (def-all-error-test dotimes.9 'listp #'(lambda (x) `(dotimes (i 1 nil . ,x)))) (def-all-error-test dotimes.10 'listp #'(lambda (x) `(dotimes (i 1 nil ,x)))) ;;; DOLIST tests (def-error-test dolist.1 (dolist)) (def-all-error-test dolist.2 'listp #'(lambda (x) `(dolist . ,x))) (def-all-error-test dolist.3 'symbolp #'(lambda (x) `(dolist (,x nil)))) (def-all-error-test dolist.4 'listp #'(lambda (x) `(dolist (e . ,x)))) (def-all-error-test dolist.5 'listp #'(lambda (x) `(dolist (e nil . ,x)))) (def-all-error-test dolist.6 'listp #'(lambda (x) `(dolist (e nil nil . ,x)))) (def-all-error-test dolist.7 'listp #'(lambda (x) `(dolist (e nil nil ,x)))) (def-all-error-test dolist.8 'listp #'(lambda (x) `(dolist (e ',x nil)))) (def-all-error-test dolist.9 'listp #'(lambda (x) `(dolist (e nil nil) . ,x))) gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/load-ba.lsp0000644000000000000000000000013014542551762017676 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.817790612 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/load-ba.lsp0000644000175000017500000000117414542551762017301 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jun 8 06:52:59 2005 ;;;; Contains: Load beyond-ansi tests (let ((*default-pathname-defaults* (pathname *load-pathname*))) (let ((*default-pathname-defaults* (merge-pathnames (make-pathname :directory '(:relative :up))))) (load "gclload1.lsp")) (load "ba-test-package.lsp") (eval '(compile-and-load "ba-aux.lsp")) (load "errors-eval-compile.lsp") (load "errors-types-and-class.lsp") (load "errors-data-and-control-flow-1.lsp") (load "errors-data-and-control-flow-2.lsp") (load "errors-data-and-control-flow-3.lsp") (in-package :ba-test) ) gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/makefile.old0000644000000000000000000000013214776006046020135 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/makefile.old0000644000175000017500000000036114776006046017533 0ustar00cammcammtest: echo "(load \"load-ba.lsp\") (in-package :ba-test) (rt:do-tests)" | $(LISP) | tee test.out clean: @rm -f test.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\# @rm -f gazonk* out.class *.dfsl *.d64fsl gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/ba-test-package.lsp0000644000000000000000000000013214542551762021331 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.817790612 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/ba-test-package.lsp0000644000175000017500000000111514542551762020725 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 28 06:38:29 2005 ;;;; Contains: Definition of BA-TEST package. (in-package :cl-user) (let* ((name :ba-test) (pkg (find-package name))) (unless pkg (setq pkg (make-package name :use '(:cl :regression-test :cl-test)))) (let ((*package* pkg)) (shadow '(#:handler-case #:handler-bind)) (import '(common-lisp-user::compile-and-load) pkg) (import '(cl-test::*universe* cl-test::*mini-universe*) pkg) ) (let ((s (find-symbol "QUIT" "CL-USER"))) (when s (import s :ba-test)))) gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/errors-types-and-class.lsp0000644000000000000000000000013014542551762022720 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.817790612 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/errors-types-and-class.lsp0000644000175000017500000000736314542551762022331 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 30 07:49:10 2005 ;;;; Contains: Tests for non-ansi exceptional situations in Section 4 of CLHS (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; COERCE (def-all-error-test coerce.1 'listp '(coerce t x)) ;;; DEFTYPE (def-error-test deftype.1 (deftype)) (def-error-test deftype.2 (deftype #.(gensym))) (def-error-test deftype.3 (deftype . foo)) (def-all-error-test deftype.4 'symbolp '(deftype x () t)) ;;; SUBTYPEP (def-all-error-test subtypep.1 'type-specifier-p '(subtypep x t)) (def-all-error-test subtypep.2 'type-specifier-p '(subtypep nil x)) ;;; TYPEP (def-all-error-test typep.1 'type-specifier-p '(typep nil x)) ;;; SATISFIES (def-error-test satisfies.1 (typep nil '(satifies))) (def-error-test satisfies.2 (typep nil '(satifies null nil))) (def-all-error-test satisfies.3 'symbolp '(typep nil (satisfies x))) ;;; MEMBER (type specifier) (def-error-test member.type.1 (typep nil 'member)) (def-error-test member.type.2 (typep nil '(member . foo))) (def-error-test member.type.3 (typep nil '(member bar . foo))) ;;; NOT (type specifier) (def-error-test not.type.1 (typep nil 'not)) (def-error-test not.type.2 (typep nil '(not))) (def-error-test not.type.3 (typep nil '(not *))) (def-error-test not.type.4 (typep nil '(not nil nil))) (def-all-error-test not.type.5 'type-specifier-p '(typep nil '(not x))) (def-error-test not.type.6 (typep nil '(not . foo))) ;;; AND (type specifier) (def-error-test and.type.1 (typep nil 'and)) (def-error-test and.type.2 (typep nil '(and *))) (def-error-test and.type.3 (typep nil '(and t * t))) (def-error-test and.type.4 (typep nil '(and . foo))) (def-all-error-test and.type.5 'type-specifier-p '(typep t '(and t t x t))) ;;; OR (type specifier) (def-error-test or.type.1 (typep nil 'or)) (def-error-test or.type.2 (typep nil '(or *))) (def-error-test or.type.3 (typep nil '(or nil * nil))) (def-error-test or.type.4 (typep nil '(or . foo))) (def-all-error-test or.type.5 'type-specifier-p '(typep t '(or nil x nil))) ;;; VALUES (type specifier) (def-error-test values.type.1 (typep nil 'values)) (def-error-test values.type.2 (the values (values))) (def-error-test values.type.3 (the (values . foo) (values))) (def-error-test values.type.4 (the (values *) t)) (def-all-error-test values.type.5 'type-specifier-p '(the (values x) t)) ;;; EQL (type specifier) (def-error-test eql.type.1 (typep nil 'eql)) (def-error-test eql.type.2 (typep nil '(eql))) (def-error-test eql.type.3 (typep nil '(eql nil nil))) (def-error-test eql.type.4 (typep nil '(eql . foo))) ;;; TYPE-ERROR-DATUM (def-all-error-test type-error-datum.1 (typef 'type-error) '(type-error-datum x)) ;;; TYPE-ERROR-EXPECTED-TYPE (def-all-error-test type-error-expected-type.1 (typef 'type-error) '(type-error-expected-type x)) ;;; FUNCTION (type specifier) (def-error-test function.type.1 (locally (declare (type (function . foo) f)) nil)) (def-error-test function.type.2 (locally (declare (type (function () . foo) f)) nil)) (def-error-test function.type.3 (locally (declare (type (function (t . t) t) f)) nil)) (def-error-test function.type.4 (locally (declare (type (function (&optional . foo) t) f)) nil)) (def-error-test function.type.5 (locally (declare (type (function (&rest . foo) t) f)) nil)) (def-error-test function.type.6 (locally (declare (type (function (&key . foo) t) f)) nil)) (def-error-test function.type.7 (locally (declare (type (function (&key :foo) t) f)) nil)) (def-error-test function.type.8 (locally (declare (type (function (&key (:foo . bar)) t) f)) nil)) (def-error-test function.type.9 (locally (declare (type (function (&key (:foo t . bar)) t) f)) nil)) (def-error-test function.type.10 (locally (declare (type (function (&key (:foo t nil)) t) f)) nil)) gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/ba-aux.lsp0000644000000000000000000000013214542551762017556 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/ba-aux.lsp0000644000175000017500000000253714542551762017163 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 30 06:45:08 2005 ;;;; Contains: Aux. files for beyond-ansi tests (in-package :ba-test) (defun function-name-p (x) (or (symbolp x) (and (consp x) (eql (car x) 'setf) (consp (cdr x)) (symbolp (cadr x)) (null (cddr x))))) (defun symbol-or-function-p (x) (or (symbolp x) (and (consp x) (eql (car x) 'function) (consp (cdr x)) (null (cddr x)) (function-name-p (cadr x))))) (defun symbol-or-list-p (x) (or (symbolp x) (listp x))) (defun function-designator-p (x) (or (functionp x) (and (symbolp x) (not (macro-function x)) (not (special-operator-p x))))) (defun type-specifier-p (x) (typep x '(or symbol list class))) (defun causes-error-p (pred formf &key (vals *mini-universe*) (var 'x)) (when (symbolp pred) (assert (fboundp pred)) (setf pred (symbol-function pred))) (loop for x in vals for inner-form = (if (functionp formf) (funcall formf x) (subst `',x var formf)) for form = `(signals-error ,inner-form error) unless (or (funcall pred x) (eval form)) collect x)) (defmacro def-all-error-test (name pred form &rest other-args) `(deftest ,name (causes-error-p ,pred ,form ,@other-args) nil)) (defmacro def-error-test (name form) `(deftest ,name (signals-error ,form error) t)) gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/README0000644000000000000000000000013214542551762016541 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/README0000644000175000017500000000021414542551762016134 0ustar00cammcammThis directory contains tests that go beyond the ANSI CL standard. No conforming implementation is required to be able to pass these tests. gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/errors-data-and-control-flow-3.lsp0000644000000000000000000000013214542551762024147 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/errors-data-and-control-flow-3.lsp0000644000175000017500000002734614542551762023561 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jun 14 07:00:58 2005 ;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS section 5, part 3 (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; CASE (def-error-test case.1 (case . 1)) (def-error-test case.2 (case nil . 1)) (def-error-test case.3 (case nil (nil . 1))) (def-error-test case.4 (case 'x nil)) (def-error-test case.5 (case 'x ((nil . x) 1))) (def-error-test case.6 (case)) ;;; CCASE (def-error-test ccase.1 (ccase . 1)) (def-error-test ccase.2 (let ((x nil)) (ccase x . 1))) (def-error-test ccase.3 (let ((x nil)) (ccase x (nil . 1)))) (def-error-test ccase.4 (let ((x 'x)) (ccase x nil))) (def-error-test ccase.5 (let ((x 'x)) (ccase x ((nil . x) 1)))) (def-error-test ccase.6 (ccase 1 (1 nil))) ;; 1 is not a place! (def-error-test ccase.7 (ccase)) ;;; ECASE (def-error-test ecase.1 (ecase . 1)) (def-error-test ecase.2 (ecase nil . 1)) (def-error-test ecase.3 (ecase nil (nil . 1))) (def-error-test ecase.4 (ecase 'x nil)) (def-error-test ecase.5 (ecase 'x ((nil . x) 1))) (def-error-test ecase.6 (ecase)) ;;; TYPECASE (def-error-test typecase.1 (typecase)) (def-error-test typecase.2 (typecase . :foo)) (def-error-test typecase.3 (typecase 'x . #\X)) (def-error-test typecase.4 (typecase 'x (#.(gensym) t))) (def-error-test typecase.5 (typecase 'x (symbol . :foo))) (def-error-test typecase.6 (typecase 'x . :foo)) (def-error-test typecase.7 (typepcase 'x (t . :foo))) (def-error-test typecase.8 (typepcase 'x (otherwise . :foo))) ;;; CTYPECASE (def-error-test ctypecase.1 (ctypecase)) (def-error-test ctypecase.2 (ctypecase . :foo)) (def-error-test ctypecase.3 (let ((x 'x)) (ctypecase x . #\X))) (def-error-test ctypecase.4 (let ((x 'x)) (ctypecase x (#.(gensym) t)))) (def-error-test ctypecase.5 (let ((x 'x)) (ctypecase x (symbol . :foo)))) (def-error-test ctypecase.6 (let ((x 'x)) (ctypecase x . :foo))) (def-error-test ctypecase.7 (let ((x 'x)) (ctypecase x (t . :foo)))) (def-error-test ctypecase.8 (let ((x 'x)) (ctypecase x (otherwise . :foo)))) (def-error-test ctypecase.9 (ctypecase 1 (integer :bad))) ;;; ETYPECASE (def-error-test etypecase.1 (etypecase)) (def-error-test etypecase.2 (etypecase . :foo)) (def-error-test etypecase.3 (etypecase 'x . #\X)) (def-error-test etypecase.4 (etypecase 'x (#.(gensym) t))) (def-error-test etypecase.5 (etypecase 'x (symbol . :foo))) (def-error-test etypecase.6 (etypecase 'x . :foo)) ;;; MULTIPLE-VALUE-BIND (def-error-test multiple-value-bind.1 (multiple-value-bind)) (def-error-test multiple-value-bind.2 (multiple-value-bind . #.(1+ most-positive-fixnum))) (def-error-test multiple-value-bind.3 (multiple-value-bind (x))) (def-error-test multiple-value-bind.4 (multiple-value-bind (x . y) 1 x)) (def-error-test multiple-value-bind.5 (multiple-value-bind (x) . :foo)) (def-error-test multiple-value-bind.6 (multiple-value-bind (x) nil . :bar)) (def-error-test multiple-value-bind.7 (multiple-value-bind (x) nil "doc string" . 1)) (def-error-test multiple-value-bind.8 (multiple-value-bind (x) nil (declare) . 1)) (def-error-test multiple-value-bind.9 (multiple-value-bind (x) 1 (declare (type symbol x)) x)) (def-error-test multiple-value-bind.10 (multiple-value-bind (x) 1 nil (declare) nil)) (def-error-test multiple-value-bind.11 (multiple-value-bind (x) 1 "foo" "bar" (declare) nil)) ;;; MULTIPLE-VALUE-CALL (def-error-test multiple-value-call.1 (multiple-value-call)) (def-error-test multiple-value-call.2 (multiple-value-call . :x)) (def-error-test multiple-value-call.3 (multiple-value-call 'list . :x)) (def-error-test multiple-value-call.4 (multiple-value-call 'list 1 . :x)) (def-all-error-test multiple-value-call.5 'function-designator-p '(multiple-value-call x nil)) (def-error-test multiple-value-call.6 (multiple-value-call (gensym))) ;;; MULTIPLE-VALUE-LIST (def-error-test multiple-value-list.1 (multiple-value-list)) (def-error-test multiple-value-list.2 (multiple-value-list . 1)) (def-error-test multiple-value-list.3 (multiple-value-list 1 . 2)) (def-error-test multiple-value-list.4 (multiple-value-list 1 2)) ;;; MULTIPLE-VALUE-PROG1 (def-error-test multiple-value-prog1.1 (multiple-value-prog1)) (def-error-test multiple-value-prog1.2 (multiple-value-prog1 . 1)) (def-error-test multiple-value-prog1.3 (multiple-value-prog1 :x . :y)) ;;; MULTIPLE-VALUE-SETQ (def-error-test multiple-value-setq.1 (multiple-value-setq)) (def-error-test multiple-value-setq.2 (let (x) (multiple-value-setq (x)) x)) (def-error-test multiple-value-setq.3 (let (x y) (multiple-value-setq (x . y) nil (list x y)))) (def-all-error-test multiple-value-setq.4 'symbolp #'(lambda (x) `(multiple-value-setq (,x) nil))) (def-all-error-test multiple-value-setq.5 (constantly nil) #'(lambda (x) `(multiple-value-setq (,x) nil)) :vals cl-test::*cl-constant-symbols*) ;;; VALUES (def-all-error-test values.1 'listp #'(lambda (x) (cons 'values x))) (def-all-error-test values.2 'listp #'(lambda (x) (list* 'values 1 x))) ;;; NTH-VALUE (def-error-test nth-value.1 (nth-value)) (def-error-test nth-value.2 (nth-value 0)) (def-error-test nth-value.3 (nth-value 1 '(a b c) 2)) (def-all-error-test nth-value.4 (constantly nil) #'(lambda (x) `(nth-value ',x))) (def-all-error-test nth-value.5 (constantly nil) #'(lambda (x) `(nth-value . ,x))) (def-all-error-test nth-value.6 (constantly nil) #'(lambda (x) `(nth-value 0 . ,x))) (def-all-error-test nth-value.7 'integerp #'(lambda (x) `(nth-value ',x nil))) (def-error-test nth-value.8 (nth-value -1 'x)) (def-all-error-test nth-value.9 'null #'(lambda (x) `(nth-value 0 'a . ,x))) ;;; PROG (def-error-test prog.1 (prog)) (def-all-error-test prog.2 'listp #'(lambda (x) `(prog . ,x))) (def-all-error-test prog.3 'listp #'(lambda (x) `(prog ,x))) (def-all-error-test prog.4 'listp #'(lambda (x) `(prog () . ,x))) (def-all-error-test prog.5 (typef '(or symbol cons)) #'(lambda (x) `(prog (,x)))) (def-all-error-test prog.6 'listp #'(lambda (x) `(prog (v . ,x)))) (def-all-error-test prog.7 'listp #'(lambda (x) `(prog ((v . ,x))))) (def-error-test prog.8 (prog ((x nil nil)))) (def-all-error-test prog.9 'null #'(lambda (x) `(prog ((v nil . ,x))))) ;;; PROG* (def-error-test prog*.1 (prog*)) (def-all-error-test prog*.2 'listp #'(lambda (x) `(prog* . ,x))) (def-all-error-test prog*.3 'listp #'(lambda (x) `(prog* ,x))) (def-all-error-test prog*.4 'listp #'(lambda (x) `(prog* () . ,x))) (def-all-error-test prog*.5 (typef '(or symbol cons)) #'(lambda (x) `(prog* (,x)))) (def-all-error-test prog*.6 'listp #'(lambda (x) `(prog* (v . ,x)))) (def-all-error-test prog*.7 'listp #'(lambda (x) `(prog* ((v . ,x))))) (def-error-test prog*.8 (prog* ((x nil nil)))) (def-all-error-test prog*.9 'null #'(lambda (x) `(prog* ((v nil . ,x))))) ;;; PROG1 (def-error-test prog1.1 (prog1)) (def-all-error-test prog1.2 #'listp #'(lambda (x) `(prog1 . ,x))) (def-all-error-test prog1.3 #'listp #'(lambda (x) `(prog1 nil . ,x))) ;;; PROG2 (def-error-test prog2.1 (prog2)) (def-all-error-test prog2.2 #'listp #'(lambda (x) `(prog2 . ,x))) (def-error-test prog2.3 (prog2 t)) (def-all-error-test prog2.4 #'listp #'(lambda (x) `(prog2 nil . ,x))) (def-all-error-test prog2.5 #'listp #'(lambda (x) `(prog2 'a 'b . ,x))) (def-all-error-test prog2.6 #'listp #'(lambda (x) `(prog2 'a 'b nil . ,x))) ;;; PROGN (def-all-error-test progn.1 'listp #'(lambda (x) `(progn . ,x))) (def-all-error-test progn.2 'listp #'(lambda (x) `(progn nil . ,x))) (def-all-error-test progn.3 'listp #'(lambda (x) `(progn 'a 'b . ,x))) ;;; DEFINE-MODIFY-MACRO (def-error-test define-modify-macro.1 (define-modify-macro)) (def-error-test define-modify-macro.2 (define-modify-macro #.(gensym))) (def-all-error-test define-modify-macro.3 'symbolp #'(lambda (x) `(define-modify-macro ,x ()))) (def-all-error-test define-modify-macro.4 'listp #'(lambda (x) `(define-modify-macro #.(gensym) ,x))) (def-all-error-test define-modify-macro.5 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () . ,x))) (def-all-error-test define-modify-macro.6 'symbolp #'(lambda (x) `(define-modify-macro #.(gensym) () ,x))) (def-all-error-test define-modify-macro.7 'stringp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) ,x))) (def-all-error-test define-modify-macro.8 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) . ,x))) (def-all-error-test define-modify-macro.9 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) "foo" . ,x))) (def-all-error-test define-modify-macro.10 (constantly nil) #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) "foo" ,x))) ;;; DEFSETF (def-error-test defsetf.1 (defsetf)) (def-error-test defsetf.2 (defsetf #.(gensym))) (def-all-error-test defsetf.3 'listp #'(lambda (x) `(defsetf ,x))) (def-all-error-test defsetf.4 'listp #'(lambda (x) `(defsetf #.(gensym) . ,x))) (def-all-error-test defsetf.5 'listp #'(lambda (x) `(defsetf #.(gensym) #.(gensym) . ,x))) (def-all-error-test defsetf.6 'stringp #'(lambda (x) `(defsetf #.(gensym) #.(gensym) ,x))) (def-all-error-test defsetf.7 'null #'(lambda (x) `(defsetf #.(gensym) #.(gensym) "foo" . ,x))) (def-all-error-test defsetf.8 (constantly nil) #'(lambda (x) `(defsetf #.(gensym) #.(gensym) "foo" ,x))) (def-all-error-test defsetf.9 (typef '(or list symbol)) #'(lambda (x) `(defsetf #.(gensym) ,x))) ;;; Need long form defsetf error tests ;;; FIXME: add tests for defsetf-lambda-lists (def-all-error-test defsetf.10 'symbolp #'(lambda (x) `(defsetf #.(gensym) (#1=#.(gensym)) (,x) #1#))) (def-all-error-test defsetf.11 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) ., x))) (def-all-error-test defsetf.12 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) , x))) (def-all-error-test defsetf.13 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) (a . ,x)))) (def-error-test defsetf.14 (defsetf #.(gensym) () () nil (declare (optimize)) nil)) (def-error-test defsetf.15 (defsetf #.(gensym) () () "foo" "bar" (declare (optimize)) nil)) ;;; FIXME -- Add tests for DEFINE-SETF-EXPANDER (def-error-test get-setf-expansion.1 (get-setf-expansion)) (def-all-error-test get-setf-expansion.2 'listp #'(lambda (x) `(get-setf-expansion . ,x))) (def-all-error-test get-setf-expansion.3 (typef '(or list symbol)) #'(lambda (x) `(get-setf-expansion ,x))) ;;; FIXME -- figure out how to test for invalid environment objects ;;; Must make an assumption about what can be an environment ;;; SETF tests (def-all-error-test setf.1 (constantly nil) #'(lambda (x) `(setf ,x))) (def-all-error-test setf.2 'listp #'(lambda (x) `(setf . ,x))) (def-all-error-test setf.3 'listp #'(lambda (x) `(setf ,x nil))) (def-all-error-test setf.4 'listp #'(lambda (x) `(let (a) (setf a . ,x)))) ;;; PSETF tests (def-all-error-test psetf.1 (constantly nil) #'(lambda (x) `(psetf ,x))) (def-all-error-test psetf.2 'listp #'(lambda (x) `(psetf . ,x))) (def-all-error-test psetf.3 'listp #'(lambda (x) `(psetf ,x nil))) (def-all-error-test psetf.4 'listp #'(lambda (x) `(let (a) (psetf a . ,x)))) ;;; SHIFTF tests (def-error-test shiftf.1 (shiftf)) (def-all-error-test shiftf.2 'listp #'(lambda (x) `(shiftf . ,x))) (def-all-error-test shiftf.3 (constantly nil) #'(lambda (x) `(shiftf ,x))) (def-all-error-test shiftf.4 'listp #'(lambda (x) `(let (a) (shiftf a . ,x)))) (def-all-error-test shiftf.5 'listp #'(lambda (x) `(shiftf ,x nil))) (def-all-error-test shiftf.6 'listp #'(lambda (x) `(let (a b) (shiftf a b . ,x)))) (def-all-error-test shiftf.7 'listp #'(lambda (x) `(let (a) (shiftf ,x a nil)))) (def-all-error-test shiftf.8 'listp #'(lambda (x) `(let (a) (shiftf a ,x nil)))) ;;; ROTATEF tests (def-all-error-test rotatef.1 'listp #'(lambda (x) `(rotatef . ,x))) (def-all-error-test rotatef.2 'listp #'(lambda (x) `(rotatef ,x))) (def-all-error-test rotatef.3 'listp #'(lambda (x) `(let (a) (rotatef a ,x)))) (def-all-error-test rotatef.4 'listp #'(lambda (x) `(let (a) (rotatef a . ,x)))) (def-all-error-test rotatef.5 'listp #'(lambda (x) `(let (a) (rotatef ,x a)))) gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/errors-data-and-control-flow-2.lsp0000644000000000000000000000013214542551762024146 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/errors-data-and-control-flow-2.lsp0000644000175000017500000002346714542551762023560 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 31 08:08:49 2005 ;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 2 (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; FUNCALL (def-all-error-test funcall.1 'function-designator-p '(funcall x)) (def-error-test funcall.2 (funcall cons 1 . 2)) ;;; FUNCTION (def-error-test function.1 (function)) (def-error-test function.2 (function . cons)) (def-error-test function.3 (function cons . foo)) (def-error-test function.4 (function cons nil)) (def-all-error-test function.5 'function-name-p '(function x)) (def-all-error-test function.6 (constantly nil) #'(lambda (x) `(function ,x)) :vals cl-test::*cl-macro-symbols*) (def-all-error-test function.7 (constantly nil) #'(lambda (x) `(function ,x)) :vals cl-test::*cl-special-operator-symbols*) (def-error-test function.8 (macrolet ((%m () nil)) #'%m)) ;;; FUNCTION-LAMBDA-EXPRESSION (def-all-error-test function-lambda-expression.1 'functionp '(function-lambda-expression x)) ;;; DEFCONSTANT (def-error-test defconstant.1 (defconstant)) (def-error-test defconstant.2 (defconstant . foo)) (def-error-test defconstant.3 (defconstant #.(gensym))) (def-error-test defconstant.4 (defconstant #.(gensym) . foo)) (def-error-test defconstant.5 (defconstant #.(gensym) nil . foo)) (def-error-test defconstant.6 (defconstant #.(gensym) nil "foo" . bar)) (def-all-error-test defconstant.7 'symbolp #'(lambda (x) `(defconstant ,x nil))) (def-all-error-test defconstant.8 'stringp #'(lambda (x) `(defconstant ,(gensym) nil ,x))) ;;; DEFPARAMETER (def-error-test defparameter.1 (defparameter)) (def-error-test defparameter.2 (defparameter . foo)) (def-error-test defparameter.3 (defparameter #.(gensym))) (def-error-test defparameter.4 (defparameter #.(gensym) . foo)) (def-error-test defparameter.5 (defparameter #.(gensym) nil . foo)) (def-error-test defparameter.6 (defparameter #.(gensym) nil "foo" . bar)) (def-all-error-test defparameter.7 'symbolp #'(lambda (x) `(defparameter ,x nil))) (def-all-error-test defparameter.8 'stringp #'(lambda (x) `(defparameter ,(gensym) nil ,x))) ;;; DEFVAR (def-error-test defvar.1 (defvar)) (def-error-test defvar.2 (defvar . foo)) (def-error-test defvar.4 (defvar #.(gensym) . foo)) (def-error-test defvar.5 (defvar #.(gensym) nil . foo)) (def-error-test defvar.6 (defvar #.(gensym) nil "foo" . bar)) (def-all-error-test defvar.7 'symbolp #'(lambda (x) `(defvar ,x nil))) (def-all-error-test defvar.8 'stringp #'(lambda (x) `(defvar ,(gensym) nil ,x))) ;;; DESTRUCTURING-BIND (def-error-test destructuring-bind.1 (destructuring-bind)) (def-error-test destructuring-bind.2 (destructuring-bind x)) (def-all-error-test destructuring-bind.3 (typef '(or symbol cons)) #'(lambda (x) `(destructuring-bind ,x nil))) (def-error-test destructuring-bind.4 (destructuring-bind (x) '(a) nil (declare) x)) ;;; LET (def-error-test let.1 (let)) (def-error-test let.2 (let . x)) (def-all-error-test let.3 'listp #'(lambda (x) `(let ,x nil))) (def-error-test let.4 (let () . x)) (def-error-test let.5 (let (x . 1) nil)) (def-error-test let.6 (let ((x) . y) nil)) (def-error-test let.7 (let ((x 1 . 2)) nil)) (def-error-test let.8 (let ((x 1 2)) nil)) (def-error-test let.9 (let ((x 1) (x 2)) x)) (def-error-test let.10 (let ((t 1)) t)) (def-all-error-test let.11 (typef '(or cons symbol)) #'(lambda (x) `(let (,x) nil))) (def-all-error-test let.12 'symbolp #'(lambda (x) `(let ((,x)) nil))) (def-error-test let.13 (let ((x 0) (x 1)) x)) ;;; LET* (def-error-test let*.1 (let*)) (def-error-test let*.2 (let* . x)) (def-all-error-test let*.3 'listp #'(lambda (x) `(let* ,x nil))) (def-error-test let*.4 (let* () . x)) (def-error-test let*.5 (let* (x . 1) nil)) (def-error-test let*.6 (let* ((x) . y) nil)) (def-error-test let*.7 (let* ((x 1 . 2)) nil)) (def-error-test let*.8 (let* ((x 1 2)) nil)) (def-error-test let*.10 (let* ((t 1)) t)) (def-all-error-test let*.11 (typef '(or cons symbol)) #'(lambda (x) `(let* (,x) nil))) (def-all-error-test let*.12 'symbolp #'(lambda (x) `(let* ((,x)) nil))) ;;; PROGV (def-error-test progv.1 (progv)) (def-error-test progv.2 (progv '(a))) (def-all-error-test progv.3 'listp '(progv x nil nil)) (def-all-error-test progv.4 'listp '(progv '(a) x nil)) ;;; SETQ (def-error-test setq.1 (setq . x)) (def-error-test setq.2 (let ((x t)) (setq x))) (def-error-test setq.3 (let ((x t)) (setq x . foo))) (def-error-test setq.4 (let ((x 1)) (setq x nil . foo))) (def-error-test setq.5 (let ((x 1) (y 2)) (setq x nil y))) (def-all-error-test setq.6 'symbolp #'(lambda (x) `(setq ,x nil))) (def-error-test setq.7 (let ((sym (gensym))) (eval `(defconstant ,sym nil)) (eval `(setq ,sym t)) (eval sym))) ;;; PSETQ (def-error-test psetq.1 (psetq . x)) (def-error-test psetq.2 (let ((x t)) (psetq x))) (def-error-test psetq.3 (let ((x t)) (psetq x . foo))) (def-error-test psetq.4 (let ((x 1)) (psetq x nil . foo))) (def-error-test psetq.5 (let ((x 1) (y 2)) (psetq x nil y))) (def-all-error-test psetq.6 'symbolp #'(lambda (x) `(psetq ,x nil))) (def-error-test psetq.7 (let ((sym (gensym))) (eval `(defconstant ,sym nil)) (eval `(psetq ,sym t)) (eval sym))) ;;; I suggest it would be useful for PSETQ to detect when it is ;;; being asked to assign to the same variable twice, since this ;;; isn't well defined. (def-error-test psetq.8 (let ((x 0)) (psetq x 1 x 2) x)) ;;; BLOCK (def-error-test block.1 (block)) (def-error-test block.2 (block . foo)) (def-all-error-test block.3 'symbolp #'(lambda (x) `(block ,x))) (def-error-test block.4 (block nil . foo)) ;;; CATCH (def-error-test catch.1 (catch)) (def-error-test catch.2 (catch . foo)) (def-error-test catch.3 (catch 'tag . foo)) (def-all-error-test catch.4 (constantly nil) '(catch x (throw x nil)) :vals *cl-symbols*) ;;; GO (def-error-test go.1 (go)) (def-error-test go.2 (go . foo)) (def-all-error-test go.3 (typef '(or symbol integer)) #'(lambda (x) `(go ,x))) (def-error-test go.4 (tagbody (go done . foo) done)) (def-error-test go.5 (tagbody (go done foo) done)) ;;; RETURN-FROM (def-error-test return-from.1 (return-from)) (def-error-test return-from.2 (return-from . foo)) (def-error-test return-from.3 (return-from foo)) (def-error-test return-from.4 (block foo (return-from foo . t))) (def-error-test return-from.5 (block foo (return-from foo nil . 2))) (def-error-test return-from.6 (block foo (return-from foo nil 3))) ;;; RETURN (def-error-test return.1 (return . x)) (def-error-test return.2 (return nil . x)) ;;; TAGBODY (def-error-test tagbody.1 (tagbody . x)) (def-all-error-test tagbody.2 (typef '(or symbol integer cons)) #'(lambda (x) `(tagbody ,x))) ;;; THROW (def-error-test throw.1 (throw)) (def-error-test throw.2 (throw . x)) (def-error-test throw.3 (catch 'a (throw 'a))) (def-error-test throw.4 (catch 'a (throw 'a . x))) (def-error-test throw.5 (catch 'a (throw 'a 1 . x))) (def-error-test throw.6 (catch 'a (throw 'a 1 'x))) ;;; UNWIND-PROTECT (def-error-test unwind-protect.1 (unwind-protect)) (def-error-test unwind-protect.2 (unwind-protect . x)) (def-error-test unwind-protect.3 (unwind-protect nil . x)) ;;; NOT (def-error-test not.1 (not . x)) (def-error-test not.2 (not nil . x)) ;;; EQ (def-error-test eq.1 (eq . 1)) (def-error-test eq.2 (eq 'x . 2)) (def-error-test eq.3 (eq :foo 2 . 17)) ;;; EQL (def-error-test eql.1 (eql . 1)) (def-error-test eql.2 (eql 'x . 2)) (def-error-test eql.3 (eql :foo 2 . 17)) ;;; EQUAL (def-error-test equal.1 (equal . 1)) (def-error-test equal.2 (equal 'x . 2)) (def-error-test equal.3 (equal :foo 2 . 17)) ;;; EQUALP (def-error-test equalp.1 (equalp . 1)) (def-error-test equalp.2 (equalp 'x . 2)) (def-error-test equalp.3 (equalp :foo 2 . 17)) ;;; IDENTITY (def-error-test identity.1 (identity . 0)) (def-error-test identity.2 (identity 0 . "foo")) ;;; COMPLEMENT (def-error-test complement.1 (complement . 1.2)) (def-error-test complement.2 (complement #'plusp . #(1 2))) (def-error-test complement.3 (complement #'zerop #*110101 . #c(1 2))) (def-all-error-test complement.4 'functionp '(complement x)) ;;; CONSTANTLY (def-error-test constantly.1 (constantly . 1/2)) (def-error-test constantly.2 (constantly :foo . 1/2)) ;;; EVERY (def-error-test every.1 (every . :foo)) (def-error-test every.2 (every 'null . (list))) (def-error-test every.3 (every (gensym) '(a b c d))) ;;; SOME (def-error-test some.1 (some . :foo)) (def-error-test some.2 (some 'null . (list))) (def-error-test some.3 (some (gensym) '(a b c d))) ;;; NOTEVERY (def-error-test notevery.1 (notevery . :foo)) (def-error-test notevery.2 (notevery 'null . (list))) (def-error-test notevery.3 (notevery (gensym) '(a b c d))) ;;; NOTANY (def-error-test notany.1 (notany . :foo)) (def-error-test notany.2 (notany 'null . (list))) (def-error-test notany.3 (notany (gensym) '(a b c d))) ;;; AND (def-error-test and.1 (and . #.(make-hash-table))) (def-error-test and.2 (and t . :foo)) ;;; COND (def-error-test cond.1 (cond . 1)) (def-error-test cond.2 (cond (t . 2))) (def-error-test cond.3 (cond nil)) (def-error-test cond.4 (cond (nil) . "foo")) ;;; IF (def-error-test if.1 (if)) (def-error-test if.2 (if . t)) (def-error-test if.3 (if t)) (def-error-test if.4 (if nil)) (def-error-test if.5 (if t . 1)) (def-error-test if.6 (if nil . 2)) (def-error-test if.7 (if t 1 . 2)) (def-error-test if.8 (if nil #\x . #\y)) (def-error-test if.9 (if t 1 2 . 3)) (def-error-test if.10 (if nil #\x #\y . 1.23d4)) (def-error-test if.11 (if t 1 2 3)) (def-error-test if.12 (if nil #\x #\y nil nil nil)) ;;; OR (def-error-test or.1 (or . :foo)) (def-error-test or.2 (or nil . :bar)) ;;; WHEN (def-error-test when.1 (when)) (def-error-test when.2 (when . #\$)) (def-error-test when.3 (when t . x)) (def-error-test when.4 (when t nil . "A")) ;;; UNLESS (def-error-test unless.1 (unless)) (def-error-test unless.2 (unless . #*1011)) (def-error-test unless.3 (unless nil . t)) (def-error-test unless.4 (unless nil nil . #())) gcl-2.7.1/ansi-tests/beyond-ansi/PaxHeaders/errors-loop.lsp0000644000000000000000000000013014542551762020662 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/beyond-ansi/errors-loop.lsp0000644000175000017500000000502114542551762020260 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS for the LOOP macro (in-package :ba-test) (compile-and-load "ba-aux.lsp") ;;; LOOP tests (def-all-error-test loop.1 'listp #'(lambda (x) `(loop . ,x))) (def-all-error-test loop.named.1 'symbolp #'(lambda (x) `(loop named ,x return nil))) (def-all-error-test loop.named.2 'listp #'(lambda (x) `(loop named . ,x))) (def-error-test loop.with.1 (loop with)) (def-all-error-test loop.with.2 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(loop with ,x))) (def-all-error-test loop.with.3 'listp #'(lambda (x) `(loop with . ,x))) (def-all-error-test loop.with.4 'listp #'(lambda (x) `(loop with x . ,x))) (def-all-error-test loop.with.5 'listp #'(lambda (x) `(loop with x = . ,x))) (def-all-error-test loop.with.6 'listp #'(lambda (x) `(loop with x t = . ,x))) (def-error-test loop.initially.1 (loop initially)) (def-all-error-test loop.initially.2 'listp #'(lambda (x) `(loop initially . ,x))) (def-all-error-test loop.initially.3 'listp #'(lambda (x) `(loop initially (progn) . ,x))) (def-error-test loop.finally.1 (loop finally)) (def-all-error-test loop.finally.2 'listp #'(lambda (x) `(loop finally . ,x))) (def-all-error-test loop.finally.3 'listp #'(lambda (x) `(loop finally (progn) . ,x))) ;;; LOOP FOR clauses (def-error-test loop.for.1 (loop for)) (def-all-error-test loop.for.2 'listp #'(lambda (x) `(loop for . ,x))) (def-all-error-test loop.for.3 'symbol-or-list-p #'(lambda (x) `(loop for ,x))) (def-all-error-test loop.for.4 'symbol-or-list-p #'(lambda (x) `(loop for ,x = nil))) (def-error-test loop.for.5 (loop for x from)) (def-error-test loop.for.6 (loop for x upfrom)) (def-error-test loop.for.7 (loop for x downfrom)) (def-error-test loop.for.8 (loop for x upto)) (def-error-test loop.for.9 (loop for x to)) (def-error-test loop.for.10 (loop for x below)) (def-all-error-test loop.for.11 (typef '(or symbol list class)) #'(lambda (x) `(loop for e ,x = nil return e))) (def-all-error-test loop.for.12 'listp #'(lambda (x) `(loop for x . ,x))) (def-all-error-test loop.for.13 'listp #'(lambda (x) `(loop for x from . ,x))) (def-all-error-test loop.for.14 'listp #'(lambda (x) `(loop for x downfrom . ,x))) (def-all-error-test loop.for.15 'listp #'(lambda (x) `(loop for x upfrom . ,x))) (def-all-error-test loop.for.16 'listp #'(lambda (x) `(loop for x upto . ,x))) (def-all-error-test loop.for.17 'listp #'(lambda (x) `(loop for x to . ,x))) (def-all-error-test loop.for.18 'listp #'(lambda (x) `(loop for x downto . ,x))) gcl-2.7.1/ansi-tests/PaxHeaders/format-logical-block.lsp0000644000000000000000000000013214542551762020161 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.821790629 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-logical-block.lsp0000644000175000017500000001674614542551762017575 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 8 12:17:31 2004 ;;;; Contains: Tests of the ~< ~:> format directives (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Error cases ;;; Prefix and suffix cannot contain format directives (deftest format.logical-block.error.1 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.2 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.3 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.4 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.5 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.6 (signals-error-always (format nil "~" '(X) '(Y)) error) t t) (deftest format.logical-block.error.7 (signals-error-always (format nil "~<~;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.8 (signals-error-always (format nil "~<~@;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.9 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.10 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.11 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.12 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.13 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.14 (signals-error-always (format nil "~:" '(X) '(Y)) error) t t) (deftest format.logical-block.error.15 (signals-error-always (format nil "~:<~;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.16 (signals-error-always (format nil "~:<~@;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.17 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.18 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.19 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.20 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.21 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.22 (signals-error-always (format nil "~@" '(X) '(Y)) error) t t) (deftest format.logical-block.error.23 (signals-error-always (format nil "~@<~;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.24 (signals-error-always (format nil "~@<~@;~A~;bar~A~:>" '(X) '(Y)) error) t t) (deftest format.logical-block.error.25 (signals-error-always (format nil "1~Z~>2" nil nil nil) error) t t) ;;; "an error is also signaled if the ~<...~:;...~> form of ~<...~> is used ;;; in the same format string with ~W, ~_, ~<...~:>, ~I, or ~:T." (deftest format.logical-block.error.26 (signals-error-always (format nil "~<~:;~>~<~:>" nil nil nil) error) t t) (deftest format.logical-block.error.27 (signals-error-always (format nil "~<~:>~<~:;~>" nil nil nil) error) t t) ;;; Non-error tests (def-pprint-test format.logical-block.1 (format nil "~<~A~:>" '(nil)) "NIL") (def-pprint-test format.logical-block.2 (format nil "~@<~A~:>" nil) "NIL") (def-pprint-test format.logical-block.3 (format nil "~:<~A~:>" '(nil)) "(NIL)") (def-pprint-test format.logical-block.4 (format nil "~:@<~A~:>" nil) "(NIL)") (def-pprint-test format.logical-block.5 (format nil "~@:<~A~:>" nil) "(NIL)") (def-pprint-test format.logical-block.6 (format nil "~<~@{~A~^*~}~:>" '(1 2 3)) "1*2*3") (def-pprint-test format.logical-block.7 (format nil "~:<~@{~A~^*~}~:>" '(1 2 3)) "(1*2*3)") (def-pprint-test format.logical-block.8 (format nil "~:<~@{~A~^*~}~:>" 1) "1") (def-pprint-test format.logical-block.9 (format nil "~<~;~A~;~:>" '(1 2 3)) "1") (def-pprint-test format.logical-block.10 (format nil "~<~;~A~:>" '(1 2 3)) "1") (def-pprint-test format.logical-block.11 (format nil "~@<~;~A~;~:>" '(1 2 3)) "(1 2 3)") (def-pprint-test format.logical-block.12 (format nil "~@<~;~A~:>" '(1 2 3)) "(1 2 3)") (def-pprint-test format.logical-block.13 (format nil "~:<[~;~@{~A~^/~}~:>" '(1 2 3)) "[1/2/3)") (def-pprint-test format.logical-block.14 (format nil "~:<~;~@{~A~^/~}~;]~:>" '(1 2 3)) "1/2/3]") (def-pprint-test format.logical-block.15 (format nil "~:<[~;~@{~A~^/~}~;]~:>" '(1 2 3)) "[1/2/3]") (def-pprint-test format.logical-block.16 (format nil "~@<~@{~A~^*~}~:>" 1 2 3) "1*2*3") (def-pprint-test format.logical-block.17 (format nil "~@<~@{~A~^ ~_~}~:>" 1 2 3) "1 2 3") (def-pprint-test format.logical-block.18 (format nil "~@<~@{~A~^ ~_~}~:>" 1 2 3) "1 2 3" :margin 2) (def-pprint-test format.logical-block.19 (format nil "~:@<~@{~A~^ ~_~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.20 (format nil "~@:<~@{~A~^ ~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.21 (format nil "~@:<~@{~A~^ ~:_~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.22 (format nil "~:@<~@{~A~^ ~}~:@>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.23 (format nil "~:@<~@{~A~^/~ ~}~:@>" 1 2 3) "(1/2/3)" :margin 2) (def-pprint-test format.logical-block.24 (format nil "~:@<~@{~A~^ ~:_~}~:>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.25 (format nil "~:@<~@{~A~^ ~}~:@>" 1 2 3) "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.26 (format nil "~:@<~@{~A~^~}~:@>" "1 2 3") "(1 2 3)" :margin 2) (def-pprint-test format.logical-block.27 (format nil "~@<**~@;~@{~A~^ ~}~:@>" 1 2 3) "**1 **2 **3" :margin 3) (def-pprint-test format.logical-block.28 (format nil "~@<**~@;~@{~A~^ ~}~;XX~:@>" 1 2 3) "**1 **2 **3XX" :margin 3) (def-pprint-test format.logical-block.29 (format nil "~:@<**~@;~@{~A~^ ~}~:@>" 1 2 3) "**1 **2 **3)" :margin 3) ;;; Circularity detection (def-pprint-test format.logical-block.circle.1 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (list x x))) "(#1=(0) #1#)" :circle t) (def-pprint-test format.logical-block.circle.2 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (cons x x))) "(#1=(0) . #1#)" :circle t) (def-pprint-test format.logical-block.circle.3 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (setf (cdr x) x) x)) "#1=(0 . #1#)" :circle t :len 500) (def-pprint-test format.logical-block.circle.4 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (list x x))) "((0) (0))") (def-pprint-test format.logical-block.circle.5 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (cons x x))) "((0) 0)") ;;; ~^ terminates a logical block (def-pprint-test format.logical-block.escape.1 (format nil "~<~A~^xxxx~:>" '(1)) "1") (def-pprint-test format.logical-block.escape.2 (format nil "~<~<~A~^xxx~:>yyy~:>" '((1))) "1yyy") gcl-2.7.1/ansi-tests/PaxHeaders/symbolp.lsp0000644000000000000000000000013114542551763015656 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/symbolp.lsp0000644000175000017500000000104314542551763015253 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 22 08:59:12 2003 ;;;; Contains: Tests for SYMBOLP (in-package :cl-test) (deftest symbolp.1 (notnot-mv (symbolp nil)) t) (deftest symbolp.2 (check-predicate #'symbolp nil *symbols*) nil) (deftest symbolp.3 (check-predicate (complement #'symbolp) #'(lambda (x) (member x *symbols*))) nil) ;;; Error cases (deftest symbolp.error.1 (signals-error (symbolp) program-error) t) (deftest symbolp.error.2 (signals-error (symbolp nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/make-instance.lsp0000644000000000000000000000013214542551763016711 xustar0030 mtime=1703597043.000022426 30 atime=1744294960.821790629 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/make-instance.lsp0000644000175000017500000001431314542551763016311 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon May 12 21:19:36 2003 ;;;; Contains: Tests of MAKE-INSTANCE (in-package :cl-test) ;;; MAKE-INSTANCE is used in many other tests as well (deftest make-instance.error.1 (signals-error (make-instance) program-error) t) (defclass make-instance-class-01 () ((a :initarg :a) (b :initarg :b))) (deftest make-instance.error.2 (signals-error (make-instance 'make-instance-class-01 :a) program-error) t) (deftest make-instance.error.3 (handler-case (progn (eval '(make-instance 'make-instance-class-01 :z 1)) t) (error () :good)) :good) (deftest make-instance.error.4 (handler-case (progn (eval '(make-instance (find-class 'make-instance-class-01) :z 1)) t) (error () :good)) :good) (deftest make-instance.error.5 (signals-error (let () (make-instance) nil) program-error) t) (deftest make-instance.error.6 (loop for cl in *built-in-classes* unless (eval `(signals-error (make-instance ',cl) error)) collect cl) nil) ;; Definitions of methods (defmethod make-instance ((x make-instance-class-01) &rest initargs &key &allow-other-keys) initargs) (deftest make-instance.1 (make-instance (make-instance 'make-instance-class-01)) nil) (deftest make-instance.2 (make-instance (make-instance 'make-instance-class-01) :a 1 :b 2) (:a 1 :b 2)) #| (when *can-define-metaclasses* (defclass make-instance-class-02 () (a b c) (:metaclass substandard-class)) (defmethod make-instance ((class (eql (find-class 'make-instance-class-02))) &rest initargs &key (x nil) (y nil) (z nil) &allow-other-keys) (declare (ignore initargs)) (let ((obj (allocate-instance class))) (setf (slot-value obj 'a) x (slot-value obj 'b) y (slot-value obj 'c) z) obj)) (deftest make-instance.3 (let ((obj (make-instance 'make-instance-class-02))) (values (eqt (class-of obj) (find-class 'make-instance-class-02)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) t nil nil nil) (deftest make-instance.4 (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd))) (values (eqt (class-of obj) (find-class 'make-instance-class-02)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) t d 45 10) (deftest make-instance.5 (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g))) (values (eqt (class-of obj) (find-class 'make-instance-class-02)) (slot-value obj 'a) (slot-value obj 'b) (slot-value obj 'c))) t nil g nil) (deftest make-instance.6 (eq (make-instance 'make-instance-class-02) (make-instance 'make-instance-class-02)) nil) ;; Customization of make-instance (defclass make-instance-class-03 () ((a :initform 1) (b :initarg :b) c) (:metaclass substandard-class)) (defmethod make-instance ((class (eql (find-class 'make-instance-class-03))) &rest initargs &key (x nil x-p) (y nil y-p) (z nil z-p) &allow-other-keys) (declare (ignore initargs)) (let ((obj (allocate-instance (find-class 'make-instance-class-03)))) (when x-p (setf (slot-value obj 'a) x)) (when y-p (setf (slot-value obj 'b) y)) (when z-p (setf (slot-value obj 'c) z)) obj)) (deftest make-instance.7 (let ((obj (make-instance 'make-instance-class-03))) (values (eqt (class-of obj) (find-class 'make-instance-class-03)) (map-slot-boundp* obj '(a b c)))) t (nil nil nil)) (deftest make-instance.8 (let* ((class (find-class 'make-instance-class-03)) (obj (make-instance class :b 10))) (values (eqt (class-of obj) class) (map-slot-boundp* obj '(a b c)))) t (nil nil nil)) (deftest make-instance.9 (let* ((class (find-class 'make-instance-class-03)) (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) (values (eqt (class-of obj) class) (map-slot-boundp* obj '(a b c)) (map-slot-value obj '(a b c)))) t (t t t) (g k i)) ;; After method combination (defparameter *make-instance-class-04-var* 0) (defclass make-instance-class-04 () ((a :initform *make-instance-class-04-var*)) (:metaclass substandard-class)) (defmethod make-instance :after ((class (eql (find-class 'make-instance-class-04))) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (incf *make-instance-class-04-var* 10)) (deftest make-instance.10 (let* ((*make-instance-class-04-var* 0) (obj (make-instance 'make-instance-class-04))) (values (slot-value obj 'a) *make-instance-class-04-var*)) 0 10) ;; Around method combination (defclass make-instance-class-05 () ((a :initarg :a) (b :initarg :b :initform 'foo) c) (:metaclass substandard-class)) (defmethod make-instance :around ((class (eql (find-class 'make-instance-class-05))) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (let ((obj (call-next-method))) (setf (slot-value obj 'c) 'bar) obj)) (deftest make-instance.11 (let ((obj (make-instance 'make-instance-class-05))) (values (map-slot-boundp* obj '(a b c)) (map-slot-value obj '(b c)))) (nil t t) (foo bar)) ) |# ;;; Order of argument evaluation (deftest make-instance.order.1 (let* ((i 0) x y (obj (make-instance 'make-instance-class-01 :a (setf x (incf i)) :b (setf y (incf i))))) (values (map-slot-value obj '(a b)) i x y)) (1 2) 2 1 2) (deftest make-instance.order.2 (let* ((i 0) x y z w (obj (make-instance 'make-instance-class-01 :a (setf x (incf i)) :b (setf y (incf i)) :b (setf z (incf i)) :a (setf w (incf i))))) (values (map-slot-value obj '(a b)) i x y z w)) (1 2) 4 1 2 3 4) (deftest make-instance.order.3 (let* ((i 0) u x y z w (obj (make-instance (prog1 'make-instance-class-01 (setf u (incf i))) :a (setf x (incf i)) :b (setf y (incf i)) :b (setf z (incf i)) :a (setf w (incf i))))) (values (map-slot-value obj '(a b)) i u x y z w)) (2 3) 5 1 2 3 4 5) gcl-2.7.1/ansi-tests/PaxHeaders/vector-push.lsp0000644000000000000000000000013214542551763016451 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/vector-push.lsp0000644000175000017500000001662414542551763016060 0ustar00cammcamm;-*- 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 (signals-error (vector-push) program-error) t) (deftest vector-push.error.15 (signals-error (vector-push (vector 1 2 3)) program-error) t) (deftest vector-push.error.16 (signals-error (vector-push (vector 1 2 3) 4 nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/tan.lsp0000644000000000000000000000013114542551763014753 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.821790629 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/tan.lsp0000644000175000017500000000563514542551763014363 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 9 20:55:40 2004 ;;;; Contains: Tests of TAN (in-package :cl-test) (deftest tan.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (tan i)) for y = (car rlist) always (and (null (cdr rlist)) (or (rationalp y) (typep y 'single-float)))) t) (deftest tan.2 (loop for x = (- (random 2000.0s0) 1000.0s0) for y = (safe-tan x 0.0s0) repeat 1000 always (typep y 'short-float)) t) (deftest tan.3 (loop for x = (- (random 2000.0f0) 1000.0f0) for y = (safe-tan x 0.0) repeat 1000 always (typep y 'single-float)) t) (deftest tan.4 (loop for x = (- (random 2000.0d0) 1000.0d0) for y = (safe-tan x 0.0d0) repeat 1000 always (typep y 'double-float)) t) (deftest tan.5 (loop for x = (- (random 2000.0l0) 1000.0l0) for y = (safe-tan 0.0l0) repeat 1000 always (typep y 'long-float)) t) (deftest tan.6 (let ((r (tan 0))) (or (eqlt r 0) (eqlt r 0.0))) t) (deftest tan.7 (tan 0.0s0) 0.0s0) (deftest tan.8 (tan 0.0) 0.0) (deftest tan.9 (tan 0.0d0) 0.0d0) (deftest tan.10 (tan 0.0l0) 0.0l0) (deftest tan.11 (loop for i from 1 to 100 unless (approx= (tan i) (tan (coerce i 'single-float))) collect i) nil) (deftest tan.12 (approx= (tan (coerce (/ pi 4) 'single-float)) 1.0) t) (deftest tan.13 (approx= (tan (coerce (/ pi -4) 'single-float)) -1.0) t) (deftest tan.14 (approx= (tan (coerce (/ pi 4) 'short-float)) 1s0) t) (deftest tan.15 (approx= (tan (coerce (/ pi -4) 'short-float)) -1s0) t) (deftest tan.16 (approx= (tan (coerce (/ pi 4) 'double-float)) 1d0) t) (deftest tan.17 (approx= (tan (coerce (/ pi -4) 'double-float)) -1d0) t) (deftest tan.18 (approx= (tan (coerce (/ pi 4) 'long-float)) 1l0) t) (deftest tan.19 (approx= (tan (coerce (/ pi -4) 'long-float)) -1l0) t) (deftest tan.20 (loop for r = (- (random 2000) 1000) for i = (- (random 20) 10) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.21 (loop for r = (- (random 2000.0s0) 1000.0s0) for i = (- (random 20.0s0) 10.0s0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.22 (loop for r = (- (random 2000.0f0) 1000.0f0) for i = (- (random 20.0f0) 10.0f0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.23 (loop for r = (- (random 2000.0d0) 1000.0d0) for i = (- (random 20.0d0) 10.0d0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) (deftest tan.24 (loop for r = (- (random 2000.0l0) 1000.0l0) for i = (- (random 20.0l0) 10.0l0) for y = (safe-tan (complex r i)) repeat 1000 always (numberp y)) t) ;;; FIXME ;;; More accuracy tests here ;;; Error tests (deftest tan.error.1 (signals-error (tan) program-error) t) (deftest tan.error.2 (signals-error (tan 0.0 0.0) program-error) t) (deftest tan.error.3 (check-type-error #'tan #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/compile-file-test-file-5.lsp0000644000000000000000000000013014542551762020570 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.825790647 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-file-test-file-5.lsp0000644000175000017500000000023214542551762020165 0ustar00cammcamm(in-package "CL-TEST") (defun compile-file-test-fun.5 () '#.*compile-file-truename*) (defun compile-file-test-fun.5a () '#.*compile-file-pathname*) gcl-2.7.1/ansi-tests/PaxHeaders/format-circumflex.lsp0000644000000000000000000000013214542551762017620 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.825790647 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format-circumflex.lsp0000644000175000017500000005164014542551762017224 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 11 20:17:51 2004 ;;;; Contains: Tests of the ~^ format directive (inside other format constructs) (in-package :cl-test) (compile-and-load "printer-aux.lsp") ;;; Tests of ~^ inside ~{ ... ~} (def-format-test format.^.{.1 "~{X ~A~^ Y ~A~^ ~}" ('(1 2 3 4 5)) "X 1 Y 2 X 3 Y 4 X 5") (def-format-test format.^.{.2 "~{X ~A~^ Y ~A~^ ~}" ('(1 2 3 4)) "X 1 Y 2 X 3 Y 4") (def-format-test format.^.{.3 "~1{~A~^~A~}" ('(1)) "1") (def-format-test format.^.{.4 "~0{~A~^~A~}" ('(1)) "") (def-format-test format.^.{.5 "~1{~A~^~A~}" ('(1 2 3)) "12") (def-format-test format.^.{.6 "~{~A~A~0^~A~}" ('(1 2 3 4 5 6)) "12") (def-format-test format.^.{.7 "~{~A~A~v^~A~}" ('(1 2 3 4 5 6 0 7 8 9 10 11 12)) "12456") (def-format-test format.^.{.8 "~{~#,3^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "1234567") (def-format-test format.^.{.9 "~{~2,#^~A~}~A" ('(1 2 3 4 5 6 7 8 9 10) 0) "123456780") (def-format-test format.^.{.10 "~{~#,#^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "") (def-format-test format.^.{.11 "~{~#,#,#^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "") (def-format-test format.^.{.12 "~{~#,1,2^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "123456789") (def-format-test format.^.{.13 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "246") (def-format-test format.^.{.14 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11)) "246") (def-format-test format.^.{.15 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12)) "246") (def-format-test format.^.{.16 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12 13)) "246") (def-format-test format.^.{.17 "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12 13 14)) "2468") (def-format-test format.^.{.18 "~{~v,v^~A~}" ((list (1+ most-positive-fixnum) (1+ most-positive-fixnum) 1)) "") (def-format-test format.^.{.19 "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) (1+ most-positive-fixnum) 1)) "") (def-format-test format.^.{.20 "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) most-positive-fixnum 1)) "1") (def-format-test format.^.{.21 "~{~1,v^~A~}" ('(nil 8 nil 7 0 6 1 5)) "876") (def-format-test format.^.{.22 "~{~0,v^~A~}" ('(3 8 1 7 3 6 nil 5)) "876") (def-format-test format.^.{.23 "~{~1,2,v^~A~}" ('(0 1 0 2 0 3 3 4)) "123") (def-format-test format.^.{.24 "~{~1,2,v^~A~}" ('(0 1 0 2 0 3 nil 4)) "1234") (def-format-test format.^.{.25 "~{~1,1,v^~A~}" ('(0 1 0 2 0 3 nil 4)) "123") (def-format-test format.^.{.26 "~{~'X^~A~}" ('(1 2 3)) "123") (def-format-test format.^.{.27 "~{~v,'X^~A~}" ('(0 1 #\x 2 nil 3 #\X 4 0 5)) "123") (def-format-test format.^.{.28 "~{~'X,v^~A~}" ('(0 1 #\x 2 nil 3 #\X 4 0 5)) "123") (def-format-test format.^.{.29 "~{~v,v^~A~}" ('(0 2 1 #\x #\X 2 5 #\X 3 #\y #\y 4 1 2 5)) "123") (def-format-test format.^.{.30 "~{~',,',^~A~}" ('(1 2 3)) "") (def-format-test format.^.{.31 "~{~1,v,v^~A~}" ('(#\a nil 0)) "0") (def-format-test format.^.{.32 "~{~v,1,v^~A~}" ('(#\a nil 0)) "0") (def-format-test format.^.{.33 "~{~v,v,v^~A~}" ('(#\a #\a nil 0)) "") ;;; ~^ with ~:{ (def-format-test format.^.\:{.1 "~:{~A~^~A~A~}" ('((1)(2 3 4)(5 6 7 8))) "1234567") (def-format-test format.^.\:{.2 "~:{~A~0^~A~A~}" ('((1)(2 3 4)(5 6 7 8))) "125") (def-format-test format.^.\:{.3 "~:{~#^~A~}" ('((1)(2 3 4)()(5 6 7 8))()) "125" 1) (def-format-test format.^.\:{.4 "~:{~#^~A~#^~A~#^~A~#^~A~}" ('((1)(2 3 4)()(5 6 7 8))()) "12345678" 1) (def-format-test format.^.\:{.5 "~:{~v^~A~}" ('((1 2 3)(0)(2 4)(0 5)(1 6 7 8))) "246") (def-format-test format.^.\:{.6 "~:{~v^~A~}" ('((nil)(nil 1)(1 2))) "12") (def-format-test format.^.\:{.7 "~:{~v^~A~}" ('((#\x 1)(#\y 2)(0 3)(1 4))) "124") (def-format-test format.^.\:{.8 "~:{~v,3^~A~}" ('((1 1)(2 0)(3 4)(5 6))) "106") (def-format-test format.^.\:{.9 "~:{~3,v^~A~}" ('((1 1)(2 0)(3 4)(5 6))) "106") (def-format-test format.^.\:{.10 "~:{~v,3^~A~}" ('((#\x 1))) "1") (def-format-test format.^.\:{.11 "~:{~2,v^~A~}" ('((#\x 1))) "1") (def-format-test format.^.\:{.12 "~:{~v,v^~A~}" ('((1 2 0) (0 1 1) (1 0 2) (3 3 5) (4 5 6))) "0126") (def-format-test format.^.\:{.13 "~:{~v,v^~A~}" ('((1 2 0) (#\a #\A 1) (#\A #\A 2) (1 2 3))) "013") (def-format-test format.^.\:{.14 "~:{~'x,3^~A~}" ('((1))) "1") (def-format-test format.^.\:{.15 "~:{~3,'x^~A~}" ('((1))) "1") (def-format-test format.^.\:{.16 "~:{~'x,'x^~A~}" ('((1))) "") (def-format-test format.^.\:{.17 "~:{~#,1^~A~}" ('((1)(2 10)(3 a b)(4)(5 x)(6)(7 8))) "2357") (def-format-test format.^.\:{.18 "~:{~1,#^~A~}" ('((1)(2 10)(3 a b)(4)(5 x)(6)(7 8))) "2357") (def-format-test format.^.\:{.19 "~:{~#,#^~A~}" ('((1)()(2 10)(3 a b)(4)(5 x)(6)(7 8))) "") (def-format-test format.^.\:{.20 "~:{~0,v^~A~}" ('((0 1)(1 2)(nil 3)(2 4))) "24") (def-format-test format.^.\:{.21 "~:{~1,v^~A~}" ('((0 1)(1 2)(nil 3)(2 4))) "134") (def-format-test format.^.\:{.22 "~:{~1,1,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "") (def-format-test format.^.\:{.23 "~:{~1,2,3^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "") (def-format-test format.^.\:{.24 "~:{~1,2,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") (def-format-test format.^.\:{.25 "~:{~1,0,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") (def-format-test format.^.\:{.26 "~:{~3,2,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") (def-format-test format.^.\:{.27 "~:{~v,2,3^~A~}" ('((1 10)(2 20)(3 30)(4 40))) "3040") (def-format-test format.^.\:{.28 "~:{~1,v,3^~A~}" ('((0 7)(1 10)(2 20)(3 30)(4 40))) "740") (def-format-test format.^.\:{.29 "~:{~1,2,v^~A~}" ('((0 0)(1 10)(2 20)(3 30)(4 40)(0 50))) "01050") (def-format-test format.^.\:{.30 "~:{~1,2,v^~A~}" ('((nil 0))) "0") (def-format-test format.^.\:{.31 "~:{~#,3,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "45") (def-format-test format.^.\:{.32 "~:{~2,#,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "145") (def-format-test format.^.\:{.33 "~:{~0,3,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "12") (def-format-test format.^.\:{.34 "~:{~#,#,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "45") (def-format-test format.^.\:{.35 "~:{~3,#,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "12") (def-format-test format.^.\:{.36 "~:{~#,3,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "1245") (def-format-test format.^.\:{.37 "~:{~#,#,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "") (def-format-test format.^.\:{.38 "~:{~1,v,v^~A~}" ('((#\a nil 0))) "0") (def-format-test format.^.\:{.39 "~:{~v,1,v^~A~}" ('((#\a nil 0))) "0") ;;; Tests of ~^ inside ~@{ ... ~} (def-format-test format.^.@{.1 "~@{X ~A~^ Y ~A~^ ~}" (1 2 3 4 5) "X 1 Y 2 X 3 Y 4 X 5") (def-format-test format.^.@{.2 "~@{X ~A~^ Y ~A~^ ~}" (1 2 3 4) "X 1 Y 2 X 3 Y 4") (def-format-test format.^.@{.3 "~1@{~A~^~A~}" (1) "1") (def-format-test format.^.@{.4 "~0@{~A~^~A~}" (1) "" 1) (def-format-test format.^.@{.5 "~1@{~A~^~A~}" (1 2 3) "12" 1) (def-format-test format.^.@{.6 "~@{~A~A~0^~A~}" (1 2 3 4 5 6) "12" 4) (def-format-test format.^.@{.7 "~@{~A~A~v^~A~}" (1 2 3 4 5 6 0 7 8 9 10 11 12) "12456" 6) (def-format-test format.^.@{.8 "~@{~#,3^~A~}" (1 2 3 4 5 6 7 8 9 10) "1234567" 3) (def-format-test format.^.@{.9 "~@{~2,#^~A~}X~A" (1 2 3 4 5 6 7 8 9 10) "12345678X9" 1) (def-format-test format.^.@{.10 "~@{~#,#^~A~}" (1 2 3 4 5 6 7 8 9 10) "" 10) (def-format-test format.^.@{.11 "~@{~#,#,#^~A~}" (1 2 3 4 5 6 7 8 9 10) "" 10) (def-format-test format.^.@{.12 "~@{~#,1,2^~A~}" (1 2 3 4 5 6 7 8 9 10) "123456789" 1) (def-format-test format.^.@{.13 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10) "246" 3) (def-format-test format.^.@{.14 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11) "246" 4) (def-format-test format.^.@{.15 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12) "246" 5) (def-format-test format.^.@{.16 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12 13) "246" 6) (def-format-test format.^.@{.17 "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12 13 14) "2468" 5) (def-format-test format.^.@{.18 "~@{~v,v^~A~}" ((1+ most-positive-fixnum) (1+ most-positive-fixnum) 1) "" 1) (def-format-test format.^.@{.19 "~@{~0,v,v^~A~}" ((1+ most-positive-fixnum) (1+ most-positive-fixnum) 1) "" 1) (def-format-test format.^.@{.20 "~@{~0,v,v^~A~}" ((1+ most-positive-fixnum) most-positive-fixnum 1) "1") (def-format-test format.^.@{.21 "~@{~1,v^~A~}" (nil 8 nil 7 0 6 1 5) "876" 1) (def-format-test format.^.@{.22 "~@{~0,v^~A~}" (3 8 1 7 3 6 nil 5) "876" 1) (def-format-test format.^.@{.23 "~@{~1,2,v^~A~}" (0 1 0 2 0 3 3 4) "123" 1) (def-format-test format.^.@{.24 "~@{~1,2,v^~A~}" (0 1 0 2 0 3 nil 4) "1234") (def-format-test format.^.@{.25 "~@{~1,1,v^~A~}" (0 1 0 2 0 3 nil 4) "123" 1) (def-format-test format.^.@{.26 "~@{~'X^~A~}" (1 2 3) "123") (def-format-test format.^.@{.27 "~@{~v,'X^~A~}" (0 1 #\x 2 nil 3 #\X 4 0 5) "123" 3) (def-format-test format.^.@{.28 "~@{~'X,v^~A~}" (0 1 #\x 2 nil 3 #\X 4 0 5) "123" 3) (def-format-test format.^.@{.29 "~@{~v,v^~A~}" (0 2 1 #\x #\X 2 5 #\X 3 #\y #\y 4 1 2 5) "123" 4) (def-format-test format.^.@{.30 "~@{~',,',^~A~}" (1 2 3) "" 3) (def-format-test format.^.@{.31 "~@{~1,v,v^~A~}" (#\a nil 0) "0") (def-format-test format.^.@{.32 "~@{~v,1,v^~A~}" (#\a nil 0) "0") (def-format-test format.^.@{.33 "~@{~v,v,v^~A~}" (#\a #\a nil 0) "" 1) ;;; Inside ~:@{ (def-format-test format.^.\:@{.1 "~:@{~A~^~A~A~}" ('(1) '(2 3 4) '(5 6 7 8)) "1234567") (def-format-test format.^.\:@{.2 "~@:{~A~0^~A~A~}" ('(1) '(2 3 4) '(5 6 7 8)) "125") (def-format-test format.^.\:@{.3 "~:@{~#^~A~}" ('(1) '(2 3 4) () '(5 6 7 8) ()) "125") (def-format-test format.^.\:@{.4 "~@:{~#^~A~#^~A~#^~A~#^~A~}" ('(1) '(2 3 4) () '(5 6 7 8) ()) "12345678") (def-format-test format.^.\:@{.5 "~:@{~v^~A~}" ('(1 2 3) '(0) '(2 4) '(0 5) '(1 6 7 8)) "246") (def-format-test format.^.\:@{.6 "~:@{~v^~A~}" ('(nil) '(nil 1) '(1 2)) "12") (def-format-test format.^.\:@{.7 "~:@{~v^~A~}" ('(#\x 1) '(#\y 2) '(0 3) '(1 4)) "124") (def-format-test format.^.\:@{.8 "~:@{~v,3^~A~}" ('(1 1) '(2 0) '(3 4) '(5 6)) "106") (def-format-test format.^.\:@{.9 "~@:{~3,v^~A~}" ('(1 1) '(2 0) '(3 4) '(5 6)) "106") (def-format-test format.^.\:@{.10 "~:@{~v,3^~A~}" ('(#\x 1)) "1") (def-format-test format.^.\:@{.11 "~:@{~2,v^~A~}" ('(#\x 1)) "1") (def-format-test format.^.\:@{.12 "~:@{~v,v^~A~}" ('(1 2 0) '(0 1 1) '(1 0 2) '(3 3 5) '(4 5 6)) "0126") (def-format-test format.^.\:@{.13 "~:@{~v,v^~A~}" ('(1 2 0) '(#\a #\A 1) '(#\A #\A 2) '(1 2 3)) "013") (def-format-test format.^.\:@{.14 "~:@{~'x,3^~A~}" ('(1)) "1") (def-format-test format.^.\:@{.15 "~:@{~3,'x^~A~}" ('(1)) "1") (def-format-test format.^.\:@{.16 "~:@{~'x,'x^~A~}" ('(1)) "") (def-format-test format.^.\:@{.17 "~:@{~#,1^~A~}" ('(1) '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "2357") (def-format-test format.^.\:@{.18 "~:@{~1,#^~A~}" ('(1) '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "2357") (def-format-test format.^.\:@{.19 "~:@{~#,#^~A~}" ('(1) '() '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "") (def-format-test format.^.\:@{.20 "~:@{~0,v^~A~}" ('(0 1) '(1 2) '(nil 3) '(2 4)) "24") (def-format-test format.^.\:@{.21 "~:@{~1,v^~A~}" ('(0 1) '(1 2) '(nil 3) '(2 4)) "134") (def-format-test format.^.\:@{.22 "~:@{~1,1,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "") (def-format-test format.^.\:@{.23 "~:@{~1,2,3^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "") (def-format-test format.^.\:@{.24 "~:@{~1,2,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") (def-format-test format.^.\:@{.25 "~:@{~1,0,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") (def-format-test format.^.\:@{.26 "~:@{~3,2,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") (def-format-test format.^.\:@{.27 "~:@{~v,2,3^~A~}" ('(1 10) '(2 20) '(3 30) '(4 40)) "3040") (def-format-test format.^.\:@{.28 "~:@{~1,v,3^~A~}" ('(0 7) '(1 10) '(2 20) '(3 30) '(4 40)) "740") (def-format-test format.^.\:@{.29 "~:@{~1,2,v^~A~}" ('(0 0) '(1 10) '(2 20) '(3 30) '(4 40) '(0 50)) "01050") (def-format-test format.^.\:@{.30 "~:@{~1,2,v^~A~}" ('(nil 0)) "0") (def-format-test format.^.\:@{.31 "~:@{~#,3,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "45") (def-format-test format.^.\:@{.32 "~:@{~2,#,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "145") (def-format-test format.^.\:@{.33 "~:@{~0,3,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "12") (def-format-test format.^.\:@{.34 "~:@{~#,#,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "45") (def-format-test format.^.\:@{.35 "~:@{~3,#,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "12") (def-format-test format.^.\:@{.36 "~:@{~#,3,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "1245") (def-format-test format.^.\:@{.37 "~:@{~#,#,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "") (def-format-test format.^.\:@{.38 "~:@{~1,v,v^~A~}" ('(#\a nil 0)) "0") (def-format-test format.^.\:@{.39 "~:@{~v,1,v^~A~}" ('(#\a nil 0)) "0") ;;; ~:^ in ~:{ (def-format-test format.\:^.\:{.1 "~:{~:^~A~}" (nil) "") (def-format-test format.\:^.\:{.2 "(~:{~A~:^,~})" ('((1)(2)(3))) "(1,2,3)") (def-format-test format.\:^.\:{.3 "~:{~:^~A~}" ('((1)(2)(3)(4))) "123") ;;; arguments (def-format-test format.\:^.\:{.4 "~:{~0:^~A~}" ('((1)(2))) "") (def-format-test format.\:^.\:{.5 "~:{~1:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.6 "~:{~'X:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.7 "~:{~v:^~A~}" ('((1 8)(2 3 4)(3 1)(0)(6 7)(8 10))) "831") (def-format-test format.\:^.\:{.8 "~:{~V:^~A~}" ('((#\X 1)(0 2))) "1") (def-format-test format.\:^.\:{.9 "~:{~#:^~A~}" ('((1)(2)(3 4)(5 6 7)()(8 9 10))) "1235") (def-format-test format.\:^.\:{.10 "~:{~1,1:^~A~}" ('(()(1)(2 3))) "") (def-format-test format.\:^.\:{.11 "~:{~0,1:^~A~}" ('((1)(2 3))) "12") (def-format-test format.\:^.\:{.12 "~:{~v,1:^~A~}" ('((2 3)(4 5 6)(0 2)(1 7)(9 10))) "352") (def-format-test format.\:^.\:{.13 "~:{~1,V:^~A~}" ('((2 3)(4 5 6)(0 2)(1 7)(9 10))) "352") (def-format-test format.\:^.\:{.14 "~:{~V,v:^~A~}" ('((0 1 2) (1 0 3) (4 4) () (5 6 7))) "23") (def-format-test format.\:^.\:{.15 "~:{~#,1:^~A~}" ('((2 3 4)(4 5)(0)(1 7)(9 10))) "24") (def-format-test format.\:^.\:{.16 "~:{~1,#:^~A~}" ('((2 3 4)(4 5)(0)(1 7)(9 10))) "24") (def-format-test format.\:^.\:{.17 "~:{~#,#:^~A~}" ('(nil)) "") (def-format-test format.\:^.\:{.18 "~:{~#,#:^~A~}" ('((1))) "") (def-format-test format.\:^.\:{.19 "~:{~#,v:^~A~}" ('((1 2)(3 4)(2 5 6)(1)(2))) "245") (def-format-test format.\:^.\:{.20 "~:{~V,#:^~A~}" ('((0 2)(1 3 4)(1 3)()(0 7))) "23") (def-format-test format.\:^.\:{.21 "~:{~'X,'Y:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.22 "~:{~'X,'X:^~A~}" ('((1)(2))) "") (def-format-test format.\:^.\:{.23 "~:{~1,2,3:^~A~}" ('((1)(2))) "") (def-format-test format.\:^.\:{.24 "~:{~1,2,1:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.25 "~:{~2,1,3:^~A~}" ('((1)(2))) "12") (def-format-test format.\:^.\:{.26 "~:{~1,1,v:^~A~}" ('((0 4)(nil 1)(0 5))) "4") (def-format-test format.\:^.\:{.27 "~:{~v,2,2:^~A~}" ('((3 4)(1 1)(4 5))) "4") (def-format-test format.\:^.\:{.28 "~:{~1,v,2:^~A~}" ('((0 2)(3 4)(1 1)(4 5))) "24") (def-format-test format.\:^.\:{.29 "~:{~V,v,3:^~A~}" ('((1 4 0)(2 1 7)(4 4 8 0)(1 2 6)(9 8 0))) "078") (def-format-test format.\:^.\:{.30 "~:{~v,2,v:^~A~}" ('((1 1 0)(3 2 5)(2 1 6)(1 2 0)(10 11 13))) "056") (def-format-test format.\:^.\:{.31 "~:{~2,V,v:^~A~}" ('((1 1 0)(3 2 5)(2 1 6)(10 11 13)(0 1 0))) "056") (def-format-test format.\:^.\:{.32 "~:{~v,v,V:^~A~}" ('((1 2 1 0)(2 1 1 4)(2 3 1 6)(1 2 3)(0 1 0 8))) "046") (def-format-test format.\:^.\:{.33 "~:{~#,2,2:^~A~}" ('((1 2 3)(2 X X)(0 A B C D)(4 5)(5 7 8 9))) "120") (def-format-test format.\:^.\:{.34 "~:{~2,#,3:^~A~}" ('((1)(2 3 4 5)(3 4)(4 5 6 7 8)())) "12") (def-format-test format.\:^.\:{.35 "~:{~1,3,#:^~A~}" ('((1)(2 3)(3 4)(4 5 6)(5))) "123") (def-format-test format.\:^.\:{.36 "~:{~#,#,2:^~A~}" ('((1 2 3)(2 X X)(0 A B C D)(4 5)(5 7 8 9))) "120") (def-format-test format.\:^.\:{.37 "~:{~3,#,#:^~A~}" ('((1)(2 3)(3 4)(4 5 6)(5))) "123") (def-format-test format.\:^.\:{.38 "~:{~#,2,#:^~A~}" ('((1 2 3)(2)(0 A B C D)(4 5)(5 7 8 9))) "120") (def-format-test format.\:^.\:{.39 "~:{~#,#,#:^~A~}" ('((1 2 3)(2)(0 A B C D)(4 5)(5 7 8 9))) "") ;;; ~:^ in ~:@{ (def-format-test format.\:^.\:@{.1 "~:@{~:^~A~}" nil "") (def-format-test format.\:^.\:@{.2 "(~:@{~A~:^,~})" ('(1) '(2) '(3)) "(1,2,3)") (def-format-test format.\:^.\:@{.3 "~:@{~:^~A~}" ('(1) '(2) '(3) '(4)) "123") (def-format-test format.\:^.\:@{.4 "~:@{~0:^~A~}" ('(1) '(2)) "" 1) (def-format-test format.\:^.\:@{.5 "~:@{~1:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.6 "~:@{~'X:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.7 "~:@{~v:^~A~}" ('(1 8) '(2 3 4) '(3 1) '(0) '(6 7) '(8 10)) "831" 2) (def-format-test format.\:^.\:@{.8 "~:@{~V:^~A~}" ('(#\X 1) '(0 2)) "1") (def-format-test format.\:^.\:@{.9 "~:@{~#:^~A~}" ('(1) '(2) '(3 4) '(5 6 7) () '(8 9 10)) "1235" 1) (def-format-test format.\:^.\:@{.10 "~:@{~1,1:^~A~}" (() '(1) '(2 3)) "" 2) (def-format-test format.\:^.\:@{.11 "~:@{~0,1:^~A~}" ('(1) '(2 3)) "12") (def-format-test format.\:^.\:@{.12 "~:@{~v,1:^~A~}" ('(2 3) '(4 5 6) '(0 2) '(1 7) '(9 10)) "352" 1) (def-format-test format.\:^.\:@{.13 "~:@{~1,V:^~A~}" ('(2 3) '(4 5 6) '(0 2) '(1 7) '(9 10)) "352" 1) (def-format-test format.\:^.\:@{.14 "~:@{~V,v:^~A~}" ('(0 1 2) '(1 0 3) '(4 4) () '(5 6 7)) "23" 2) (def-format-test format.\:^.\:@{.15 "~:@{~#,1:^~A~}" ('(2 3 4) '(4 5) '(0) '(1 7) '(9 10)) "24" 2) (def-format-test format.\:^.\:@{.16 "~:@{~1,#:^~A~}" ('(2 3 4) '(4 5) '(0) '(1 7) '(9 10)) "24" 2) (def-format-test format.\:^.\:@{.17 "~:@{~#,#:^~A~}" (nil) "") (def-format-test format.\:^.\:@{.18 "~:@{~#,#:^~A~}" ('(1)) "") (def-format-test format.\:^.\:@{.19 "~:@{~#,v:^~A~}" ('(1 2) '(3 4) '(2 5 6) '(1) '(2)) "245" 1) (def-format-test format.\:^.\:@{.20 "~:@{~V,#:^~A~}" ('(0 2) '(1 3 4) '(1 3) () '(0 7)) "23" 2) (def-format-test format.\:^.\:@{.21 "~:@{~'X,'Y:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.22 "~:@{~'X,'X:^~A~}" ('(1) '(2)) "" 1) (def-format-test format.\:^.\:@{.23 "~:@{~1,2,3:^~A~}" ('(1) '(2)) "" 1) (def-format-test format.\:^.\:@{.24 "~:@{~1,2,1:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.25 "~:@{~2,1,3:^~A~}" ('(1) '(2)) "12") (def-format-test format.\:^.\:@{.26 "~:@{~1,1,v:^~A~}" ('(0 4) '(nil 1) '(0 5)) "4" 1) (def-format-test format.\:^.\:@{.27 "~:@{~v,2,2:^~A~}" ('(3 4) '(1 1) '(4 5)) "4" 1) (def-format-test format.\:^.\:@{.28 "~:@{~1,v,2:^~A~}" ('(0 2) '(3 4) '(1 1) '(4 5)) "24" 1) (def-format-test format.\:^.\:@{.29 "~:@{~V,v,3:^~A~}" ('(1 4 0) '(2 1 7) '(4 4 8 0) '(1 2 6) '(9 8 0)) "078" 1) (def-format-test format.\:^.\:@{.30 "~:@{~v,2,v:^~A~}" ('(1 1 0) '(3 2 5) '(2 1 6) '(1 2 0) '(10 11 13)) "056" 1) (def-format-test format.\:^.\:@{.31 "~:@{~2,V,v:^~A~}" ('(1 1 0) '(3 2 5) '(2 1 6) '(10 11 13) '(0 1 0)) "056" 1) (def-format-test format.\:^.\:@{.32 "~:@{~v,v,V:^~A~}" ('(1 2 1 0) '(2 1 1 4) '(2 3 1 6) '(1 2 3) '(0 1 0 8)) "046" 1) (def-format-test format.\:^.\:@{.33 "~:@{~#,2,2:^~A~}" ('(1 2 3) '(2 X X) '(0 A B C D) '(4 5) '(5 7 8 9)) "120" 1) (def-format-test format.\:^.\:@{.34 "~:@{~2,#,3:^~A~}" ('(1) '(2 3 4 5) '(3 4) '(4 5 6 7 8) ()) "12" 2) (def-format-test format.\:^.\:@{.35 "~:@{~1,3,#:^~A~}" ('(1) '(2 3) '(3 4) '(4 5 6) '(5)) "123" 1) (def-format-test format.\:^.\:@{.36 "~:@{~#,#,2:^~A~}" ('(1 2 3) '(2 X X) '(0 A B C D) '(4 5) '(5 7 8 9)) "120" 1) (def-format-test format.\:^.\:@{.37 "~:@{~3,#,#:^~A~}" ('(1) '(2 3) '(3 4) '(4 5 6) '(5)) "123" 1) (def-format-test format.\:^.\:@{.38 "~:@{~#,2,#:^~A~}" ('(1 2 3) '(2) '(0 A B C D) '(4 5) '(5 7 8 9)) "120" 1) (def-format-test format.\:^.\:@{.39 "~:@{~#,#,#:^~A~}" ('(1 2 3) '(2) '(0 A B C D) '(4 5) '(5 7 8 9)) "" 4) ;;; ~^ inside ~?, ~@? (def-format-test format.^.?.1 "~AY~?X~A" (1 "~A~0^~A" '(2 4) 3) "1Y2X3") (def-format-test format.^.?.2 "~AY~?X~A" (1 "~A~^~A" '(2) 3) "1Y2X3") (def-format-test format.^.?.3 "~AY~?X~A" (1 "~A~^~A~^~A" '(2 4) 3) "1Y24X3") (def-format-test format.^.?.4 "~A~?X~A" (1 "~{~^~A~}~AY~A" '((2 3) 4 5) 6) "1234Y5X6") (def-format-test format.^.@?.1 "~AY~@?X~A" (1 "~A~0^~A" 2 3 4) "1Y2X3" 1) (def-format-test format.^.@?.2 "~A~@?X~A" (1 "~{~^~A~}~AY~A" '(2 3) 4 5 6) "1234Y5X6") ;;; ~^ in ~[ (def-format-test format.^.\[.1 "~{~[X~;Y~;Z~;~0^~]~}" ('(0 1 2 3 4)) "XYZ") (def-format-test format.^.\[.2 "~{~[X~;Y~;Z~:;~0^~]~}" ('(1 0 2 8 9 10 0)) "YXZ") (def-format-test format.^.\[.3 "~{~[X~;Y~0^NO~;Z~;~^~]~}" ('(0 1 2 3 4)) "XY") ;;; ~^ in ~( (def-format-test format.^.\(.1 "~{~(~C~C~0^~C~)W~}" ('(#\X #\Y #\Z #\A)) "xy") (def-format-test format.^.\:\(.1 "~{~:(~C~C~0^~C~)U~}" ('(#\X #\Y #\Z #\A)) "Xy") (def-format-test format.^.@\(.1 "~{~@(~CA ~Cb ~0^~C~)V~}" ('(#\x #\y #\Z #\A)) "Xa yb ") (def-format-test format.^.@\:\(.1 "~{~@:(~CA ~Cb ~0^~C~)W~}" ('(#\x #\Y #\Z #\A)) "XA YB ") gcl-2.7.1/ansi-tests/PaxHeaders/reinitialize-instance.lsp0000644000000000000000000000013114542551763020463 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.825790647 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/reinitialize-instance.lsp0000644000175000017500000000657514542551763020077 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Apr 28 21:56:47 2003 ;;;; Contains: Tests for REINITIALIZE-INSTANCE (in-package :cl-test) ;;; Many of the classes used here are defined in defclass-??.lsp (deftest reinitialize-instance.1 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.2 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj :allow-other-keys nil))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.3 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj :allow-other-keys t))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.4 (let* ((obj (make-instance 'class-01)) (obj2 (reinitialize-instance obj :allow-other-keys t :allow-other-keys nil))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) t (nil nil nil)) (deftest reinitialize-instance.5 (let* ((obj (make-instance 'class-07)) (obj2 (reinitialize-instance obj :s1a 'a :s2 'b :s1a 'bad :s2 'bad2 :s1b 'bad3))) (values (eqt obj obj2) (map-slot-value obj '(s1 s2)))) t (a b)) (deftest reinitialize-instance.6 (let* ((obj (make-instance 'class-07 :s1a 'a)) (obj2 (reinitialize-instance obj :s1b 'b))) (values (eqt obj obj2) (slot-value obj 's1) (slot-boundp* obj 's2))) t b nil) (deftest reinitialize-instance.7 (let* ((obj (make-instance 'class-07 :s1a 'a)) (obj2 (reinitialize-instance obj :s2 'b))) (values (eqt obj obj2) (slot-value obj 's1) (slot-value obj 's2))) t a b) ;;; Tests of user-defined methods (defclass reinit-class-01 () ((a :initarg :a) (b :initarg :b))) (defmethod reinitialize-instance :after ((instance reinit-class-01) &rest initargs &key (x nil x-p)) (declare (ignore initargs)) (when x-p (setf (slot-value instance 'a) x)) instance) (deftest reinitialize-instance.8 (let* ((obj (make-instance 'reinit-class-01)) (obj2 (reinitialize-instance obj :a 1 :b 3))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) t (1 3)) (deftest reinitialize-instance.9 (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) (obj2 (reinitialize-instance obj :x 3))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) t (3 20)) (deftest reinitialize-instance.10 (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) (obj2 (reinitialize-instance obj :x 3 :x 100))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) t (3 20)) ;;; Order of evaluation tests (deftest reinitialize-instance.order.1 (let* ((obj (make-instance 'reinit-class-01)) (i 0) x y z w (obj2 (reinitialize-instance (progn (setf x (incf i)) obj) :b (setf y (incf i)) :a (setf z (incf i)) :b (setf w (incf i))))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)) i x y z w)) t (3 2) 4 1 2 3 4) ;;; Error cases (deftest reinitialize-instance.error.1 (handler-case (eval '(reinitialize-instance (make-instance 'class-01) :garbage t)) (error () :good)) :good) (deftest reinitialize-instance.error.2 (signals-error (reinitialize-instance) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/symbol-name.lsp0000644000000000000000000000013114542551763016414 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.825790647 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/symbol-name.lsp0000644000175000017500000000114614542551763016015 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jun 14 05:45:55 2003 ;;;; Contains: Tests of SYMBOL-NAME (in-package :cl-test) (deftest symbol-name.1 (symbol-name '|ABCD|) "ABCD") (deftest symbol-name.2 (symbol-name '|1234abcdABCD|) "1234abcdABCD") (deftest symbol-name.3 (symbol-name :|abcdefg|) "abcdefg") ;;; Error tests (deftest symbol-name.error.1 (signals-error (symbol-name) program-error) t) (deftest symbol-name.error.2 (signals-error (symbol-name 'a 'b) program-error) t) (deftest symbol-name.error.3 (check-type-error #'symbol-name #'symbolp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/simple-bit-vector-p.lsp0000644000000000000000000000013214542551763017774 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.825790647 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/simple-bit-vector-p.lsp0000644000175000017500000000232714542551763017376 0ustar00cammcamm;-*- 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 (check-type-predicate #'simple-bit-vector-p 'simple-bit-vector) nil) (deftest simple-bit-vector-p.error.1 (signals-error (simple-bit-vector-p) program-error) t) (deftest simple-bit-vector-p.error.2 (signals-error (simple-bit-vector-p #* #*) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/loop1.lsp0000644000000000000000000000013214763573237015231 xustar0030 mtime=1741616799.673591244 30 atime=1744294960.825790647 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/loop1.lsp0000644000175000017500000001736114763573237014637 0ustar00cammcamm;-*- 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 achieves 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) |# ;;; The arithmetic loop form says the types are numbers, not ;;; reals, so arguably they should work on complexes (which are ;;; numbers.) Comparing these for termination could be problematic, ;;; but a clause without termination should work just fine. (deftest loop.1.44 (loop for i from 1 to 5 for c from #c(0 1) collect c) (#c(0 1) #c(1 1) #c(2 1) #c(3 1) #c(4 1))) (deftest loop.1.45 (loop for i from 1 to 5 for c from #c(0 1) by 2 collect c) (#c(0 1) #c(2 1) #c(4 1) #c(6 1) #c(8 1))) (deftest loop.1.46 (loop for i from 1 to 5 for c downfrom #c(5 1) collect c) (#c(5 1) #c(4 1) #c(3 1) #c(2 1) #c(1 1))) (deftest loop.1.47 (loop for i from 1 to 5 for c downfrom #c(10 1) by 2 collect c) (#c(10 1) #c(8 1) #c(6 1) #c(4 1) #c(2 1))) (deftest loop.1.48 (loop for i from 1 to 5 for c upfrom #c(0 1) collect c) (#c(0 1) #c(1 1) #c(2 1) #c(3 1) #c(4 1))) (deftest loop.1.49 (loop for i from 1 to 5 for c upfrom #c(0 1) by 2 collect c) (#c(0 1) #c(2 1) #c(4 1) #c(6 1) #c(8 1))) ;;; The variable in the loop for-as-arithmetic clause ;;; can be a d-var-spec, so 'NIL' should mean don't bind anything (deftest loop.1.50 (let ((i 0)) (loop for nil from 10 to 15 collect (incf i))) (1 2 3 4 5 6)) (deftest loop.1.51 (let ((i 0)) (loop for nil from 10 below 15 collect (incf i))) (1 2 3 4 5)) (deftest loop.1.52 (loop for nil from 10 to 0 collect 'a) nil) (deftest loop.1.53 (let ((i 0)) (loop for nil from 0 to 10 by 2 collect (incf i))) (1 2 3 4 5 6)) (deftest loop.1.54 (let ((i 0)) (loop for nil from 1 to 4 for nil from 1 to 10 collect (incf i))) (1 2 3 4)) (deftest loop.1.55 (let ((i 0)) (loop for nil from 5 downto 0 collect (incf i))) (1 2 3 4 5 6)) (deftest loop.1.56 (let ((i 0)) (loop for nil from 5 above 0 collect (incf i))) (1 2 3 4 5)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest loop.1.57 (macrolet ((%m (z) z)) (loop for i from (expand-in-current-env (%m 1)) to 5 collect i)) (1 2 3 4 5)) (deftest loop.1.58 (macrolet ((%m (z) z)) (loop for i from 1 to (expand-in-current-env (%m 5)) collect i)) (1 2 3 4 5)) (deftest loop.1.59 (macrolet ((%m (z) z)) (loop for i from 1 to 5 by (expand-in-current-env (%m 2)) collect i)) (1 3 5)) (deftest loop.1.60 (macrolet ((%m (z) z)) (loop for i downfrom (expand-in-current-env (%m 10)) to 3 collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.61 (macrolet ((%m (z) z)) (loop for i downfrom 10 to (expand-in-current-env (%m 3)) collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.62 (macrolet ((%m (z) z)) (loop for i from (expand-in-current-env (%m 10)) downto 3 collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.63 (macrolet ((%m (z) z)) (loop for i from 10 downto (expand-in-current-env (%m 3)) collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.64 (macrolet ((%m (z) z)) (loop for i from (expand-in-current-env (%m 1)) below 5 collect i)) (1 2 3 4)) (deftest loop.1.65 (macrolet ((%m (z) z)) (loop for i from 1 below (expand-in-current-env (%m 5)) collect i)) (1 2 3 4)) gcl-2.7.1/ansi-tests/PaxHeaders/random.lsp0000644000000000000000000000013114542551763015451 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.825790647 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/random.lsp0000644000175000017500000000353314542551763015054 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 6 15:47:42 2003 ;;;; Contains: Tests of RANDOM (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "random-aux.lsp") (deftest random.error.1 (signals-error (random) program-error) t) (deftest random.error.2 (signals-error (random 10 *random-state* nil) program-error) t) (deftest random.error.3 (check-type-error #'random (typef '(real (0)))) nil) (deftest random.1 (loop for i from 2 to 30 for n = (ash 1 i) nconc (loop for j = (1+ (random n)) repeat 20 nconc (loop for r = (random j) repeat i unless (and (integerp r) (<= 0 r) (< r j)) collect (list j r)))) nil) (deftest random.2 (loop for i from 2 to 20 for n = (ash 1 i) nconc (loop for j = (random (float n)) repeat 20 unless (zerop j) nconc (loop for r = (random j) repeat 20 unless (and (eql (float r j) r) (<= 0 r) (< r j)) collect (list j r)))) nil) (deftest random.3 (binomial-distribution-test 10000 #'(lambda () (eql (random 2) 0))) t) (deftest random.4 (binomial-distribution-test 10000 #'(lambda () (< (random 1.0s0) 0.5s0))) t) (deftest random.5 (binomial-distribution-test 10000 #'(lambda () (< (random 1.0d0) 0.5d0))) t) (deftest random.6 (binomial-distribution-test 10000 #'(lambda () (evenp (random 1024)))) t) (deftest random.7 (loop for x in '(10.0s0 20.0f0 30.0d0 40.0l0) for r = (random x) unless (eql (float r x) r) collect (list x r)) nil) (deftest random.8 (let* ((f1 '(lambda (x) (random (if x 10 20)))) (f2 (compile nil f1))) (values (loop repeat 100 always (<= 0 (funcall f2 t) 9)) (loop repeat 100 always (<= 0 (funcall f2 nil) 19)))) t t) ;;; Do more statistical tests here gcl-2.7.1/ansi-tests/PaxHeaders/maphash.lsp0000644000000000000000000000013114542551763015612 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.825790647 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/maphash.lsp0000644000175000017500000000734414542551763015221 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Nov 28 09:36:58 2003 ;;;; Contains: Test of MAPHASH (in-package :cl-test) (deftest maphash.1 (let ((table (make-hash-table))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) (deftest maphash.2 (let ((table (make-hash-table :test 'equal))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) (deftest maphash.3 (let ((table (make-hash-table :test 'equalp))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) ;;; Test that REMHASH on the key being traversed is allowed (deftest maphash.4 (let ((table (make-hash-table))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v) (remhash k table)) table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) (deftest maphash.5 (let ((table (make-hash-table :test 'equal))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v) (remhash k table)) table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) (deftest maphash.6 (let ((table (make-hash-table :test 'equalp))) (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) (let ((s1 0) (s2 0)) (values (multiple-value-list (maphash #'(lambda (k v) (incf s1 k) (incf s2 v) (remhash k table)) table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) ;;; EQ hash tables (deftest maphash.7 (let ((symbols '(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)) (table (make-hash-table :test #'eq))) (loop for sym in symbols for i from 1 do (setf (gethash sym table) i)) (let ((sum 0)) (values (multiple-value-list (maphash #'(lambda (k v) (assert (eq (elt symbols (1- v)) k)) (incf sum v)) table)) sum))) (nil) #.(* 13 27)) (deftest maphash.8 (let ((symbols '(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)) (table (make-hash-table :test #'eq))) (loop for sym in symbols for i from 1 do (setf (gethash sym table) i)) (let ((sum 0)) (values (multiple-value-list (maphash #'(lambda (k v) (assert (eq (elt symbols (1- v)) k)) (remhash k table) (incf sum v)) table)) sum (hash-table-count table)))) (nil) #.(* 13 27) 0) ;;; Need to add tests where things are setf'd during traversal (deftest maphash.order.1 (let ((i 0) x y dummy (table (make-hash-table))) (values (multiple-value-list (maphash (progn (setf x (incf i)) #'(lambda (k v) (setf dummy (list k v)))) (progn (setf y (incf i)) table))) i x y dummy)) (nil) 2 1 2 nil) ;;; Error tests (deftest maphash.error.1 (signals-error (maphash) program-error) t) (deftest maphash.error.2 (signals-error (maphash #'list) program-error) t) (deftest maphash.error.3 (signals-error (maphash #'list (make-hash-table) nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/string.lsp0000644000000000000000000000013214542551763015500 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.825790647 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/string.lsp0000644000175000017500000000656514542551763015112 0ustar00cammcamm;-*- 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 (check-predicate #'(lambda (x) (handler-case (stringp (string x)) (type-error () :caught)))) nil) (deftest string.8 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(array nil (*)) 'string) t t) (deftest string.9 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(array nil 1) 'string) t t) (deftest string.10 :notes (:allow-nil-arrays :nil-vectors-are-strings) (string (make-array '(0) :element-type nil)) "") (deftest string.11 (typep* "abcd" 'string) t) (deftest string.12 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(17) :element-type nil) 'string) t) (deftest string.13 :notes (:allow-nil-arrays :nil-vectors-are-strings) (typep* (make-array '(0) :element-type nil) 'string) t) (deftest string.14 (let ((count 0)) (loop for i below (min char-code-limit 65536) for c = (code-char i) for s = (and c (string c)) when (and c (or (not (stringp s)) (not (= (length s) 1)) (not (eql c (char s 0))))) collect (progn (incf count) (list i c s)) until (>= count 100))) nil) (deftest string.15 (when (> char-code-limit 65536) (loop for i = (random char-code-limit) for c = (code-char i) for s = (and c (string c)) repeat 2000 when (and c (or (not (stringp s)) (not (= (length s) 1)) (not (eql c (char s 0))))) collect (list i c s))) nil) (deftest string.16 (check-predicate #'(lambda (s) (or (not (stringp s)) (eq s (string s))))) nil) (deftest string.17 (typep* "abc" '(string)) t) (deftest string.18 (typep* "abc" '(string *)) t) (deftest string.19 (typep* "abc" '(string 3)) t) (deftest string.20 (typep* "abc" '(string 2)) nil) (deftest string.21 (typep* "abc" '(string 4)) nil) (deftest string.22 (do-special-strings (s "X") (assert (typep s 'string))) nil) (deftest string.23 (do-special-strings (s "X") (assert (typep s '(string)))) nil) (deftest string.24 (do-special-strings (s "X") (assert (typep s '(string *)))) nil) (deftest string.25 (do-special-strings (s "X") (or (array-has-fill-pointer-p s) (assert (typep s '(string 1))))) nil) (deftest string.26 (let ((i 0)) (values (string (progn (incf i) "")) i)) "" 1) ;;Spec does not appear to require this to be a fresh string ;#-gcl(def-fold-test string.fold.1 (string #\A)) (deftest string.fold.1 :notes (:string-on-character-can-be-constant) (flet ((%f nil (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) (debug 0))) (string #\a))) (eq (%f) (%f))) nil) ;;; Error tests (deftest string.error.1 (signals-error (string) program-error) t) (deftest string.error.2 (signals-error (string nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/stream-error-stream.lsp0000644000000000000000000000013214542551763020105 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.825790647 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/stream-error-stream.lsp0000644000175000017500000000121514542551763017502 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/special.lsp0000644000000000000000000000013214542551763015612 xustar0030 mtime=1703597043.024022464 30 atime=1744294960.825790647 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/special.lsp0000644000175000017500000000131114542551763015204 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 21 12:51:59 2005 ;;;; Contains: Tests of the declaration SPECIAL (in-package :cl-test) ;;; Many tests for this declaration are in the tests ;;; for specific binding forms. (deftest special.1 (let ((f 1)) (declare (special f)) (flet ((f () :good)) (flet ((g () (f))) (flet ((f () :bad)) (g))))) :good) (deftest special.2 (let ((x 'a)) (declare (special x)) (let ((x 'b)) (values x (locally (declare (special x)) x) x))) b a b) (deftest special.3 (flet ((%f () (declare (special x10)) x10)) (let ((x10 'a)) (declare (special x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) (%f))) a) gcl-2.7.1/ansi-tests/PaxHeaders/function-lambda-expression.lsp0000644000000000000000000000013214542551762021431 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.825790647 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/function-lambda-expression.lsp0000644000175000017500000000212114542551762021023 0ustar00cammcamm;-*- 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) ;;; Verify that it doesn't barf on generic functions (deftest function-lambda-expression.3 (length (multiple-value-list (function-lambda-expression #'meaningless-user-generic-function-for-universe))) 3) (deftest function-lambda-expression.order.1 (let ((i 0)) (function-lambda-expression (progn (incf i) #'cons)) i) 1) (deftest function-lambda-expression.error.1 (signals-error (function-lambda-expression) program-error) t) (deftest function-lambda-expression.error.2 (signals-error (function-lambda-expression #'cons nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/bit-vector.lsp0000644000000000000000000000013014542551762016245 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-vector.lsp0000644000175000017500000000424414542551762015651 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/array-as-class.lsp0000644000000000000000000000013214542551762017013 xustar0030 mtime=1703597042.916022294 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/array-as-class.lsp0000644000175000017500000000250014542551762016406 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/method-qualifiers.lsp0000644000000000000000000000013114542551763017613 xustar0030 mtime=1703597043.004022432 30 atime=1744294960.829790665 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/method-qualifiers.lsp0000644000175000017500000000234214542551763017213 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 11 07:14:12 2003 ;;;; Contains: Tests of METHOD-QUALIFIERS (in-package :cl-test) (defgeneric mq-generic-function (x)) (defparameter *mq-method-1* (defmethod mq-generic-function ((x integer)) (1+ x))) (deftest method-qualifiers.1 (method-qualifiers *mq-method-1*) nil) (defclass mq-class-01 () (a b c)) (defparameter *mq-method-2* (defmethod mq-generic-function :before ((x mq-class-01)) 'foo)) (deftest method-qualifiers.2 (method-qualifiers *mq-method-2*) (:before)) (defclass mq-class-02 () (e f g)) (defparameter *mq-method-3* (defmethod mq-generic-function :after ((x mq-class-02)) 'foo)) (deftest method-qualifiers.3 (method-qualifiers *mq-method-3*) (:after)) (defclass mq-class-03 () (h i j)) (defparameter *mq-method-4* (defmethod mq-generic-function :around ((x mq-class-03)) 'foo)) (deftest method-qualifiers.4 (method-qualifiers *mq-method-4*) (:around)) ;;; Need tests on user-defined method combinations (deftest method-qualifiers.error.1 (signals-error (method-qualifiers) program-error) t) (deftest method-qualifiers.error.2 (signals-error (method-qualifiers *mq-method-4* nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/bit-vector-p.lsp0000644000000000000000000000013014542551762016502 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/bit-vector-p.lsp0000644000175000017500000000274314542551762016110 0ustar00cammcamm;-*- 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 (check-type-predicate #'bit-vector-p 'bit-vector) nil) (deftest bit-vector-p.13 (macrolet ((%m (z) z)) (values (notnot (bit-vector-p (expand-in-current-env (%m #*110101)))) (bit-vector-p (expand-in-current-env (%m nil))))) t nil) (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 (signals-error (bit-vector-p) program-error) t) (deftest bit-vector-p.error.2 (signals-error (bit-vector-p #* #*) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/file-write-date.lsp0000644000000000000000000000013214542551762017153 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.829790665 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/file-write-date.lsp0000644000175000017500000000400614542551762016551 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/defun.lsp0000644000000000000000000000013214542551762015272 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defun.lsp0000644000175000017500000000577614542551762014707 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 16 23:40:32 2003 ;;;; Contains: Tests of DEFUN (in-package :cl-test) ;;; Tests for implicit blocks (defun defun-test-fun-1 () (return-from defun-test-fun-1 'good)) (deftest defun.1 (defun-test-fun-1) good) (defun defun-test-fun-2 () (return-from defun-test-fun-2 (values))) (deftest defun.2 (defun-test-fun-2)) (defun defun-test-fun-3 () (return-from defun-test-fun-3 (values 'a 'b 'c 'd 'e 'f))) (deftest defun.3 (defun-test-fun-3) a b c d e f) (defun defun-test-fun-4 (x) (car x)) (deftest defun.4 (let ((x (list 'a 'b))) (values (setf (defun-test-fun-4 x) 'c) x)) c (c b)) (report-and-ignore-errors (defun (setf defun-test-fun-4) (newval x) (return-from defun-test-fun-4 (setf (car x) newval)))) (deftest defun.5 (let ((x 1)) (declare (special x)) (let ((x 2)) (defun defun-test-fun-5 (&aux (y x)) (declare (special x)) (values y x)) (defun-test-fun-5))) 2 1) (deftest defun.6 (let ((x 1)) (declare (special x)) (let ((x 2)) (defun defun-test-fun-5 (&optional (y x)) (declare (special x)) (values y x)) (defun-test-fun-5))) 2 1) (deftest defun.7 (let ((x 1)) (declare (special x)) (let ((x 2)) (defun defun-test-fun-5 (&key (y x)) (declare (special x)) (values y x)) (defun-test-fun-5))) 2 1) ;; Documentation (deftest defun.8 (let* ((sym (gensym)) (doc "DEFUN.8") (form `(defun ,sym () ,doc nil))) (or (documentation sym 'function) doc)) "DEFUN.8") ;;; Error tests (deftest defun.error.1 (signals-error (funcall (macro-function 'defun)) program-error) t) (deftest defun.error.2 (signals-error (funcall (macro-function 'defun) '(defun nonexistent-function ())) program-error) t) (deftest defun.error.3 (signals-error (funcall (macro-function 'defun) '(defun nonexistent-function ()) nil nil) program-error) t) ;;; More comprehensive error handling tests of calls to ;;; user-defined functions (deftest defun.error.4 (let* ((name (gensym))) (loop for i below (min 100 lambda-parameters-limit) for params = nil then (cons (gensym) params) for args = nil then (cons nil args) for expected = '(1 2 3) for fn = (eval `(prog2 (proclaim '(optimize (safety 0))) (defun ,name ,params (values ,@expected)) (proclaim '(optimize safety)))) when (cond ((not (equal (multiple-value-list (apply fn args)) expected)) (list i :fail1)) ((not (equal (multiple-value-list (apply (symbol-function fn) args)) expected)) (list i :fail2)) ((not (equal (multiple-value-list (eval `(,name ,@args))) expected)) (list i :fail3)) ;; Error cases ((and (> i 0) (let ((val (eval `(signals-error (,name ,@(cdr args)) program-error)))) (and (not (eq val t)) :fail4)))) ((and (< i (1- call-arguments-limit)) (let ((val (eval `(signals-error (,name nil ,@args) program-error)))) (and (not (eq val t)) :fail5))))) collect it)) nil) gcl-2.7.1/ansi-tests/PaxHeaders/t.lsp0000644000000000000000000000013114542551763014434 xustar0029 mtime=1703597043.02802247 30 atime=1744294960.829790665 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/t.lsp0000644000175000017500000000060214542551763014031 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/cons-test-17.lsp0000644000000000000000000000013214542551762016335 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/cons-test-17.lsp0000644000175000017500000003202214542551762015732 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/fill-strings.lsp0000644000000000000000000000013214542551762016606 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.829790665 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/fill-strings.lsp0000644000175000017500000000117014542551762016203 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/continue.lsp0000644000000000000000000000013214542551762016015 xustar0030 mtime=1703597042.924022307 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/continue.lsp0000644000175000017500000000214614542551762015416 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 23 08:37:15 2003 ;;;; Contains: Tests of CONTINUE restart and function (in-package :cl-test) (deftest continue.1 (restart-case (progn (continue) 'bad) (continue () 'good)) good) (deftest continue.2 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (continue c2)) (continue () 'bad) (continue () 'good))) good) (deftest continue.3 (restart-case (progn (continue nil) 'bad) (continue () 'good)) good) (deftest continue.4 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 (list (first (compute-restarts))) (continue nil)) (continue () 'good) (continue () 'bad))) good) (deftest continue.5 (let ((c1 (make-condition 'error)) (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) ;; All conditions are now associated with c1 (continue c2))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/decf.lsp0000644000000000000000000000013214542551762015072 xustar0030 mtime=1703597042.972022382 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/decf.lsp0000644000175000017500000000710214542551762014470 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 4 20:50:54 2003 ;;;; Contains: Tests of DECF (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (deftest decf.1 (let ((x 12)) (values (decf x) x)) 11 11) (deftest decf.2 (let ((x 3.0s0)) (values (decf x) x)) 2.0s0 2.0s0) (deftest decf.3 (let ((x 19.0f0)) (values (decf x) x)) 18.0f0 18.0f0) (deftest decf.4 (let ((x 813.0d0)) (values (decf x) x)) 812.0d0 812.0d0) (deftest decf.5 (let ((x -17.0l0)) (values (decf x) x)) -18.0l0 -18.0l0) (deftest decf.6 (loop for x from 1 to 5 collect (let ((y x)) (list (decf y) y))) ((0 0) (1 1) (2 2) (3 3) (4 4))) (deftest decf.7 (loop for x in '(3.0s0 3.0f0 3.0d0 3.0l0) collect (let ((y x)) (list (decf y) y))) ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) (deftest decf.8 (loop for x in '(3.0s0 3.0f0 3.0d0 3.0f0) for y = (complex x 0) for z = (decf y) for x1c = (complex (1- x) 0) unless (and (eql y z) (eql x1c y)) collect (list x y z x1c)) nil) (deftest decf.9 (let ((x most-negative-fixnum)) (values (decf x) x)) #.(1- most-negative-fixnum) #.(1- most-negative-fixnum)) (deftest decf.10 (let ((x (1- most-negative-fixnum))) (values (decf x) x)) #.(- most-negative-fixnum 2) #.(- most-negative-fixnum 2)) (deftest decf.11 (loop for x in *numbers* unless (let* ((y x) (z (decf y))) (and (eql y (1- x)) (eql y z))) collect x) nil) ;;; Increment by other than 1 (deftest decf.12 (loop for x in *numbers* unless (let* ((y x) (z (decf y 0))) (and (eql x y) (eql y z))) collect x) nil) (deftest decf.13 (loop for x in *numbers* nconc (loop for r = (random-from-interval 1000000) repeat 100 when (let* ((y x) (z (decf y r))) (and (not (and (eql (- x r) y) (eql y z))) (list x y r))) collect it)) nil) (deftest decf.14 (let ((x 1)) (values (decf x 0.0s0) x)) 1.0s0 1.0s0) (deftest decf.15 (let ((x 1)) (values (decf x 0.0f0) x)) 1.0f0 1.0f0) (deftest decf.16 (let ((x 2)) (values (decf x 0.0d0) x)) 2.0d0 2.0d0) (deftest decf.17 (let ((x 10)) (values (decf x 0.0l0) x)) 10.0l0 10.0l0) (deftest decf.18 (let ((x 1)) (values (decf x #c(0.0s0 10.0s0)) x)) #c(1.0s0 -10.0s0) #c(1.0s0 -10.0s0)) (deftest decf.19 (let ((x 1)) (values (decf x #c(0.0f0 2.0f0)) x)) #c(1.0f0 -2.0f0) #c(1.0f0 -2.0f0)) (deftest decf.20 (let ((x 1)) (values (decf x #c(0.0d0 2.0d0)) x)) #c(1.0d0 -2.0d0) #c(1.0d0 -2.0d0)) (deftest decf.21 (let ((x 1)) (values (decf x #c(0.0l0 -2.0l0)) x)) #c(1.0l0 2.0l0) #c(1.0l0 2.0l0)) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest decf.22 (macrolet ((%m (z) z)) (let ((x 10)) (values (decf (expand-in-current-env (%m x))) x))) 9 9) (deftest decf.23 (macrolet ((%m (z) z)) (let ((x 5)) (values (decf x (expand-in-current-env (%m 3))) x))) 2 2) (deftest decf.order.2 (let ((a (vector 1 2 3 4)) (i 0) x y z) (values (decf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0)) (progn (setf z (incf i)) 17)) i x y z a)) -16 3 1 2 3 #(-16 2 3 4)) (deftest decf.order.3 (let ((a (vector 10 2 3 4)) (i 0) x y) (values (decf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 0))) i x y a)) 9 2 1 2 #(9 2 3 4)) (deftest decf.order.4 (let ((x 0)) (progn "See CLtS 5.1.3" (values (decf x (setf x 1)) x))) 0 0) gcl-2.7.1/ansi-tests/PaxHeaders/imagpart.lsp0000644000000000000000000000013114542551762015774 xustar0029 mtime=1703597042.99602242 30 atime=1744294960.829790665 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/imagpart.lsp0000644000175000017500000000166314542551762015401 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 7 07:47:43 2003 ;;;; Contains: Tests of IMAGPART (in-package :cl-test) (deftest imagpart.error.1 (signals-error (imagpart) program-error) t) (deftest imagpart.error.2 (signals-error (imagpart #c(1.0 2.0) nil) program-error) t) (deftest imagpart.error.3 (check-type-error #'imagpart #'numberp) nil) (deftest imagpart.1 (loop for x in *reals* for c = (complex 0 x) for ip = (imagpart c) unless (eql x ip) collect (list x c ip)) nil) (deftest imagpart.2 (loop for x in *reals* for c = (complex 1 x) for ip = (imagpart c) unless (eql x ip) collect (list x c ip)) nil) (deftest imagpart.3 (loop for x in *reals* for c = (complex x x) for ip = (imagpart c) unless (eql x ip) collect (list x c ip)) nil) (deftest imagpart.4 (loop for x in *reals* for ip = (imagpart x) unless (eql (* 0 x) ip) collect (list x ip (* 0 x))) nil) gcl-2.7.1/ansi-tests/PaxHeaders/load-symbols.lsp0000644000000000000000000000013214772071560016574 xustar0030 mtime=1743287152.274908044 30 atime=1744294960.829790665 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-symbols.lsp0000644000175000017500000000071714772071560016177 0ustar00cammcamm;;; Tests of symbols (compile-and-load "cl-symbols-aux.lsp") ;; (load "cl-symbol-names.lsp") ;; moved to gclload1.lsp (load "cl-symbols.lsp") (load "symbolp.lsp") (load "keywordp.lsp") (load "make-symbol.lsp") (load "copy-symbol.lsp") (load "gensym.lsp") (load "gentemp.lsp") (load "symbol-function.lsp") (load "symbol-name.lsp") (load "boundp.lsp") (load "special-operator-p.lsp") (load "makunbound.lsp") (load "set.lsp") (load "remprop.lsp") (load "get.lsp") gcl-2.7.1/ansi-tests/PaxHeaders/with-open-stream.lsp0000644000000000000000000000013214542551763017375 xustar0030 mtime=1703597043.032022476 30 atime=1744294960.833790682 30 ctime=1744351535.662907604 gcl-2.7.1/ansi-tests/with-open-stream.lsp0000644000175000017500000000352014542551763016773 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/defparameter.lsp0000644000000000000000000000013214542551762016630 xustar0030 mtime=1703597042.980022395 30 atime=1744294960.833790682 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defparameter.lsp0000644000175000017500000000424614542551762016234 0ustar00cammcamm;-*- 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 ;;; (signals-error (defparameter) program-error) ;;; t) ;;; ;;; (deftest defparameter.error.2 ;;; (signals-error (defparameter *ignored-defparameter-name*) ;;; program-error) ;;; t) ;;; ;;; (deftest defparameter.error.3 ;;; (signals-error (defparameter *ignored-defparameter-name* nil ;;; "documentation" ;;; "illegal extra argument") ;;; program-error) ;;; t) (deftest defparameter.error.1 (signals-error (funcall (macro-function 'defparameter)) program-error) t) (deftest defparameter.error.2 (signals-error (funcall (macro-function 'defparameter) '(defparameter *nonexistent-variable* nil)) program-error) t) (deftest defparameter.error.3 (signals-error (funcall (macro-function 'defparameter) '(defparameter *nonexistent-variable* nil) nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/compile-file.lsp0000644000000000000000000000013214772071542016534 xustar0030 mtime=1743287138.658895479 30 atime=1744294960.833790682 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/compile-file.lsp0000644000175000017500000001512314772071542016134 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 9 08:25:25 2005 ;;;; Contains: Tests of COMPILE-FILE (in-package :cl-test) (defun compile-file-test (file funname &rest args &key expect-warnings expect-style-warnings output-file (print nil print-p) (verbose nil verbose-p) (*compile-print* nil) (*compile-verbose* nil) external-format) (declare (ignorable external-format)) (let* ((target-pathname (or output-file (compile-file-pathname file))) (actual-warnings-p nil) (actual-style-warnings-p nil)) (when (probe-file target-pathname) (delete-file target-pathname)) (fmakunbound funname) (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0)) (vals (multiple-value-list (handler-bind ((style-warning #'(lambda (c) (declare (ignore c)) (setf actual-style-warnings-p t) nil)) ((or error warning) #'(lambda (c) (unless (typep c 'style-warning) (setf actual-warnings-p t)) nil))) (with-output-to-string (*standard-output* str) (apply #'compile-file file :allow-other-keys t args)))))) (assert (= (length vals) 3)) (destructuring-bind (output-truename warnings-p failure-p) vals (print (namestring (truename target-pathname))) (print (namestring output-truename)) (values (let ((v1 (or print verbose (and (not print-p) *compile-print*) (and (not verbose-p) *compile-verbose*) (string= str ""))) (v2 (or (and verbose-p (not verbose)) (and (not verbose-p) (not *compile-verbose*)) (position #\; str))) (v3 (if actual-warnings-p failure-p t)) (v4 (if expect-warnings failure-p t)) (v5 (if expect-style-warnings warnings-p t)) (v6 (or (null output-truename) (pathnamep output-truename))) (v7 (equalpt-or-report (namestring (truename target-pathname)) (namestring output-truename))) (v8 (not (fboundp funname)))) (if (and v1 v2 v3 v4 v5 v6 (eql v7 t) v8) t (list v1 v2 v3 v4 v5 v6 v7 v8))) (progn (load output-truename) (funcall funname))))))) (deftest compile-file.1 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest compile-file.2 (compile-file-test "compile-file-test-file-2.lsp" 'compile-file-test-fun.2 :expect-style-warnings t) t nil) (deftest compile-file.2a (compile-file-test "compile-file-test-file-2a.lsp" 'compile-file-test-fun.2a :expect-warnings t) t nil) (deftest compile-file.3 (let ((*package* (find-package "CL-TEST"))) (compile-file-test "compile-file-test-file-3.lsp" 'compile-file-test-fun.3)) t nil) (deftest compile-file.4 (let ((*package* (find-package "CL-USER"))) (compile-file-test "compile-file-test-file-3.lsp" 'cl-user::compile-file-test-fun.3)) t nil) (deftest compile-file.5 (compile-file-test #p"compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest compile-file.6 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file "foo.fasl") t nil) (deftest compile-file.6a (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file "foo.ufsl") t nil) (deftest compile-file.7 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :external-format :default) t nil) (deftest compile-file.8 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file #p"foo.fasl") t nil) (deftest compile-file.9 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :print t) t nil) (deftest compile-file.10 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :verbose t) t nil) (deftest compile-file.11 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :print nil) t nil) (deftest compile-file.12 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :verbose nil) t nil) ;;; A file stream is a pathname designator (deftest compile-file.13 (with-open-file (s "compile-file-test-file.lsp" :direction :input) (compile-file-test s 'compile-file-test-fun.1)) t nil) (deftest compile-file.14 (let ((s (open "foo.fasl" :direction :output :if-exists :supersede :if-does-not-exist :create))) (close s) (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file s)) t nil) (deftest compile-file.15 (let ((*readtable* (copy-readtable nil))) (set-macro-character #\! (get-macro-character #\')) (compile-file-test "compile-file-test-file-4.lsp" 'compile-file-test-fun.4)) t foo) ;;; Tests for *compile-file-truename*, *compile-file-pathname* (deftest compile-file.16 (let* ((file #p"compile-file-test-file-5.lsp") (target-pathname (compile-file-pathname file)) (*compile-print* nil) (*compile-verbose* nil)) (when (probe-file target-pathname) (delete-file target-pathname)) (compile-file file) (load target-pathname) (values (equalpt-or-report (truename file) (funcall 'compile-file-test-fun.5)) (equalpt-or-report (pathname (merge-pathnames file)) (funcall 'compile-file-test-fun.5a)))) t t) ;;; Add tests of logical pathnames (deftest compile-file.17 (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.LSP"))) (with-open-file (s file :direction :output :if-exists :supersede :if-does-not-exist :create) (format s "(in-package :cl-test)~%(defun compile-file-test-lp.fun () nil)~%")) (compile-file-test file 'compile-file-test-lp.fun)) t nil) (deftest compile-file.18 (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.OUT"))) (with-open-file (s file :direction :output :if-exists :supersede :if-does-not-exist :create)) (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :output-file file)) t nil) (deftest compile-file.19 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*compile-verbose* t) t nil) (deftest compile-file.20 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*compile-print* t) t nil) (deftest compile-file-pathname.1 *compile-file-pathname* nil) (deftest compile-file-truename.1 *compile-file-truename* nil) ;;; Error cases (deftest compile-file.error.1 (signals-error (compile-file "nonexistent-file-to-compile.lsp") file-error) t) (deftest compile-file.error.2 (signals-error (compile-file) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/exp-aux.lsp0000644000000000000000000000013214542551762015560 xustar0030 mtime=1703597042.988022407 30 atime=1744294960.833790682 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/exp-aux.lsp0000644000175000017500000000101714542551762015155 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 1 21:30:38 2003 ;;;; Contains: Aux. functions for testing EXP, EXPT (in-package :cl-test) (defun my-exp (x n) "Compute e^x in the appropriate float result type, summing the first n terms of the Taylor series." (assert (realp x)) (let ((result 1) (xrat (rational x))) (loop for i from (1- n) downto 1 do (setq result (+ 1 (/ (* xrat result) i)))) (if (floatp x) (float result x) (float result 1.0f0)))) gcl-2.7.1/ansi-tests/PaxHeaders/defclass-forward-reference.lsp0000644000000000000000000000013214542551762021353 xustar0030 mtime=1703597042.976022388 30 atime=1744294960.833790682 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/defclass-forward-reference.lsp0000644000175000017500000000711114542551762020751 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 2 22:53:27 2003 ;;;; Contains: Tests for definitions of classes with forward references (in-package :cl-test) (deftest defclass.forward-ref.1 (let ((c1 (gensym)) (c2 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) (if (not (typep class1 'class)) 1 (let ((class2 (eval `(defclass ,c2 nil nil)))) (if (not (typep class2 'class)) 2 (let ((i1 (make-instance c1)) (i2 (make-instance c2))) (cond ((not (typep i1 c1)) 3) ((not (typep i1 class1)) 4) ((not (typep i1 c2)) 5) ((not (typep i1 class2)) 6) ((typep i2 c1) 7) ((typep i2 class1) 8) ((not (typep i2 c2)) 9) ((not (typep i2 class2)) 10) (t 'good)))))))) good) (deftest defclass.forward-ref.2 (let ((c1 (gensym)) (c2 (gensym)) (c3 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2 ,c3) nil)))) (if (not (typep class1 'class)) 1 (let ((class2 (eval `(defclass ,c2 nil nil)))) (if (not (typep class2 'class)) 2 (let ((class3 (eval `(defclass ,c3 nil nil)))) (if (not (typep class3 'class)) 3 (let ((i1 (make-instance c1)) (i2 (make-instance c2)) (i3 (make-instance c3))) (cond ((not (typep i1 c1)) 4) ((not (typep i1 class1)) 5) ((not (typep i1 c2)) 6) ((not (typep i1 class2)) 7) ((not (typep i1 c3)) 8) ((not (typep i1 class3)) 9) ((typep i2 c1) 10) ((typep i2 class1) 11) ((typep i3 c1) 12) ((typep i3 class1) 13) ((not (typep i2 c2)) 14) ((not (typep i2 class2)) 15) ((not (typep i3 c3)) 16) ((not (typep i3 class3)) 17) ((typep i2 c3) 18) ((typep i2 class3) 19) ((typep i3 c2) 20) ((typep i3 class2) 21) (t 'good)))))))))) good) (deftest defclass.forward-ref.3 (let ((c1 (gensym)) (c2 (gensym)) (c3 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) (if (not (typep class1 'class)) 1 (let ((class2 (eval `(defclass ,c2 (,c3) nil)))) (if (not (typep class2 'class)) 2 (let ((class3 (eval `(defclass ,c3 nil nil)))) (if (not (typep class3 'class)) 3 (let ((i1 (make-instance c1)) (i2 (make-instance c2)) (i3 (make-instance c3))) (cond ((not (typep i1 c1)) 4) ((not (typep i1 class1)) 5) ((not (typep i1 c2)) 6) ((not (typep i1 class2)) 7) ((not (typep i1 c3)) 8) ((not (typep i1 class3)) 9) ((typep i2 c1) 10) ((typep i2 class1) 11) ((typep i3 c1) 12) ((typep i3 class1) 13) ((not (typep i2 c2)) 14) ((not (typep i2 class2)) 15) ((not (typep i3 c3)) 16) ((not (typep i3 class3)) 17) ((not (typep i2 c3)) 18) ((not (typep i2 class3)) 19) ((typep i3 c2) 20) ((typep i3 class2) 21) (t 'good)))))))))) good) (deftest defclass.forward-ref.4 (block nil (let ((c1 (gensym)) (c2 (gensym)) (c3 (gensym)) (c4 (gensym)) (c5 (gensym))) (unless (typep (eval `(defclass ,c4 nil nil)) 'class) (return 1)) (unless (typep (eval `(defclass ,c5 nil nil)) 'class) (return 2)) (unless (typep (eval `(defclass ,c1 (,c2 ,c3) nil)) 'class) (return 3)) (unless (typep (eval `(defclass ,c2 (,c4 ,c5) nil)) 'class) (return 4)) (handler-case (eval `(progn (defclass ,c3 (,c5 ,c4) nil) (make-instance ',c1))) (error () :good)))) :good) gcl-2.7.1/ansi-tests/PaxHeaders/format.lsp0000644000000000000000000000013214542551762015461 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.833790682 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/format.lsp0000644000175000017500000000050714542551762015061 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 23 05:08:17 2004 ;;;; Contains: Tests of FORMAT (in-package :cl-test) (defun def-format-test (name args result) `(deftest ,name (equalt (with-standard-io-syntax (with-output-to-string (s) (format s ,@args))) result) t)) gcl-2.7.1/ansi-tests/PaxHeaders/remf.lsp0000644000000000000000000000013114542551763015122 xustar0030 mtime=1703597043.020022457 30 atime=1744294960.833790682 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/remf.lsp0000644000175000017500000000360314542551763014523 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 20 07:38:18 2003 ;;;; Contains: Tests of REMF (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest remf.5 (macrolet ((%m (z) z)) (let ((x nil)) (values (remf (expand-in-current-env (%m x)) 'a) x))) nil nil) (deftest remf.6 (macrolet ((%m (z) z)) (let ((x (list 'a 'b))) (values (notnot (remf (expand-in-current-env (%m x)) 'a)) x))) t nil) (deftest remf.7 (macrolet ((%m (z) z)) (let ((x (list 'a 'b 'c 'd))) (values (notnot (remf x (expand-in-current-env (%m 'a)))) x))) t (c d)) (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) (deftest remf.order.2 (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 remf.order.3 (let ((x (list 'a 'b 'c 'd))) (progn "See CLtS 5.1.3" (values (remf x (progn (setq x (list 'e 'f)) 'a)) x))) nil (e f)) (def-macro-test remf.error.1 (remf x 'a)) gcl-2.7.1/ansi-tests/PaxHeaders/find-all-symbols.lsp0000644000000000000000000000013214542551762017345 xustar0030 mtime=1703597042.992022413 30 atime=1744294960.833790682 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/find-all-symbols.lsp0000644000175000017500000000675714542551762016762 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 22 07:10:22 2004 ;;;; Contains: Tests for FIND-ALL-SYMBOLS (in-package :cl-test) (deftest find-all-symbols.1 (let ((all-packages (list-all-packages))) (loop for package in all-packages append (let ((failures nil)) (do-symbols (sym package failures) (when (eql (symbol-package sym) package) (let* ((name (symbol-name sym)) (similar (find-all-symbols name)) (similar2 (find-all-symbols sym))) (unless (and (member sym similar) (subsetp similar similar2) (subsetp similar2 similar) (loop for sym2 in similar always (string= name (symbol-name sym2)))) (push sym failures)))))))) nil) ;;; FIXME -- test that each symbol found is accessible in some package (deftest find-all-symbols.2 (loop for i from 0 to 255 for c = (code-char i) when (and (characterp c) (loop for sym in (find-all-symbols c) thereis (not (string= (symbol-name sym) (string c))))) collect c) nil) ;;; Unusual strings (deftest find-all-symbols.3 (let* ((name (make-array '(3) :initial-contents "NIL" :element-type 'base-char)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.4 (let* ((name (make-array '(5) :initial-contents "NILXY" :fill-pointer 3 :element-type 'character)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.5 (let* ((name (make-array '(5) :initial-contents "NILXY" :fill-pointer 3 :element-type 'base-char)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.6 (let* ((name (make-array '(3) :initial-contents "NIL" :adjustable t :element-type 'base-char)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.7 (let* ((name (make-array '(3) :initial-contents "NIL" :adjustable t :element-type 'character)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.8 (let* ((type 'character) (name0 (make-array '(9) :initial-contents "XYZNILABC" :element-type type)) (name (make-array '(3) :element-type type :displaced-to name0 :displaced-index-offset 3)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) (deftest find-all-symbols.9 (let* ((type 'base-char) (name0 (make-array '(9) :initial-contents "XYZNILABC" :element-type type)) (name (make-array '(3) :element-type type :displaced-to name0 :displaced-index-offset 3)) (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) t t) ;;; Error tests (deftest find-all-symbols.error.1 (signals-error (find-all-symbols) program-error) t) (deftest find-all-symbols.error.2 (signals-error (find-all-symbols "CAR" nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/open.lsp0000644000000000000000000000013114542551763015132 xustar0030 mtime=1703597043.012022445 30 atime=1744294960.833790682 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/open.lsp0000644000175000017500000010723214542551763014536 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/class-of.lsp0000644000000000000000000000013014542551762015676 xustar0028 mtime=1703597042.9200223 30 atime=1744294960.833790682 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/class-of.lsp0000644000175000017500000000053714542551762015303 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jun 16 19:40:32 2003 ;;;; Contains: Tests of CLASS-OF (in-package :cl-test) ;;; Most tests of CLASS-OF are in other files (deftest class-of.error.1 (signals-error (class-of) program-error) t) (deftest class-of.error.2 (signals-error (class-of nil nil) program-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/asin.lsp0000644000000000000000000000013014542551762015121 xustar0030 mtime=1703597042.916022294 28 atime=1744294960.8377907 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/asin.lsp0000644000175000017500000000451614542551762014527 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 11 05:59:43 2004 ;;;; Contains: Tests for ASIN (in-package :cl-test) (deftest asin.1 (loop for i from -1000 to 1000 for rlist = (multiple-value-list (asin i)) for y = (car rlist) always (and (null (cdr rlist)) (numberp y))) t) (deftest asin.2 (loop for type in '(short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (asin x)) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t)) (deftest asin.3 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x = (- (random a) b) for rlist = (multiple-value-list (asin (complex 0 x))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest asin.4 (loop for type in '(integer short-float single-float double-float long-float) collect (let ((a (coerce 2000 type)) (b (coerce -1000 type))) (loop for x1 = (- (random a) b) for x2 = (- (random a) b) for rlist = (multiple-value-list (asin (complex x1 x2))) for y = (car rlist) repeat 1000 always (and (null (cdr rlist)) (numberp y))))) (t t t t t)) (deftest asin.5 (approx= (asin 1) (coerce (/ pi 2) 'single-float)) t) (deftest asin.6 (loop for type in '(single-float short-float double-float long-float) unless (approx= (asin (coerce 1 type)) (coerce (/ pi 2) type)) collect type) nil) (deftest asin.7 (loop for type in '(single-float short-float double-float long-float) unless (approx= (asin (coerce 0 type)) (coerce 0 type)) collect type) nil) (deftest asin.8 (loop for type in '(single-float short-float double-float long-float) unless (approx= (asin (coerce -1 type)) (coerce (/ pi -2) type)) collect type) nil) (deftest asin.9 (macrolet ((%m (z) z)) (asin (expand-in-current-env (%m 0.0)))) 0.0) ;;; FIXME ;;; Add accuracy tests ;;; Error tests (deftest asin.error.1 (signals-error (asin) program-error) t) (deftest asin.error.2 (signals-error (asin 0.0 0.0) program-error) t) (deftest asin.error.3 (check-type-error #'asin #'numberp) nil) gcl-2.7.1/ansi-tests/PaxHeaders/floor.lsp0000644000000000000000000000013014542551762015310 xustar0030 mtime=1703597042.992022413 28 atime=1744294960.8377907 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/floor.lsp0000644000175000017500000000717614542551762014723 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 4 22:16:00 2003 ;;;; Contains: Tests of FLOOR (in-package :cl-test) (compile-and-load "numbers-aux.lsp") (compile-and-load "floor-aux.lsp") ;;; Error tests (deftest floor.error.1 (signals-error (floor) program-error) t) (deftest floor.error.2 (signals-error (floor 1.0 1 nil) program-error) t) ;;; Non-error tests (deftest floor.1 (floor.1-fn) nil) (deftest floor.2 (floor.2-fn) nil) (deftest floor.3 (floor.3-fn 2.0s4) nil) (deftest floor.4 (floor.3-fn 2.0f4) nil) (deftest floor.5 (floor.3-fn 2.0d4) nil) (deftest floor.6 (floor.3-fn 2.0l4) nil) (deftest floor.7 (floor.7-fn) nil) (deftest floor.8 (floor.8-fn) nil) (deftest floor.9 (floor.9-fn) nil) (deftest floor.10 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (floor x x)) unless (and (eql q 1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest floor.11 (loop for x in (remove-if #'zerop *reals*) for (q r) = (multiple-value-list (floor (- x) x)) unless (and (eql q -1) (zerop r) (if (rationalp x) (eql r 0) (eql r (float 0 x)))) collect x) nil) (deftest floor.12 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.13 (let* ((radix (float-radix 1.0s0)) (rad (float radix 1.0s0)) (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.14 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.15 (let* ((radix (float-radix 1.0f0)) (rad (float radix 1.0f0)) (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.16 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.17 (let* ((radix (float-radix 1.0d0)) (rad (float radix 1.0d0)) (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.18 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (+ i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q i) (eql r rrad)) collect (list i x q r))) nil) (deftest floor.19 (let* ((radix (float-radix 1.0l0)) (rad (float radix 1.0l0)) (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 for x = (- i rrad) for (q r) = (multiple-value-list (floor x)) unless (and (eql q (1- i)) (eql r rrad)) collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants ;;; (suitably scaled) to floated integers. gcl-2.7.1/ansi-tests/PaxHeaders/nreconc.lsp0000644000000000000000000000012714542551763015625 xustar0030 mtime=1703597043.008022439 28 atime=1744294960.8377907 29 ctime=1744351535.65890764 gcl-2.7.1/ansi-tests/nreconc.lsp0000644000175000017500000000162714542551763015225 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 19 22:38:12 2003 ;;;; Contains: Tests of NRECONC (in-package :cl-test) (compile-and-load "cons-aux.lsp") (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 (signals-error (nreconc) program-error) t) (deftest nreconc.error.2 (signals-error (nreconc nil) program-error) t) (deftest nreconc.error.3 (signals-error (nreconc nil nil nil) program-error) t) (deftest nreconc.error.4 (signals-error (nreconc (cons 'a 'b) (list 'z)) type-error) t) gcl-2.7.1/ansi-tests/PaxHeaders/load-iteration.lsp0000644000000000000000000000013014772071553017102 xustar0030 mtime=1743287147.518903474 28 atime=1744294960.8377907 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/load-iteration.lsp0000644000175000017500000000074014772071553016503 0ustar00cammcamm;;; Tests of iteration forms ;;(load "iteration.lsp") (load "do.lsp") (load "dostar.lsp") (load "dolist.lsp") (load "dotimes.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.7.1/ansi-tests/PaxHeaders/adjust-array.lsp0000644000000000000000000000013014542551762016575 xustar0030 mtime=1703597042.916022294 28 atime=1744294960.8377907 30 ctime=1744351535.650907712 gcl-2.7.1/ansi-tests/adjust-array.lsp0000644000175000017500000010125514542551762016201 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 15 07:27:22 2004 ;;;; Contains: Tests of ADJUST-ARRAY (in-package :cl-test) (defun listify-form (form) (cond ((integerp form) `'(,form)) ((null form) nil) ((and (consp form) (eq (car form) 'quote) (consp (cadr form))) form) (t `(let ((x ,form)) (if (listp x) x (list x)))))) (defmacro def-adjust-array-test (name args1 args2 expected-result) `(deftest ,name (let* ((a1 (make-array ,@args1)) (a2 (adjust-array a1 ,@args2))) (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) (assert (or (adjustable-array-p a1) (equal (array-dimensions a1) ,(listify-form (first args1))))) (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) ,@(unless (or (member :displaced-to args1) (member :displaced-to args2)) (list '(assert (not (array-displacement a2))))) a2) ,expected-result)) (defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results) `(deftest ,name (let* ((a1 (make-array ,@args1)) (a2 (adjust-array a1 ,@args2))) (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) (assert (or (adjustable-array-p a1) (equal (array-dimensions a1) ,(listify-form (first args1))))) (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) ,@(unless (or (member :displaced-to args1) (member :displaced-to args2)) (list '(assert (not (array-displacement a2))))) ,@(when misc (list misc)) (values (fill-pointer a2) a2)) ,@expected-results)) (def-adjust-array-test adjust-array.1 (5 :initial-contents '(a b c d e)) (4) #(a b c d)) (def-adjust-array-test adjust-array.2 (5 :initial-contents '(a b c d e)) (8 :initial-element 'x) #(a b c d e x x x)) (def-adjust-array-test adjust-array.3 (5 :initial-contents '(a b c d e)) (4 :initial-contents '(w x y z)) #(w x y z)) (def-adjust-array-test adjust-array.4 (5 :initial-contents '(a b c d e)) (8 :initial-contents '(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1)) (def-adjust-array-fp-test adjust-array.5 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.6 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4 :fill-pointer nil) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.7 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4 :fill-pointer t) nil 4 #(a b c d)) (def-adjust-array-fp-test adjust-array.8 (5 :initial-contents '(a b c d e) :fill-pointer 3) (4 :fill-pointer 2) (progn (assert (eq (aref a2 2) 'c)) (assert (eq (aref a2 3) 'd))) 2 #(a b)) (def-adjust-array-fp-test adjust-array.9 (5 :initial-contents '(a b c d e) :fill-pointer 3) (8 :fill-pointer 5 :initial-element 'x) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) 5 #(a b c d e)) (deftest adjust-array.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e))) (a2 (adjust-array a1 4 :displaced-to nil))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.11 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (adjust-array a1 4))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.12 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :initial-contents '(a b c d e))) (a2 (adjust-array a1 4 :displaced-to a0))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #(1 2 3 4)) (deftest adjust-array.13 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :initial-contents '(a b c d e))) (a2 (adjust-array a1 4 :displaced-to a0 :displaced-index-offset 2))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 2))) a2) #(3 4 5 6)) (deftest adjust-array.14 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (adjust-array a1 4 :displaced-to a0))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #(1 2 3 4)) (deftest adjust-array.15 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)) (a3 (adjust-array a2 4 :displaced-to a1))) a3) #(2 3 4 5)) (deftest adjust-array.16 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) (a2 (adjust-array a1 5 :displaced-to a0))) a2) #(1 2 3 4 5)) (def-adjust-array-test adjust-array.17 (nil :initial-element 'x) (nil) #0ax) (def-adjust-array-test adjust-array.18 (nil :initial-element 'x) (nil :initial-contents 'y) #0ay) (def-adjust-array-test adjust-array.19 (nil :initial-element 'x) (nil :initial-element 'y) #0ax) (deftest adjust-array.20 (let* ((a0 (make-array nil :initial-element 'x)) (a1 (make-array nil :displaced-to a0)) (a2 (adjust-array a1 nil))) a2) #0ax) ;; 2-d arrays (def-adjust-array-test adjust-array.21 ('(4 5) :initial-contents '((1 2 3 4 5) (3 4 5 6 7) (5 6 7 8 9) (7 8 9 1 2))) ('(2 3)) #2a((1 2 3)(3 4 5))) (def-adjust-array-test adjust-array.22 ('(4 5) :initial-contents '((1 2 3 4 5) (3 4 5 6 7) (5 6 7 8 9) (7 8 9 1 2))) ('(6 8) :initial-element 0) #2a((1 2 3 4 5 0 0 0) (3 4 5 6 7 0 0 0) (5 6 7 8 9 0 0 0) (7 8 9 1 2 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0))) (deftest adjust-array.23 (let* ((a1 (make-array '(4 5) :initial-contents '((#\1 #\2 #\3 #\4 #\5) (#\3 #\4 #\5 #\6 #\7) (#\5 #\6 #\7 #\8 #\9) (#\7 #\8 #\9 #\1 #\2)) :element-type 'character)) (a2 (adjust-array a1 '(2 3) :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a2) '(2 3)))) (assert (not (typep 0 (array-element-type a2)))) a2) #2a((#\1 #\2 #\3)(#\3 #\4 #\5))) ;;; Macro expansion tests (deftest adjust-array.24 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array (expand-in-current-env (%m a)) '(4)))) #(a b c d)) (deftest adjust-array.25 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a (expand-in-current-env (%m '(4)))))) #(a b c d)) (deftest adjust-array.26 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) (expand-in-current-env (%m :element-type)) t))) #(a b c d)) (deftest adjust-array.27 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :element-type (expand-in-current-env (%m t))))) #(a b c d)) (deftest adjust-array.28 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(6) (expand-in-current-env (%m :initial-element)) 17))) #(a b c d 17 17)) (deftest adjust-array.29 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(7) :initial-element (expand-in-current-env (%m 5))))) #(a b c d 5 5 5)) (deftest adjust-array.30 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(6) (expand-in-current-env (%m :initial-contents)) '(1 2 3 4 5 6)))) #(1 2 3 4 5 6)) (deftest adjust-array.31 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(3) :initial-contents (expand-in-current-env (%m "ABC"))))) #(#\A #\B #\C)) (deftest adjust-array.32 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) (expand-in-current-env (%m :fill-pointer)) nil))) #(a b c d)) (deftest adjust-array.33 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :fill-pointer (expand-in-current-env (%m nil))))) #(a b c d)) (deftest adjust-array.34 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) (expand-in-current-env (%m :displaced-to)) nil))) #(a b c d)) (deftest adjust-array.35 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :displaced-to (expand-in-current-env (%m nil))))) #(a b c d)) (deftest adjust-array.36 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d))) (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) (adjust-array a '(3) :displaced-to c (expand-in-current-env (%m :displaced-index-offset)) 2))) #(3 4 5)) (deftest adjust-array.37 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d))) (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) (adjust-array a '(5) :displaced-to c :displaced-index-offset (expand-in-current-env (%m 1))))) #(2 3 4 5 6)) ;;; Adjust an adjustable array (def-adjust-array-test adjust-array.adjustable.1 (5 :initial-contents '(a b c d e) :adjustable t) (4) #(a b c d)) (def-adjust-array-test adjust-array.adjustable.2 (5 :initial-contents '(a b c d e) :adjustable t) (8 :initial-element 'x) #(a b c d e x x x)) (def-adjust-array-test adjust-array.adjustable.3 (5 :initial-contents '(a b c d e) :adjustable t) (4 :initial-contents '(w x y z)) #(w x y z)) (def-adjust-array-test adjust-array.adjustable.4 (5 :initial-contents '(a b c d e) :adjustable t) (8 :initial-contents '(8 7 6 5 4 3 2 1)) #(8 7 6 5 4 3 2 1)) (def-adjust-array-fp-test adjust-array.adjustable.5 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.adjustable.6 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4 :fill-pointer nil) (assert (eq (aref a2 3) 'd)) 3 #(a b c)) (def-adjust-array-fp-test adjust-array.adjustable.7 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4 :fill-pointer t) nil 4 #(a b c d)) (def-adjust-array-fp-test adjust-array.adjustable.8 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (4 :fill-pointer 2) (assert (equal (list (aref a2 2) (aref a2 3)) '(c d))) 2 #(a b)) (def-adjust-array-fp-test adjust-array.adjustable.9 (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) (8 :fill-pointer 5 :initial-element 'x) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) 5 #(a b c d e)) (deftest adjust-array.adjustable.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e) :adjustable t)) (a2 (adjust-array a1 4 :displaced-to nil))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.adjustable.11 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t)) (a2 (adjust-array a1 4))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.adjustable.12 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t)) (a2 (adjust-array a1 4 :displaced-to a0))) (assert (eq a1 a2)) a2) #(x a b c)) (deftest adjust-array.adjustable.13 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 :displaced-index-offset 2))) a2) #(c d e y)) ;;;; Strings (loop for element-type in '(character base-char) for forms = `( (def-adjust-array-test adjust-array.string.1 (5 :element-type 'character :initial-contents "abcde") (4 :element-type 'character) "abcd") (def-adjust-array-test adjust-array.string.2 (5 :element-type 'character :initial-contents "abcde") (8 :element-type 'character :initial-element #\x) "abcdexxx") (def-adjust-array-test adjust-array.string.3 (5 :element-type 'character :initial-contents "abcde") (4 :element-type 'character :initial-contents "wxyz") "wxyz") (def-adjust-array-test adjust-array.string.4 (5 :element-type 'character :initial-contents "abcde") (8 :element-type 'character :initial-contents "87654321") "87654321") (def-adjust-array-fp-test adjust-array.string.5 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.6 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character :fill-pointer nil) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.7 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character :fill-pointer t) nil 4 "abcd") (def-adjust-array-fp-test adjust-array.string.8 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character :fill-pointer 2) (progn (assert (eql (aref a2 2) #\c)) (assert (eql (aref a2 3) #\d))) 2 "ab") (def-adjust-array-fp-test adjust-array.string.9 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (8 :element-type 'character :fill-pointer 5 :initial-element #\x) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(#\x #\x #\x))) 5 "abcde") (deftest adjust-array.string.10 (let* ((a1 (make-array 5 :element-type 'character :initial-contents "abcde")) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.11 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (adjust-array a1 4 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.12 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) "1234") (deftest adjust-array.string.13 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :displaced-index-offset 2 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 2))) a2) "3456") (deftest adjust-array.string.14 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) "1234") (deftest adjust-array.string.15 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'character)) (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'character))) a3) "2345") (deftest adjust-array.string.16 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'character)) (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'character))) a2) "12345") (def-adjust-array-test adjust-array.string.17 (nil :initial-element #\x :element-type 'character) (nil) #.(make-array nil :initial-element #\x :element-type 'character)) (def-adjust-array-test adjust-array.string.18 (nil :initial-element #\x :element-type 'character) (nil :initial-contents #\y :element-type 'character) #.(make-array nil :initial-element #\y :element-type 'character)) (def-adjust-array-test adjust-array.string.19 (nil :initial-element #\x :element-type 'character) (nil :initial-element #\y :element-type 'character) #.(make-array nil :initial-element #\x :element-type 'character)) (deftest adjust-array.string.20 (let* ((a0 (make-array nil :initial-element #\x :element-type 'character)) (a1 (make-array nil :displaced-to a0 :element-type 'character)) (a2 (adjust-array a1 nil :element-type 'character))) a2) #.(make-array nil :initial-element #\x :element-type 'character)) (def-adjust-array-test adjust-array.string.adjustable.1 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (4 :element-type 'character) "abcd") (def-adjust-array-test adjust-array.string.adjustable.2 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (8 :initial-element #\x :element-type 'character) "abcdexxx") (def-adjust-array-test adjust-array.string.adjustable.3 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (4 :initial-contents "wxyz" :element-type 'character) "wxyz") (def-adjust-array-test adjust-array.string.adjustable.4 (5 :initial-contents "abcde" :adjustable t :element-type 'character) (8 :initial-contents "87654321" :element-type 'character) "87654321") (def-adjust-array-fp-test adjust-array.string.adjustable.5 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :element-type 'character :initial-element #\Space) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.adjustable.6 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :fill-pointer nil :element-type 'character :initial-element #\?) (assert (eql (aref a2 3) #\d)) 3 "abc") (def-adjust-array-fp-test adjust-array.string.adjustable.7 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :fill-pointer t :element-type 'character :initial-element #\!) nil 4 "abcd") (def-adjust-array-fp-test adjust-array.string.adjustable.8 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (4 :fill-pointer 2 :element-type 'character :initial-element #\X) (assert (equal (list (aref a2 2) (aref a2 3)) '(#\c #\d))) 2 "ab") (def-adjust-array-fp-test adjust-array.string.adjustable.9 (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) (8 :fill-pointer 5 :initial-element #\x :element-type 'character) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(#\x #\x #\x))) 5 "abcde") (deftest adjust-array.string.adjustable.10 (let* ((a1 (make-array 5 :initial-contents "abcde" :adjustable t :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.adjustable.11 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'character)) (a2 (adjust-array a1 4 :element-type 'character))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.adjustable.12 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'character)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (eq a1 a2)) a2) "xabc") (deftest adjust-array.string.adjustable.13 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'character)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'character))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 :displaced-index-offset 2 :element-type 'character))) a2) "cdey") ) for forms2 = (subst element-type 'character forms) for forms3 = (mapcar #'(lambda (form) (destructuring-bind (dt name . body) form `(,dt ,(if (eql element-type 'character) name (intern (replace (copy-seq (symbol-name name)) "BASEST" :start1 13 :end1 19) (symbol-package name))) ,@ body))) forms2) do (eval `(progn ,@forms3))) ;; 2-d arrays (def-adjust-array-test adjust-array.string.21 ('(4 5) :initial-contents '("12345" "34567" "56789" "78912") :element-type 'character) ('(2 3)) #.(make-array '(2 3) :initial-contents '("123" "345") :element-type 'character)) (def-adjust-array-test adjust-array.string.22 ('(4 5) :initial-contents '("12345" "34567" "56789" "78912") :element-type 'character) ('(6 8) :initial-element #\0 :element-type 'character) #.(make-array '(6 8) :initial-contents '("12345000" "34567000" "56789000" "78912000" "00000000" "00000000") :element-type 'character)) (def-adjust-array-test adjust-array.bit-vector.1 (5 :element-type 'bit :initial-contents #*01100) (4 :element-type 'bit) #*0110) (def-adjust-array-test adjust-array.bit-vector.2 (5 :element-type 'bit :initial-contents #*01100) (8 :element-type 'bit :initial-element 1) #*01100111) (def-adjust-array-test adjust-array.bit-vector.3 (5 :element-type 'bit :initial-contents #*01100) (4 :element-type 'bit :initial-contents #*1011) #*1011) (def-adjust-array-test adjust-array.bit-vector.4 (5 :element-type 'bit :initial-contents #*01100) (8 :element-type 'bit :initial-contents #*11110000) #*11110000) (def-adjust-array-fp-test adjust-array.bit-vector.5 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit) (assert (eql (aref a2 3) 0)) 3 #*011) (def-adjust-array-fp-test adjust-array.bit-vector.6 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit :fill-pointer nil) (assert (eql (aref a2 3) 0)) 3 #*011) (def-adjust-array-fp-test adjust-array.bit-vector.7 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit :fill-pointer t) nil 4 #*0110) (def-adjust-array-fp-test adjust-array.bit-vector.8 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit :fill-pointer 2) (progn (assert (eql (aref a2 2) 1)) (assert (eql (aref a2 3) 0))) 2 #*01) (def-adjust-array-fp-test adjust-array.bit-vector.9 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (8 :element-type 'bit :fill-pointer 5 :initial-element 1) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(1 1 1))) 5 #*01100) (deftest adjust-array.bit-vector.10 (let* ((a1 (make-array 5 :element-type 'bit :initial-contents #*01100)) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.11 (let* ((a0 (make-array 7 :initial-contents #*0011001 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (adjust-array a1 4 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.12 (let* ((a0 (make-array 7 :initial-contents #*1010101 :element-type 'bit)) (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #*1010) (deftest adjust-array.bit-vector.13 (let* ((a0 (make-array 7 :initial-contents #*1011101 :element-type 'bit)) (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :displaced-index-offset 2 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 2))) a2) #*1110) (deftest adjust-array.bit-vector.14 (let* ((a0 (make-array 7 :initial-contents #*1011001 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (if (adjustable-array-p a1) (eq a1 a2) (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) (list a0 0))) a2) #*1011) (deftest adjust-array.bit-vector.15 (let* ((a0 (make-array 7 :initial-contents #*1100010 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'bit)) (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'bit))) a3) #*1000) (deftest adjust-array.bit-vector.16 (let* ((a0 (make-array 7 :initial-contents #*1011011 :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :element-type 'bit)) (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'bit))) a2) #*10110) (def-adjust-array-test adjust-array.bit-vector.17 (nil :initial-element 0 :element-type 'bit) (nil) #.(make-array nil :initial-element 0 :element-type 'bit)) (def-adjust-array-test adjust-array.bit-vector.18 (nil :initial-element 0 :element-type 'bit) (nil :initial-contents 1 :element-type 'bit) #.(make-array nil :initial-element 1 :element-type 'bit)) (def-adjust-array-test adjust-array.bit-vector.19 (nil :initial-element 1 :element-type 'bit) (nil :initial-element 0 :element-type 'bit) #.(make-array nil :initial-element 1 :element-type 'bit)) (deftest adjust-array.bit-vector.20 (let* ((a0 (make-array nil :initial-element 1 :element-type 'bit)) (a1 (make-array nil :displaced-to a0 :element-type 'bit)) (a2 (adjust-array a1 nil :element-type 'bit))) a2) #.(make-array nil :initial-element 1 :element-type 'bit)) ;; 2-d arrays (def-adjust-array-test adjust-array.bit-vector.21 ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111) :element-type 'bit) ('(2 3)) #.(make-array '(2 3) :initial-contents '(#*111 #*001) :element-type 'bit)) (def-adjust-array-test adjust-array.bit-vector.22 ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111) :element-type 'bit) ('(6 8) :initial-element 0 :element-type 'bit) #.(make-array '(6 8) :initial-contents '(#*11100000 #*00110000 #*00001000 #*11111000 #*00000000 #*00000000) :element-type 'bit)) ;;; Adjustable bit vector tests (def-adjust-array-test adjust-array.bit-vector.adjustable.1 (5 :initial-contents '(1 0 1 1 0) :adjustable t :element-type 'bit) (4 :element-type 'bit) #*1011) (def-adjust-array-test adjust-array.bit-vector.adjustable.2 (5 :initial-contents '(1 0 1 0 1) :adjustable t :element-type 'bit) (8 :initial-element '1 :element-type 'bit) #*10101111) (def-adjust-array-test adjust-array.bit-vector.adjustable.3 (5 :initial-contents '(0 1 0 1 0) :adjustable t :element-type 'bit) (4 :initial-contents '(1 1 1 0) :element-type 'bit) #*1110) (def-adjust-array-test adjust-array.bit-vector.adjustable.4 (5 :initial-contents '(1 0 0 1 0) :adjustable t :element-type 'bit) (8 :initial-contents '(0 1 0 1 1 0 1 0) :element-type 'bit) #*01011010) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.5 (5 :initial-contents '(1 1 1 0 0) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :element-type 'bit :initial-element 0) (assert (eql (aref a2 3) 0)) 3 #*111) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.6 (5 :initial-contents '(0 0 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :fill-pointer nil :element-type 'bit :initial-element 1) (assert (eql (aref a2 3) 1)) 3 #*000) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.7 (5 :initial-contents '(1 1 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :fill-pointer t :element-type 'bit :initial-element 1) nil 4 #*1101) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.8 (5 :initial-contents '(0 1 1 1 0) :fill-pointer 3 :adjustable t :element-type 'bit) (4 :fill-pointer 2 :element-type 'bit :initial-element 0) (assert (equal (list (aref a2 2) (aref a2 3)) '(1 1))) 2 #*01) (def-adjust-array-fp-test adjust-array.bit-vector.adjustable.9 (5 :initial-contents '(1 0 0 0 1) :fill-pointer 3 :adjustable t :element-type 'bit) (8 :fill-pointer 5 :initial-element 1 :element-type 'bit) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(1 1 1))) 5 #*10001) (deftest adjust-array.bit-vector.adjustable.10 (let* ((a1 (make-array 5 :initial-contents '(0 1 1 0 1) :adjustable t :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.adjustable.11 (let* ((a0 (make-array 7 :initial-contents '(0 1 0 1 1 1 0) :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'bit)) (a2 (adjust-array a1 4 :element-type 'bit))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) #*1011) (deftest adjust-array.bit-vector.adjustable.12 (let* ((a0 (make-array 7 :initial-contents '(0 0 1 1 1 1 1) :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'bit)) (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (eq a1 a2)) a2) #*0011) (deftest adjust-array.bit-vector.adjustable.13 (let* ((a0 (make-array 7 :initial-contents '(1 0 0 0 0 0 1) :element-type 'bit)) (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 :adjustable t :element-type 'bit)) (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 :element-type 'bit))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 :displaced-index-offset 2 :element-type 'bit))) a2) #*0001) ;;; FIXME. specialized integer array tests ;;; FIXNME float array tests ;;; Error cases (deftest adjust-array.error.1 (signals-error (adjust-array) program-error) t) (deftest adjust-array.error.2 (signals-error (adjust-array (make-array 10 :initial-element nil)) program-error) t) (deftest adjust-array.error.3 (signals-error (adjust-array (make-array 10 :initial-element nil) 8 :bad t) program-error) t) (deftest adjust-array.error.4 (signals-error (adjust-array (make-array 10 :initial-element nil) 8 :initial-element) program-error) t) (deftest adjust-array.error.5 (signals-error (adjust-array (make-array 10 :initial-element nil) 8 :allow-other-keys nil :allow-other-keys t :bad t) program-error) t) (deftest adjust-array.error.6 (signals-error (let ((a (make-array 5 :initial-element 'x))) (adjust-array a :fill-pointer 4)) error) t) gcl-2.7.1/ansi-tests/PaxHeaders/enough-namestring.lsp0000644000000000000000000000013014542551762017621 xustar0030 mtime=1703597042.988022407 28 atime=1744294960.8377907 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/enough-namestring.lsp0000644000175000017500000000440514542551762017224 0ustar00cammcamm;-*- 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.7.1/ansi-tests/PaxHeaders/hash-table-aux.lsp0000644000000000000000000000012714542551762017000 xustar0029 mtime=1703597042.99602242 28 atime=1744294960.8377907 30 ctime=1744351535.654907676 gcl-2.7.1/ansi-tests/hash-table-aux.lsp0000644000175000017500000000526514542551762016402 0ustar00cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 4 09:24:24 2003 ;;;; Contains: Aux. functions for testing hash tables (in-package :cl-test) (eval-when (:load-toplevel :compile-toplevel :execute) (compile-and-load "random-aux.lsp")) (defparameter *hash-table-test-iters* 1000) (defun test-hash-table-1 (&rest args) (let ((table (apply #'make-hash-table args)) (test (or (getf args :test) 'eql))) (assert (member test '(eq eql equal equalp))) (assert (hash-table-p table)) (assert (typep table 'hash-table)) ;; Build a hash table using the arguments in ARGS. ;; Perform *hash-table-test-iters* iterations of ;; random hash table operations (let* ((universe-vec (coerce *universe* 'vector)) ;; (universe-size (length universe-vec)) (mapping nil) (count 0)) (loop for i from 0 below *hash-table-test-iters* do (assert (eql (hash-table-count table) count)) do (assert (let ((size (hash-table-size table))) (and (integerp size) (>= size 0)))) do (flet ((%remove-pair (rpair) (decf count) (let ((key (car rpair)) (expected-value (cdr rpair))) (multiple-value-bind (value present-p) (gethash key table) (assert present-p) (assert (eql expected-value value)) (setf mapping (remove rpair mapping :count 1 :test 'eq))) (assert (remhash key table)) (multiple-value-bind (value present-p) (gethash key table) (assert (not present-p)) (assert (null value)) )))) (rcase (1 ;; Insert (let* ((new-elem (random-from-seq universe-vec)) (pair (assoc new-elem mapping :test test))) (cond (pair (multiple-value-bind (value present-p) (gethash new-elem table) (assert present-p) (assert (eql (cdr pair) value)) (setf (cdr pair) i (gethash new-elem table) i))) (t (assert (equal (multiple-value-list (gethash new-elem table)) '(nil nil))) (incf count) (push (cons new-elem i) mapping) (setf (gethash new-elem table) i))))) (1 ;; Delete element in the set (when mapping (%remove-pair (random-from-seq mapping)))) (1 ;; Delete random element from universe (let* ((key (random-from-seq universe-vec)) (pair (assoc key mapping :test test))) (cond (pair (%remove-pair pair)) (t ;; Not present -- check that this is true (assert (equal (multiple-value-list (gethash key table)) '(nil nil))) (assert (not (remhash key table))) (assert (equal (multiple-value-list (gethash key table)) '(nil nil))))) )) )))))) gcl-2.7.1/PaxHeaders/git.tag0000644000000000000000000000013214776071210012631 xustar0030 mtime=1744335496.941521547 30 atime=1744335596.878429177 30 ctime=1744351535.730906995 gcl-2.7.1/git.tag0000644000175000017500000000002114776071210012220 0ustar00cammcamm"Version_2_7_0" gcl-2.7.1/PaxHeaders/config.guess0000644000000000000000000000013214776130437013675 xustar0030 mtime=1744351519.783051006 30 atime=1744351519.963049368 30 ctime=1744351535.446909541 gcl-2.7.1/config.guess0000755000175000017500000014306714776130437013311 0ustar00cammcamm#! /bin/sh # Attempt to guess a canonical system name. # Copyright 1992-2024 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale timestamp='2024-07-27' # 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-2024 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 c17 c99 c89 ; 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" #if defined(__ANDROID__) LIBC=android #else #include #if defined(__UCLIBC__) LIBC=uclibc #elif defined(__dietlibc__) LIBC=dietlibc #elif defined(__GLIBC__) LIBC=gnu #elif defined(__LLVM_LIBC__) LIBC=llvm #else #include /* First heuristic to detect musl libc. */ #ifdef __DEFINED_va_list LIBC=musl #endif #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 int 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=`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 ;; x86_64:[Mm]anagarm:*:*|i?86:[Mm]anagarm:*:*) GUESS="$UNAME_MACHINE-pc-managarm-mlibc" ;; *:[Mm]anagarm:*:*) GUESS="$UNAME_MACHINE-unknown-managarm-mlibc" ;; *:Minix:*:*) GUESS=$UNAME_MACHINE-unknown-minix ;; aarch64:Linux:*:*) set_cc_for_build CPU=$UNAME_MACHINE LIBCABI=$LIBC if test "$CC_FOR_BUILD" != no_compiler_found; then ABI=64 sed 's/^ //' << EOF > "$dummy.c" #ifdef __ARM_EABI__ #ifdef __ARM_PCS_VFP ABI=eabihf #else ABI=eabi #endif #endif EOF cc_set_abi=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^ABI' | sed 's, ,,g'` eval "$cc_set_abi" case $ABI in eabi | eabihf) CPU=armv8l; LIBCABI=$LIBC$ABI ;; esac fi GUESS=$CPU-unknown-linux-$LIBCABI ;; 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 ;; kvx:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; kvx:cos:*:*) GUESS=$UNAME_MACHINE-unknown-cos ;; kvx:mbr:*:*) GUESS=$UNAME_MACHINE-unknown-mbr ;; loongarch32:Linux:*:* | loongarch64: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 CPU=$UNAME_MACHINE LIBCABI=$LIBC if test "$CC_FOR_BUILD" != no_compiler_found; then ABI=64 sed 's/^ //' << EOF > "$dummy.c" #ifdef __i386__ ABI=x86 #else #ifdef __ILP32__ ABI=x32 #endif #endif EOF cc_set_abi=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^ABI' | sed 's, ,,g'` eval "$cc_set_abi" case $ABI in x86) CPU=i686 ;; x32) LIBCABI=${LIBC}x32 ;; esac fi GUESS=$CPU-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 ;; ppc:Haiku:*:*) # Haiku running on Apple PowerPC GUESS=powerpc-apple-haiku ;; *:Haiku:*:*) # Haiku modern gcc (not bound by BeOS compat) GUESS=$UNAME_MACHINE-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 ;; *:Ironclad:*:*) GUESS=$UNAME_MACHINE-unknown-ironclad ;; 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 int 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.7.1/PaxHeaders/depcomp0000644000000000000000000000013214776130437012732 xustar0030 mtime=1744351519.835050533 30 atime=1744351519.999049041 30 ctime=1744351535.446909541 gcl-2.7.1/depcomp0000755000175000017500000005621714776130437012346 0ustar00cammcamm#! /bin/sh # depcomp - compile a program generating dependencies as side-effects scriptversion=2024-06-19.01; # UTC # Copyright (C) 1999-2024 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. # Originally written by Alexandre Oliva . case $1 in '') echo "$0: No command. Try '$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: depcomp [--help] [--version] PROGRAM [ARGS] Run PROGRAMS ARGS to compile a file, generating dependencies as side-effects. Environment variables: depmode Dependency tracking mode. source Source file read by 'PROGRAMS ARGS'. object Object file output by 'PROGRAMS ARGS'. DEPDIR directory where to store dependencies. depfile Dependency file to output. tmpdepfile Temporary file to use when outputting dependencies. libtool Whether libtool is used (yes/no). Report bugs to . GNU Automake home page: . General help using GNU software: . EOF exit $? ;; -v | --v*) echo "depcomp (GNU Automake) $scriptversion" exit $? ;; esac # Get the directory component of the given path, and save it in the # global variables '$dir'. Note that this directory component will # be either empty or ending with a '/' character. This is deliberate. set_dir_from () { case $1 in */*) dir=`echo "$1" | sed -e 's|/[^/]*$|/|'`;; *) dir=;; esac } # Get the suffix-stripped basename of the given path, and save it the # global variable '$base'. set_base_from () { base=`echo "$1" | sed -e 's|^.*/||' -e 's/\.[^.]*$//'` } # If no dependency file was actually created by the compiler invocation, # we still have to create a dummy depfile, to avoid errors with the # Makefile "include basename.Plo" scheme. make_dummy_depfile () { echo "#dummy" > "$depfile" } # Factor out some common post-processing of the generated depfile. # Requires the auxiliary global variable '$tmpdepfile' to be set. aix_post_process_depfile () { # If the compiler actually managed to produce a dependency file, # post-process it. if test -f "$tmpdepfile"; then # Each line is of the form 'foo.o: dependency.h'. # Do two passes, one to just change these to # $object: dependency.h # and one to simply output # dependency.h: # which is needed to avoid the deleted-header problem. { sed -e "s,^.*\.[$lower]*:,$object:," < "$tmpdepfile" sed -e "s,^.*\.[$lower]*:[$tab ]*,," -e 's,$,:,' < "$tmpdepfile" } > "$depfile" rm -f "$tmpdepfile" else make_dummy_depfile fi } # A tabulation character. tab=' ' # A newline character. nl=' ' # Character ranges might be problematic outside the C locale. # These definitions help. upper=ABCDEFGHIJKLMNOPQRSTUVWXYZ lower=abcdefghijklmnopqrstuvwxyz alpha=${upper}${lower} if test -z "$depmode" || test -z "$source" || test -z "$object"; then echo "depcomp: Variables source, object and depmode must be set" 1>&2 exit 1 fi # Dependencies for sub/bar.o or sub/bar.obj go into sub/.deps/bar.Po. depfile=${depfile-`echo "$object" | sed 's|[^\\/]*$|'${DEPDIR-.deps}'/&|;s|\.\([^.]*\)$|.P\1|;s|Pobj$|Po|'`} tmpdepfile=${tmpdepfile-`echo "$depfile" | sed 's/\.\([^.]*\)$/.T\1/'`} rm -f "$tmpdepfile" # Avoid interference from the environment. gccflag= dashmflag= # Some modes work just like other modes, but use different flags. We # parameterize here, but still list the modes in the big case below, # to make depend.m4 easier to write. Note that we *cannot* use a case # here, because this file can only contain one case statement. if test "$depmode" = hp; then # HP compiler uses -M and no extra arg. gccflag=-M depmode=gcc fi if test "$depmode" = dashXmstdout; then # This is just like dashmstdout with a different argument. dashmflag=-xM depmode=dashmstdout fi cygpath_u="cygpath -u -f -" if test "$depmode" = msvcmsys; then # This is just like msvisualcpp but w/o cygpath translation. # Just convert the backslash-escaped backslashes to single forward # slashes to satisfy depend.m4 cygpath_u='sed s,\\\\,/,g' depmode=msvisualcpp fi if test "$depmode" = msvc7msys; then # This is just like msvc7 but w/o cygpath translation. # Just convert the backslash-escaped backslashes to single forward # slashes to satisfy depend.m4 cygpath_u='sed s,\\\\,/,g' depmode=msvc7 fi if test "$depmode" = xlc; then # IBM C/C++ Compilers xlc/xlC can output gcc-like dependency information. gccflag=-qmakedep=gcc,-MF depmode=gcc fi case "$depmode" in gcc3) ## gcc 3 implements dependency tracking that does exactly what ## we want. Yay! Note: for some reason libtool 1.4 doesn't like ## it if -MD -MP comes after the -MF stuff. Hmm. ## Unfortunately, FreeBSD c89 acceptance of flags depends upon ## the command line argument order; so add the flags where they ## appear in depend2.am. Note that the slowdown incurred here ## affects only configure: in makefiles, %FASTDEP% shortcuts this. for arg do case $arg in -c) set fnord "$@" -MT "$object" -MD -MP -MF "$tmpdepfile" "$arg" ;; *) set fnord "$@" "$arg" ;; esac shift # fnord shift # $arg done "$@" stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi mv "$tmpdepfile" "$depfile" ;; gcc) ## Note that this doesn't just cater to obsolete pre-3.x GCC compilers. ## but also to in-use compilers like IBM xlc/xlC and the HP C compiler. ## (see the conditional assignment to $gccflag above). ## There are various ways to get dependency output from gcc. Here's ## why we pick this rather obscure method: ## - Don't want to use -MD because we'd like the dependencies to end ## up in a subdir. Having to rename by hand is ugly. ## (We might end up doing this anyway to support other compilers.) ## - The DEPENDENCIES_OUTPUT environment variable makes gcc act like ## -MM, not -M (despite what the docs say). Also, it might not be ## supported by the other compilers which use the 'gcc' depmode. ## - Using -M directly means running the compiler twice (even worse ## than renaming). if test -z "$gccflag"; then gccflag=-MD, fi "$@" -Wp,"$gccflag$tmpdepfile" stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" echo "$object : \\" > "$depfile" # The second -e expression handles DOS-style file names with drive # letters. sed -e 's/^[^:]*: / /' \ -e 's/^['$alpha']:\/[^:]*: / /' < "$tmpdepfile" >> "$depfile" ## This next piece of magic avoids the "deleted header file" problem. ## The problem is that when a header file which appears in a .P file ## is deleted, the dependency causes make to die (because there is ## typically no way to rebuild the header). We avoid this by adding ## dummy dependencies for each header file. Too bad gcc doesn't do ## this for us directly. ## Some versions of gcc put a space before the ':'. On the theory ## that the space means something, we add a space to the output as ## well. hp depmode also adds that space, but also prefixes the VPATH ## to the object. Take care to not repeat it in the output. ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. tr ' ' "$nl" < "$tmpdepfile" \ | sed -e 's/^\\$//' -e '/^$/d' -e "s|.*$object$||" -e '/:$/d' \ | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; sgi) if test "$libtool" = yes; then "$@" "-Wp,-MDupdate,$tmpdepfile" else "$@" -MDupdate "$tmpdepfile" fi stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" if test -f "$tmpdepfile"; then # yes, the sourcefile depend on other files echo "$object : \\" > "$depfile" # Clip off the initial element (the dependent). Don't try to be # clever and replace this with sed code, as IRIX sed won't handle # lines with more than a fixed number of characters (4096 in # IRIX 6.2 sed, 8192 in IRIX 6.5). We also remove comment lines; # the IRIX cc adds comments like '#:fec' to the end of the # dependency line. tr ' ' "$nl" < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' \ | tr "$nl" ' ' >> "$depfile" echo >> "$depfile" # The second pass generates a dummy entry for each header file. tr ' ' "$nl" < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' -e 's/$/:/' \ >> "$depfile" else make_dummy_depfile fi rm -f "$tmpdepfile" ;; xlc) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; aix) # The C for AIX Compiler uses -M and outputs the dependencies # in a .u file. In older versions, this file always lives in the # current directory. Also, the AIX compiler puts '$object:' at the # start of each line; $object doesn't have directory information. # Version 6 uses the directory in both cases. set_dir_from "$object" set_base_from "$object" if test "$libtool" = yes; then tmpdepfile1=$dir$base.u tmpdepfile2=$base.u tmpdepfile3=$dir.libs/$base.u "$@" -Wc,-M else tmpdepfile1=$dir$base.u tmpdepfile2=$dir$base.u tmpdepfile3=$dir$base.u "$@" -M fi stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" do test -f "$tmpdepfile" && break done aix_post_process_depfile ;; tcc) # tcc (Tiny C Compiler) understand '-MD -MF file' since version 0.9.26 # FIXME: That version still under development at the moment of writing. # Make that this statement remains true also for stable, released # versions. # It will wrap lines (doesn't matter whether long or short) with a # trailing '\', as in: # # foo.o : \ # foo.c \ # foo.h \ # # It will put a trailing '\' even on the last line, and will use leading # spaces rather than leading tabs (at least since its commit 0394caf7 # "Emit spaces for -MD"). "$@" -MD -MF "$tmpdepfile" stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" # Each non-empty line is of the form 'foo.o : \' or ' dep.h \'. # We have to change lines of the first kind to '$object: \'. sed -e "s|.*:|$object :|" < "$tmpdepfile" > "$depfile" # And for each line of the second kind, we have to emit a 'dep.h:' # dummy dependency, to avoid the deleted-header problem. sed -n -e 's|^ *\(.*\) *\\$|\1:|p' < "$tmpdepfile" >> "$depfile" rm -f "$tmpdepfile" ;; ## The order of this option in the case statement is important, since the ## shell code in configure will try each of these formats in the order ## listed in this file. A plain '-MD' option would be understood by many ## compilers, so we must ensure this comes after the gcc and icc options. pgcc) # Portland's C compiler understands '-MD'. # Will always output deps to 'file.d' where file is the root name of the # source file under compilation, even if file resides in a subdirectory. # The object file name does not affect the name of the '.d' file. # pgcc 10.2 will output # foo.o: sub/foo.c sub/foo.h # and will wrap long lines using '\' : # foo.o: sub/foo.c ... \ # sub/foo.h ... \ # ... set_dir_from "$object" # Use the source, not the object, to determine the base name, since # that's sadly what pgcc will do too. set_base_from "$source" tmpdepfile=$base.d # For projects that build the same source file twice into different object # files, the pgcc approach of using the *source* file root name can cause # problems in parallel builds. Use a locking strategy to avoid stomping on # the same $tmpdepfile. lockdir=$base.d-lock trap " echo '$0: caught signal, cleaning up...' >&2 rmdir '$lockdir' exit 1 " 1 2 13 15 numtries=100 i=$numtries while test $i -gt 0; do # mkdir is a portable test-and-set. if mkdir "$lockdir" 2>/dev/null; then # This process acquired the lock. "$@" -MD stat=$? # Release the lock. rmdir "$lockdir" break else # If the lock is being held by a different process, wait # until the winning process is done or we timeout. while test -d "$lockdir" && test $i -gt 0; do sleep 1 i=`expr $i - 1` done fi i=`expr $i - 1` done trap - 1 2 13 15 if test $i -le 0; then echo "$0: failed to acquire lock after $numtries attempts" >&2 echo "$0: check lockdir '$lockdir'" >&2 exit 1 fi if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" # Each line is of the form `foo.o: dependent.h', # or `foo.o: dep1.h dep2.h \', or ` dep3.h dep4.h \'. # Do two passes, one to just change these to # `$object: dependent.h' and one to simply `dependent.h:'. sed "s,^[^:]*:,$object :," < "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process this invocation # correctly. Breaking it into two sed invocations is a workaround. sed 's,^[^:]*: \(.*\)$,\1,;s/^\\$//;/^$/d;/:$/d' < "$tmpdepfile" \ | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp2) # The "hp" stanza above does not work with aCC (C++) and HP's ia64 # compilers, which have integrated preprocessors. The correct option # to use with these is +Maked; it writes dependencies to a file named # 'foo.d', which lands next to the object file, wherever that # happens to be. # Much of this is similar to the tru64 case; see comments there. set_dir_from "$object" set_base_from "$object" if test "$libtool" = yes; then tmpdepfile1=$dir$base.d tmpdepfile2=$dir.libs/$base.d "$@" -Wc,+Maked else tmpdepfile1=$dir$base.d tmpdepfile2=$dir$base.d "$@" +Maked fi stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile1" "$tmpdepfile2" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then sed -e "s,^.*\.[$lower]*:,$object:," "$tmpdepfile" > "$depfile" # Add 'dependent.h:' lines. sed -ne '2,${ s/^ *// s/ \\*$// s/$/:/ p }' "$tmpdepfile" >> "$depfile" else make_dummy_depfile fi rm -f "$tmpdepfile" "$tmpdepfile2" ;; tru64) # The Tru64 compiler uses -MD to generate dependencies as a side # effect. 'cc -MD -o foo.o ...' puts the dependencies into 'foo.o.d'. # At least on Alpha/Redhat 6.1, Compaq CCC V6.2-504 seems to put # dependencies in 'foo.d' instead, so we check for that too. # Subdirectories are respected. set_dir_from "$object" set_base_from "$object" if test "$libtool" = yes; then # Libtool generates 2 separate objects for the 2 libraries. These # two compilations output dependencies in $dir.libs/$base.o.d and # in $dir$base.o.d. We have to check for both files, because # one of the two compilations can be disabled. We should prefer # $dir$base.o.d over $dir.libs/$base.o.d because the latter is # automatically cleaned when .libs/ is deleted, while ignoring # the former would cause a distcleancheck panic. tmpdepfile1=$dir$base.o.d # libtool 1.5 tmpdepfile2=$dir.libs/$base.o.d # Likewise. tmpdepfile3=$dir.libs/$base.d # Compaq CCC V6.2-504 "$@" -Wc,-MD else tmpdepfile1=$dir$base.d tmpdepfile2=$dir$base.d tmpdepfile3=$dir$base.d "$@" -MD fi stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" do test -f "$tmpdepfile" && break done # Same post-processing that is required for AIX mode. aix_post_process_depfile ;; msvc7) if test "$libtool" = yes; then showIncludes=-Wc,-showIncludes else showIncludes=-showIncludes fi "$@" $showIncludes > "$tmpdepfile" stat=$? grep -v '^Note: including file: ' "$tmpdepfile" if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" echo "$object : \\" > "$depfile" # The first sed program below extracts the file names and escapes # backslashes for cygpath. The second sed program outputs the file # name when reading, but also accumulates all include files in the # hold buffer in order to output them again at the end. This only # works with sed implementations that can handle large buffers. sed < "$tmpdepfile" -n ' /^Note: including file: *\(.*\)/ { s//\1/ s/\\/\\\\/g p }' | $cygpath_u | sort -u | sed -n ' s/ /\\ /g s/\(.*\)/'"$tab"'\1 \\/p s/.\(.*\) \\/\1:/ H $ { s/.*/'"$tab"'/ G p }' >> "$depfile" echo >> "$depfile" # make sure the fragment doesn't end with a backslash rm -f "$tmpdepfile" ;; msvc7msys) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; #nosideeffect) # This comment above is used by automake to tell side-effect # dependency tracking mechanisms from slower ones. dashmstdout) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout, regardless of -o. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi # Remove '-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done test -z "$dashmflag" && dashmflag=-M # Require at least two characters before searching for ':' # in the target name. This is to cope with DOS-style filenames: # a dependency such as 'c:/foo/bar' could be seen as target 'c' otherwise. "$@" $dashmflag | sed "s|^[$tab ]*[^:$tab ][^:][^:]*:[$tab ]*|$object: |" > "$tmpdepfile" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process this sed invocation # correctly. Breaking it into two sed invocations is a workaround. tr ' ' "$nl" < "$tmpdepfile" \ | sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' \ | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; dashXmstdout) # This case only exists to satisfy depend.m4. It is never actually # run, as this mode is specially recognized in the preamble. exit 1 ;; makedepend) "$@" || exit $? # Remove any Libtool call if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi # X makedepend shift cleared=no eat=no for arg do case $cleared in no) set ""; shift cleared=yes ;; esac if test $eat = yes; then eat=no continue fi case "$arg" in -D*|-I*) set fnord "$@" "$arg"; shift ;; # Strip any option that makedepend may not understand. Remove # the object too, otherwise makedepend will parse it as a source file. -arch) eat=yes ;; -*|$object) ;; *) set fnord "$@" "$arg"; shift ;; esac done obj_suffix=`echo "$object" | sed 's/^.*\././'` touch "$tmpdepfile" ${MAKEDEPEND-makedepend} -o"$obj_suffix" -f"$tmpdepfile" "$@" rm -f "$depfile" # makedepend may prepend the VPATH from the source file name to the object. # No need to regex-escape $object, excess matching of '.' is harmless. sed "s|^.*\($object *:\)|\1|" "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process the last invocation # correctly. Breaking it into two sed invocations is a workaround. sed '1,2d' "$tmpdepfile" \ | tr ' ' "$nl" \ | sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' \ | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" "$tmpdepfile".bak ;; cpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi # Remove '-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done "$@" -E \ | sed -n -e '/^# [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ -e '/^#line [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ | sed '$ s: \\$::' > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" cat < "$tmpdepfile" >> "$depfile" sed < "$tmpdepfile" '/^$/d;s/^ //;s/ \\$//;s/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; msvisualcpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi IFS=" " for arg do case "$arg" in -o) shift ;; $object) shift ;; "-Gm"|"/Gm"|"-Gi"|"/Gi"|"-ZI"|"/ZI") set fnord "$@" shift shift ;; *) set fnord "$@" "$arg" shift shift ;; esac done "$@" -E 2>/dev/null | sed -n '/^#line [0-9][0-9]* "\([^"]*\)"/ s::\1:p' | $cygpath_u | sort -u > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::'"$tab"'\1 \\:p' >> "$depfile" echo "$tab" >> "$depfile" sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::\1\::p' >> "$depfile" rm -f "$tmpdepfile" ;; msvcmsys) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; none) exec "$@" ;; *) echo "Unknown depmode $depmode" 1>&2 exit 1 ;; esac exit 0 # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: gcl-2.7.1/PaxHeaders/configure.ac0000644000000000000000000000013214776101315013637 xustar0030 mtime=1744339661.006463326 30 atime=1744339701.746712669 30 ctime=1744351535.394910007 gcl-2.7.1/configure.ac0000644000175000017500000015647714776101315013261 0ustar00cammcamm# Copyright 2024 Camm Maguire AC_INIT(gcl,2.7.1) AC_PREREQ([2.0]) AC_CONFIG_HEADERS([h/gclincl.h]) AM_INIT_AUTOMAKE([1.16 -Wno-portability tar-pax]) AM_PATH_LISPDIR AC_CONFIG_FILES([Makefile]) #AC_USE_SYSTEM_EXTENSIONS #LT_INIT MAJVERS=`cat $srcdir/majvers` MINVERS=`cat $srcdir/minvers` GIT_TAG=`cat $srcdir/git.tag` RELEASE=`cat $srcdir/release` VERSION=$MAJVERS.$MINVERS AC_SUBST(VERSION) dnl AC_ARG_ENABLE(xgcl,[ --enable-xgcl=yes will compile in support for XGCL], dnl [enable_xgcl=$enableval],[enable_xgcl="yes"]) # # Host information # AC_CHECK_PROGS(AWK,gawk nawk awk) 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 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_64*gnu*) use=amd64-gnu;; *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;; loongarch64*linux*) use=loongarch64-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_pic="no"; case $use in *kfreebsd) if ! test -d h ; then mkdir h; fi;; # ln -snf ../$srcdir/h/linux.defs h/$use.defs;; *gnu) if ! test -d h ; then mkdir h; fi;; # ln -snf ../$srcdir/h/linux.defs h/$use.defs;; *linux) if ! test -d h ; then mkdir h; fi; # ln -snf ../$srcdir/h/linux.defs h/$use.defs; case $use in hppa*) # FIXME 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([xgcl],[ --enable-xgcl=yes will compile in support for XGCL],,[enable_xgcl=yes]) 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]) # # 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_USE_SYSTEM_EXTENSIONS AC_PROG_RANLIB AC_PROG_CC AC_PROG_CPP AC_SUBST(CC) GCL_CC=`basename $CC` if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi AC_SUBST(GCL_CC) AC_SUBST(CPP) 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 \ -std=gnu17 \ -Wall \ -Wno-builtin-requires-header -Wno-empty-body -Wno-self-assign \ -Wno-unused-but-set-variable -D_FILE_OFFSET_BITS=64 -D_TIME_BITS=64 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])]) 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-linux) if ! add_arg_to_cflags -msse2 || ! add_arg_to_cflags -mfpmath=sse ; then add_arg_to_cflags -ffloat-store; fi;; loongarch64-linux) add_arg_to_cflags -mno-relax add_arg_to_cflags -Wa,-mno-relax;; 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="" TOSFLAGS="" 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) GPROF="gprof_objs" AC_ARG_ENABLE([gprof],[ --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof], [if test "$enableval" != "yes" ; then GPROF=""; fi]) if test "$GPROF" != "" ; then case $use in sh4*) GPROF="";; m68k*) GPROF="";; ia64*) GPROF="";; gnuwin95*) GPROF="";; esac OLD_CFLAGS=$CFLAGS if ! add_arg_to_cflags -pg ; then GPROF="" ; fi CFLAGS=$OLD_CFLAGS AC_MSG_CHECKING([working gprof]) if test "$GPROF" = "" ; then AC_MSG_RESULT([disabled]) else AC_MSG_RESULT([ok]) AC_DEFINE(USE_GPROF,1,[use gprof]) fi fi dnl AC_SUBST(GPROF) AM_CONDITIONAL([AMM_GPROF],[test "$GPROF" != ""]) if test "$enable_debug" = "yes" ; then assert_arg_to_cflags -g # for subconfigurations CFLAGS="$CFLAGS -g" else TOSFLAGS="-O2" # "-Os $TFPFLAG" 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*) 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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo "$TOSFLAGS" | 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'` TOSFLAGS=`echo $TOSFLAGS | sed 's,-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" 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)])]) 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=`$CC -E foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'` rm -f foo.c])])]) if test "$MP_INCLUDE" = "" ; then AC_MSG_ERROR([Cannot use dynamic gmp lib]) 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 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) AC_MSG_CHECKING([for GNU ld option -Map]) touch map foo.c $CC -o foo [ -Wl,-Map ] map foo.c >/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 # # 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 AM_CONDITIONAL([AMM_XGCL],[test "$X_LIBS" != ""]) AC_SUBST(X_LIBS) AC_SUBST(X_CFLAGS) # # Dynamic loading # # boot.so requires dlopen AC_CHECK_LIB([dl],[dlopen],,AC_MSG_ERROR([Cannot find dlopen])) 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 #include ]], [[ unsigned long k=(1UL<<$j); void *p=malloc(2*k); int i; p=(void *)((((unsigned long)p)+k-1)&~(k-1)); i=madvise(p,k,MADV_HUGEPAGE); return i; ]])], [AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_MADVISE_HUGEPAGE,[1],[can madvise hugepages]) if test $min_pagewidth -lt $j ; then min_pagewidth=$j ; fi], [AC_MSG_RESULT([no])])] ,[],[#include ])])]) else AC_MSG_RESULT([not found]) fi AC_ARG_ENABLE(min_pagewidth,[ --enable-min_pagewidth=xxx sets 1< #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 #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "$srcdir/h/enum.h" #define OBJ_ALIGN #include "$srcdir/h/type.h" #include "$srcdir/h/lu.h" #include "$srcdir/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 #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "$srcdir/h/enum.h" #include "$srcdir/h/type.h" #include "$srcdir/h/lu.h" #include "$srcdir/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(CSTACK_DIRECTION) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); 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 #include int main(int argc,char **argv,char **envp) { void *b,*c; FILE *fp = fopen("conftest1","w"); long n; 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) if test $cstack_direction -eq 1 ; then AC_MSG_CHECKING(CSTACK_TOP) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"),*f=fopen("/proc/self/maps","r"); unsigned long i,j; char b[4096]; i=(unsigned long)alloca(sizeof(void *)); for (j=0;j #include #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"),*f=fopen("/proc/self/maps","r"); unsigned long i,j; char b[4096],*stack_map_base; #include "$srcdir/h/cstack.h" i=(unsigned long)alloca(sizeof(void *)); for (j=0;j #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); unsigned long i,j; j=getpagesize(); i=(unsigned long)alloca(sizeof(void *)); j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i-1); fclose(fp); return 0; }]])], [cstack_top=`cat conftest1`],[cstack_top=0]) AC_MSG_RESULT($cstack_top) AC_MSG_CHECKING([relocated CSTACK_TOP]) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); unsigned long i,j; char *stack_map_base; #include "$srcdir/h/cstack.h" j=getpagesize(); i=(unsigned long)alloca(sizeof(void *)); j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i-1); fclose(fp); return 0; }]])], [cstack_top=`cat conftest1`],[cstack_top=0]) AC_MSG_RESULT($cstack_top) fi AC_MSG_CHECKING([cstack bits]) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include #include #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); long i,j; char *stack_map_base; #include "$srcdir/h/cstack.h" j=getpagesize(); i=$cstack_top; 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_MSG_RESULT($cstack_bits) AC_MSG_CHECKING(NEG_CSTACK_ADDRESS) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include #include #include #include #include int main(int argc,char **argv,char **envp) { char *stack_map_base; #include "$srcdir/h/cstack.h" return (long)$cstack_top<0 ? 0 : -1; }]])], [AC_MSG_RESULT(yes) neg_cstack_address=1], [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]) AC_MSG_CHECKING([finding default linker script]) if ! test -d unixport ; then mkdir unixport ; fi 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:|tr '-' '_'`; 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_CHECKING([output_mach]) output_mach=`cat gcl.script |grep OUTPUT_ARCH|head -n 1|sed 's,.*(\(.*\)).*,\1:,1'|cut -f2 -d:|tr '-' '_'|tr -d '.'`; if test "$output_mach" = "common" ; then #FIXME output_mach="" fi defaulted="" if test "$output_mach" = "" ; then if test "$output_arch" = "i386" ; then output_mach="i386_i386"; defaulted="(defaulted)" fi fi if test "$output_mach" != "" ; then AC_DEFINE_UNQUOTED(OUTPUT_MACH,bfd_mach_${output_mach},[bfd output mach]) AC_MSG_RESULT([$defaulted bfd_mach_${output_mach}]) 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 >/dev/null 2>&1 && ./foo >/dev/null 2>&1 ) >/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 # Workaround for false island of acceptability on riscv64, 20240716 if test `$AWK 'END {print n-m}' m=$min n=$max 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 AC_DEFINE_UNQUOTED(CSSIZE,$enable_cssize,[maximum C stack size]) 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_top; for (i=j=k;j && i>=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) 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("config.log",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]))) # Check if Posix compliant getcwd exists, if not we'll use getwd. AC_CHECK_FUNCS(getcwd) AC_CHECK_FUNCS(getwd) AC_CHECK_FUNCS(rename) AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME,1,[no uname call])) AC_CHECK_FUNCS(readlinkat,[],[AC_MSG_ERROR([must have readlinkat])]) 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) if test "$use" != "mingw" ; then AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) fi AC_CHECK_LIB(mingwex,main,LIBS="${LIBS} -lmingwex",true) # # 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]), [],[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) 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 AC_CHECK_FUNCS(print_insn_i386,LIBS="$MLIBS -ldl"))) 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],) 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],) 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 TCL_VERSION=`echo '[puts [set tcl_version]]' | ${TCLSH}` fi if test -e /usr/lib/tcl$TCL_VERSION/tclConfig.sh ; then TCL_CONFIG_PREFIX=/usr/lib/tcl$TCL_VERSION fi fi if test -e ${TCL_CONFIG_PREFIX}/tclConfig.sh ; then . ${TCL_CONFIG_PREFIX}/tclConfig.sh ; fi if test -d "${TK_CONFIG_PREFIX}" ; then true ; else if test -e ${TCL_CONFIG_PREFIX}/tkConfig.sh ; then TK_CONFIG_PREFIX=${TCL_CONFIG_PREFIX} else if test -e `echo $TCL_CONFIG_PREFIX | sed 's,tcl,tk,g'`/tkConfig.sh ; then TK_CONFIG_PREFIX=`echo $TCL_CONFIG_PREFIX | sed 's,tcl,tk,g'` fi fi fi if test -e ${TK_CONFIG_PREFIX}/tkConfig.sh ; then . ${TK_CONFIG_PREFIX}/tkConfig.sh ; fi if test -d ${TCL_CONFIG_PREFIX}/tcl${TCL_VERSION} ; then TCL_LIBRARY=${TCL_CONFIG_PREFIX}/tcl${TCL_VERSION} else if test -d ${TCL_CONFIG_PREFIX}/../tcl${TCL_VERSION} ; then TCL_LIBRARY=${TCL_CONFIG_PREFIX}/../tcl${TCL_VERSION} fi 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 -e ${TCL_CONFIG_PREFIX}/../include/tcl.h ; then TCL_INCLUDE=-I${TCL_CONFIG_PREFIX}/../include else if test -e /usr/include/tcl${TCL_VERSION}/tcl.h ; then TCL_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi if test -e ${TK_CONFIG_PREFIX}/../include/tk.h ; then TK_INCLUDE=-I${TK_CONFIG_PREFIX}/../include else if test -e /usr/include/tcl${TCL_VERSION}/tk.h ; then TK_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi fi AM_CONDITIONAL([AMM_TK],[test "$TK_CONFIG_PREFIX" != ""]) AC_MSG_CHECKING([for tcl/tk]) if test -d "${TK_CONFIG_PREFIX}" ; then AC_MSG_RESULT([using TK_VERSION=${TK_VERSION} of ${TK_CONFIG_PREFIX}]) AC_SUBST(TK_CONFIG_PREFIX) AC_SUBST(TK_XLIB_DIR) AC_SUBST(TK_LIBRARY) AC_SUBST(TCL_LIBRARY) AC_SUBST(TK_INCLUDE) AC_SUBST(TCL_INCLUDE) AC_SUBST(TK_LIB_SPEC) AC_SUBST(TCL_LIB_SPEC) AC_CONFIG_FILES([gcl-tk/gcltksrv]) else AC_MSG_RESULT([not found]) fi AC_SUBST(EXT) AC_CONFIG_FILES([bin/gcl]) AC_CHECK_HEADERS(sys/mman.h,AC_CHECK_FUNCS(mprotect)) AC_CHECK_HEADERS(alloca.h) AC_FUNC_ALLOCA #LDFLAGS="`echo $GPL_FLAG $LDFLAGS | sed 's,gcl.script,../unixport/gcl.script,g'`" LDFLAGS="`echo $GPL_FLAG $LDFLAGS`" #AM_LDFLAGS = $LDFLAGS BASE_LDFLAGS="$LDFLAGS" LDFLAGS="" AC_SUBST(BASE_LDFLAGS) LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $LIBS $TLIBS" #AM_LIBS = $LIBS AC_SUBST(LIBS) CFLAGS="$CFLAGS $GP_FLAG" FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS" AC_SUBST(FINAL_CFLAGS) # Work around bug with gcc on ppc -- CM NIFLAGS="$CFLAGS $CPPFLAGS $TONIFLAGS -I o" AC_SUBST(NIFLAGS) CFLAGS="$CFLAGS $CPPFLAGS $TO3FLAGS -I o" BASE_CFLAGS="$CFLAGS" CFLAGS="" AC_SUBST(BASE_CFLAGS) BASE_CPPFLAGS="-I h -I /usr/include/tirpc $CPPFLAGS" CPPFLAGS= AC_SUBST(BASE_CPPFLAGS) O3FLAGS=$TOSFLAGS AC_SUBST(O3FLAGS) O2FLAGS=$TO2FLAGS AC_SUBST(O2FLAGS) AC_SUBST(EXTRA_LOBJS) AC_SUBST(LEADING_UNDERSCORE) AC_SUBST(GNU_LD) LI_EXTVERS=`echo $MINVERS | cut -f2 -d.` AC_SUBST(LI_EXTVERS) LI_MINVERS=`echo $MINVERS | cut -f1 -d.` AC_SUBST(LI_MINVERS) LI_MAJVERS=$MAJVERS AC_SUBST(LI_MAJVERS) LI_GITTAG="$GIT_TAG" AC_SUBST(LI_GITTAG) LI_RELEASE="$RELEASE" AC_SUBST(LI_RELEASE) LI_CC="\"$GCL_CC -c `echo " $FINAL_CFLAGS" | sed 's,-pg\b,,g'`\"" AC_SUBST(LI_CC) LI_DFP="\"$GPL_FLAG\"" AC_SUBST(LI_DFP) LI_LD="\"$GCL_CC $BASE_LDFLAGS -o\"" AC_SUBST(LI_LD) LI_LD_LIBS="\"$LIBS\"" AC_SUBST(LI_LD_LIBS) LI_OPT_THREE="\"$O3FLAGS\"" AC_SUBST(LI_OPT_THREE) LI_OPT_TWO="\"$O2FLAGS\"" AC_SUBST(LI_OPT_TWO) LI_INIT_LSP="\"init_raw.lsp\"" AC_SUBST(LI_INIT_LSP) AC_CONFIG_FILES([unixport/init_raw.lsp]) if test "$use" != "" ; then AC_OUTPUT cmp $srcdir/h/$use.h h/config.h || cp $srcdir/h/$use.h h/config.h echo configuration for $use done 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 exit 1 fi gcl-2.7.1/PaxHeaders/texinfo.tex0000644000000000000000000000013214776130437013556 xustar0030 mtime=1744351519.923049732 30 atime=1744351519.999049041 30 ctime=1744351535.450909505 gcl-2.7.1/texinfo.tex0000644000175000017500000135102514776130437013163 0ustar00cammcamm% texinfo.tex -- TeX macros to handle Texinfo files. % % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % \def\texinfoversion{2024-02-10.22} % % Copyright 1985, 1986, 1988, 1990-2024 Free Software Foundation, Inc. % % This texinfo.tex 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 texinfo.tex file is distributed in the hope that 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, when this file is read by TeX when processing % a Texinfo source document, you may use the result without % restriction. This Exception is an additional permission under section 7 % of the GNU General Public License, version 3 ("GPLv3"). % % Please try the latest version of texinfo.tex before submitting bug % reports; you can get the latest version from: % https://ftp.gnu.org/gnu/texinfo/ (the Texinfo release area), or % https://ftpmirror.gnu.org/texinfo/ (same, via a mirror), or % https://www.gnu.org/software/texinfo/ (the Texinfo home page) % The texinfo.tex in any given distribution could well be out % of date, so if that's what you're using, please check. % % Send bug reports to bug-texinfo@gnu.org. Please include a % complete document in each bug report with which we can reproduce the % problem. Patches are, of course, greatly appreciated. % % To process a Texinfo manual with TeX, it's most reliable to use the % texi2dvi shell script that comes with the distribution. For a simple % manual foo.texi, however, you can get away with this: % tex foo.texi % texindex foo.?? % tex foo.texi % tex foo.texi % dvips foo.dvi -o # or whatever; this makes foo.ps. % The extra TeX runs get the cross-reference information correct. % Sometimes one run after texindex suffices, and sometimes you need more % than two; texi2dvi does it as many times as necessary. % % It is possible to adapt texinfo.tex for other languages, to some % extent. You can get the existing language-specific files from the % full Texinfo distribution. % % The GNU Texinfo home page is https://www.gnu.org/software/texinfo. \message{Loading texinfo [version \texinfoversion]:} % LaTeX's \typeout. This ensures that the messages it is used for % are identical in format to the corresponding ones from latex/pdflatex. \def\typeout{\immediate\write17}% \chardef\other=12 % We never want plain's \outer definition of \+ in Texinfo. % For @tex, we can use \tabalign. \let\+ = \relax % Save some plain tex macros whose names we will redefine. \let\ptexb=\b \let\ptexbullet=\bullet \let\ptexc=\c \let\ptexcomma=\, \let\ptexdot=\. \let\ptexdots=\dots \let\ptexend=\end \let\ptexequiv=\equiv \let\ptexexclam=\! \let\ptexfootnote=\footnote \let\ptexgtr=> \let\ptexhat=^ \let\ptexi=\i \let\ptexindent=\indent \let\ptexinsert=\insert \let\ptexlbrace=\{ \let\ptexless=< \let\ptexnewwrite\newwrite \let\ptexnoindent=\noindent \let\ptexplus=+ \let\ptexraggedright=\raggedright \let\ptexrbrace=\} \let\ptexslash=\/ \let\ptexsp=\sp \let\ptexstar=\* \let\ptexsup=\sup \let\ptext=\t \let\ptextop=\top {\catcode`\'=\active \global\let\ptexquoteright'}% active in plain's math mode % If this character appears in an error message or help string, it % starts a new line in the output. \newlinechar = `^^J % Use TeX 3.0's \inputlineno to get the line number, for better error % messages, but if we're using an old version of TeX, don't do anything. % \ifx\inputlineno\thisisundefined \let\linenumber = \empty % Pre-3.0. \else \def\linenumber{l.\the\inputlineno:\space} \fi % Set up fixed words for English if not already set. \ifx\putwordAppendix\undefined \gdef\putwordAppendix{Appendix}\fi \ifx\putwordChapter\undefined \gdef\putwordChapter{Chapter}\fi \ifx\putworderror\undefined \gdef\putworderror{error}\fi \ifx\putwordfile\undefined \gdef\putwordfile{file}\fi \ifx\putwordin\undefined \gdef\putwordin{in}\fi \ifx\putwordIndexIsEmpty\undefined \gdef\putwordIndexIsEmpty{(Index is empty)}\fi \ifx\putwordIndexNonexistent\undefined \gdef\putwordIndexNonexistent{(Index is nonexistent)}\fi \ifx\putwordInfo\undefined \gdef\putwordInfo{Info}\fi \ifx\putwordInstanceVariableof\undefined \gdef\putwordInstanceVariableof{Instance Variable of}\fi \ifx\putwordMethodon\undefined \gdef\putwordMethodon{Method on}\fi \ifx\putwordNoTitle\undefined \gdef\putwordNoTitle{No Title}\fi \ifx\putwordof\undefined \gdef\putwordof{of}\fi \ifx\putwordon\undefined \gdef\putwordon{on}\fi \ifx\putwordpage\undefined \gdef\putwordpage{page}\fi \ifx\putwordsection\undefined \gdef\putwordsection{section}\fi \ifx\putwordSection\undefined \gdef\putwordSection{Section}\fi \ifx\putwordsee\undefined \gdef\putwordsee{see}\fi \ifx\putwordSee\undefined \gdef\putwordSee{See}\fi \ifx\putwordShortTOC\undefined \gdef\putwordShortTOC{Short Contents}\fi \ifx\putwordTOC\undefined \gdef\putwordTOC{Table of Contents}\fi % \ifx\putwordMJan\undefined \gdef\putwordMJan{January}\fi \ifx\putwordMFeb\undefined \gdef\putwordMFeb{February}\fi \ifx\putwordMMar\undefined \gdef\putwordMMar{March}\fi \ifx\putwordMApr\undefined \gdef\putwordMApr{April}\fi \ifx\putwordMMay\undefined \gdef\putwordMMay{May}\fi \ifx\putwordMJun\undefined \gdef\putwordMJun{June}\fi \ifx\putwordMJul\undefined \gdef\putwordMJul{July}\fi \ifx\putwordMAug\undefined \gdef\putwordMAug{August}\fi \ifx\putwordMSep\undefined \gdef\putwordMSep{September}\fi \ifx\putwordMOct\undefined \gdef\putwordMOct{October}\fi \ifx\putwordMNov\undefined \gdef\putwordMNov{November}\fi \ifx\putwordMDec\undefined \gdef\putwordMDec{December}\fi % \ifx\putwordDefmac\undefined \gdef\putwordDefmac{Macro}\fi \ifx\putwordDefspec\undefined \gdef\putwordDefspec{Special Form}\fi \ifx\putwordDefvar\undefined \gdef\putwordDefvar{Variable}\fi \ifx\putwordDefopt\undefined \gdef\putwordDefopt{User Option}\fi \ifx\putwordDeffunc\undefined \gdef\putwordDeffunc{Function}\fi % Give the space character the catcode for a space. \def\spaceisspace{\catcode`\ =10\relax} % Likewise for ^^M, the end of line character. \def\endlineisspace{\catcode13=10\relax} \chardef\dashChar = `\- \chardef\slashChar = `\/ \chardef\underChar = `\_ % Ignore a token. % \def\gobble#1{} % The following is used inside several \edef's. \def\makecsname#1{\expandafter\noexpand\csname#1\endcsname} % Hyphenation fixes. \hyphenation{ Flor-i-da Ghost-script Ghost-view Mac-OS Post-Script ap-pen-dix bit-map bit-maps data-base data-bases eshell fall-ing half-way long-est man-u-script man-u-scripts mini-buf-fer mini-buf-fers over-view par-a-digm par-a-digms rath-er rec-tan-gu-lar ro-bot-ics se-vere-ly set-up spa-ces spell-ing spell-ings stand-alone strong-est time-stamp time-stamps which-ever white-space wide-spread wrap-around } % Sometimes it is convenient to have everything in the transcript file % and nothing on the terminal. We don't just call \tracingall here, % since that produces some useless output on the terminal. We also make % some effort to order the tracing commands to reduce output in the log % file; cf. trace.sty in LaTeX. % \def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}% \def\loggingall{% \tracingstats2 \tracingpages1 \tracinglostchars2 % 2 gives us more in etex \tracingparagraphs1 \tracingoutput1 \tracingmacros2 \tracingrestores1 \showboxbreadth\maxdimen \showboxdepth\maxdimen \ifx\eTeXversion\thisisundefined\else % etex gives us more logging \tracingscantokens1 \tracingifs1 \tracinggroups1 \tracingnesting2 \tracingassigns1 \fi \tracingcommands3 % 3 gives us more in etex \errorcontextlines16 }% % @errormsg{MSG}. Do the index-like expansions on MSG, but if things % aren't perfect, it's not the end of the world, being an error message, % after all. % \def\errormsg{\begingroup \indexnofonts \doerrormsg} \def\doerrormsg#1{\errmessage{#1}} % add check for \lastpenalty to plain's definitions. If the last thing % we did was a \nobreak, we don't want to insert more space. % \def\smallbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\smallskipamount \removelastskip\penalty-50\smallskip\fi\fi} \def\medbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\medskipamount \removelastskip\penalty-100\medskip\fi\fi} \def\bigbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\bigskipamount \removelastskip\penalty-200\bigskip\fi\fi} % Output routine % % For a final copy, take out the rectangles % that mark overfull boxes (in case you have decided % that the text looks ok even though it passes the margin). % \def\finalout{\overfullrule=0pt } % Output a mark which sets \thischapter, \thissection and \thiscolor. % We dump everything together because we only have one kind of mark. % This works because we only use \botmark / \topmark, not \firstmark. % % A mark contains a subexpression of the \ifcase ... \fi construct. % \get*marks macros below extract the needed part using \ifcase. % % Another complication is to let the user choose whether \thischapter % (\thissection) refers to the chapter (section) in effect at the top % of a page, or that at the bottom of a page. % \domark is called twice inside \chapmacro, to add one % mark before the section break, and one after. % In the second call \prevchapterdefs is the same as \currentchapterdefs, % and \prevsectiondefs is the same as \currentsectiondefs. % Then if the page is not broken at the mark, some of the previous % section appears on the page, and we can get the name of this section % from \firstmark for @everyheadingmarks top. % @everyheadingmarks bottom uses \botmark. % % See page 260 of The TeXbook. \def\domark{% \toks0=\expandafter{\currentchapterdefs}% \toks2=\expandafter{\currentsectiondefs}% \toks4=\expandafter{\prevchapterdefs}% \toks6=\expandafter{\prevsectiondefs}% \toks8=\expandafter{\currentcolordefs}% \mark{% \the\toks0 \the\toks2 % 0: marks for @everyheadingmarks top \noexpand\or \the\toks4 \the\toks6 % 1: for @everyheadingmarks bottom \noexpand\else \the\toks8 % 2: color marks }% } % \gettopheadingmarks, \getbottomheadingmarks, % \getcolormarks - extract needed part of mark. % % \topmark doesn't work for the very first chapter (after the title % page or the contents), so we use \firstmark there -- this gets us % the mark with the chapter defs, unless the user sneaks in, e.g., % @setcolor (or @url etc.) between @contents and the very first @chapter. \def\gettopheadingmarks{% \ifcase0\the\savedtopmark\fi \ifx\thischapter\empty \ifcase0\firstmark\fi \fi } \def\getbottomheadingmarks{\ifcase1\botmark\fi} \def\getcolormarks{\ifcase2\the\savedtopmark\fi} % Avoid "undefined control sequence" errors. \def\currentchapterdefs{} \def\currentsectiondefs{} \def\currentsection{} \def\prevchapterdefs{} \def\prevsectiondefs{} \def\currentcolordefs{} % Margin to add to right of even pages, to left of odd pages. \newdimen\bindingoffset \newdimen\normaloffset \newdimen\txipagewidth \newdimen\txipageheight % Main output routine. % \chardef\PAGE = 255 \newtoks\defaultoutput \defaultoutput = {\savetopmark\onepageout{\pagecontents\PAGE}} \output=\expandafter{\the\defaultoutput} \newbox\headlinebox \newbox\footlinebox % When outputting the double column layout for indices, an output routine % is run several times, hiding the original value of \topmark. Hence, save % \topmark at the beginning. % \newtoks\savedtopmark \newif\iftopmarksaved \topmarksavedtrue \def\savetopmark{% \iftopmarksaved\else \global\savedtopmark=\expandafter{\topmark}% \global\topmarksavedtrue \fi } % \onepageout takes a vbox as an argument. % \shipout a vbox for a single page, adding an optional header, footer % and footnote. This also causes index entries for this page to be written % to the auxiliary files. % \def\onepageout#1{% \hoffset=\normaloffset % \ifodd\pageno \advance\hoffset by \bindingoffset \else \advance\hoffset by -\bindingoffset\fi % \checkchapterpage % % Make the heading and footing. \makeheadline and \makefootline % use the contents of \headline and \footline. \def\commonheadfootline{\let\hsize=\txipagewidth \texinfochars} \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi \global\setbox\headlinebox = \vbox{\commonheadfootline \makeheadline}% \ifodd\pageno \getoddfootingmarks \else \getevenfootingmarks \fi \global\setbox\footlinebox = \vbox{\commonheadfootline \makefootline}% % {% % Set context for writing to auxiliary files like index files. % Have to do this stuff outside the \shipout because we want it to % take effect in \write's, yet the group defined by the \vbox ends % before the \shipout runs. % \atdummies % don't expand commands in the output. \turnoffactive \shipout\vbox{% % Do this early so pdf references go to the beginning of the page. \ifpdfmakepagedest \pdfdest name{\the\pageno} xyz\fi % \unvbox\headlinebox \pagebody{#1}% \ifdim\ht\footlinebox > 0pt % Only leave this space if the footline is nonempty. % (We lessened \vsize for it in \oddfootingyyy.) % The \baselineskip=24pt in plain's \makefootline has no effect. \vskip 24pt \unvbox\footlinebox \fi % }% }% \global\topmarksavedfalse \advancepageno \ifnum\outputpenalty>-20000 \else\dosupereject\fi } \newinsert\margin \dimen\margin=\maxdimen % Main part of page, including any footnotes \def\pagebody#1{\vbox to\txipageheight{\boxmaxdepth=\maxdepth #1}} {\catcode`\@ =11 \gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi % marginal hacks, juha@viisa.uucp (Juha Takala) \ifvoid\margin\else % marginal info is present \rlap{\kern\hsize\vbox to\z@{\kern1pt\box\margin \vss}}\fi \dimen@=\dp#1\relax \unvbox#1\relax \ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi \ifr@ggedbottom \kern-\dimen@ \vfil \fi} } % Check if we are on the first page of a chapter. Used for printing headings. \newif\ifchapterpage \def\checkchapterpage{% % Get the chapter that was current at the end of the last page \ifcase1\the\savedtopmark\fi \let\prevchaptername\thischaptername % \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi \let\curchaptername\thischaptername % \ifx\curchaptername\prevchaptername \chapterpagefalse \else \chapterpagetrue \fi } % Argument parsing % Parse an argument, then pass it to #1. The argument is the rest of % the input line (except we remove a trailing comment). #1 should be a % macro which expects an ordinary undelimited TeX argument. % For example, \def\foo{\parsearg\fooxxx}. % \def\parsearg{\parseargusing{}} \def\parseargusing#1#2{% \def\argtorun{#2}% \begingroup \obeylines \spaceisspace #1% \parseargline\empty% Insert the \empty token, see \finishparsearg below. } {\obeylines % \gdef\parseargline#1^^M{% \endgroup % End of the group started in \parsearg. \argremovecomment #1\comment\ArgTerm% }% } % First remove any @comment, then any @c comment. Pass the result on to % \argremovespace. \def\argremovecomment#1\comment#2\ArgTerm{\argremovec #1\c\ArgTerm} \def\argremovec#1\c#2\ArgTerm{\argremovespace#1$ $\ArgTerm} % \argremovec might leave us with trailing space, though; e.g., % @end itemize @c foo % Note that the argument cannot contain the TeX $, as its catcode is % changed to \other when Texinfo source is read. \def\argremovespace#1 $#2\ArgTerm{\finishparsearg#1$\ArgTerm} % If a _delimited_ argument is enclosed in braces, they get stripped; so % to get _exactly_ the rest of the line, we had to prevent such situation. % We prepended an \empty token at the very beginning and we expand it % just before passing the control to \next. % (But first, we have to remove the remaining $ or two.) \def\finishparsearg#1$#2\ArgTerm{\expandafter\argtorun\expandafter{#1}} % \parseargdef - define a command taking an argument on the line % % \parseargdef\foo{...} % is roughly equivalent to % \def\foo{\parsearg\Xfoo} % \def\Xfoo#1{...} \def\parseargdef#1{% \expandafter \doparseargdef \csname\string#1\endcsname #1% } \def\doparseargdef#1#2{% \def#2{\parsearg#1}% \def#1##1% } % Several utility definitions with active space: { \obeyspaces \gdef\obeyedspace{ } % Make each space character in the input produce a normal interword % space in the output. Don't allow a line break at this space, as this % is used only in environments like @example, where each line of input % should produce a line of output anyway. % \gdef\sepspaces{\obeyspaces\let =\tie} % If an index command is used in an @example environment, any spaces % therein should become regular spaces in the raw index file, not the % expansion of \tie (\leavevmode \penalty \@M \ ). \gdef\unsepspaces{\let =\space} } \def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next} % Define the framework for environments in texinfo.tex. It's used like this: % % \envdef\foo{...} % \def\Efoo{...} % % It's the responsibility of \envdef to insert \begingroup before the % actual body; @end closes the group after calling \Efoo. \envdef also % defines \thisenv, so the current environment is known; @end checks % whether the environment name matches. The \checkenv macro can also be % used to check whether the current environment is the one expected. % % Non-false conditionals (@iftex, @ifset) don't fit into this, so they % are not treated as environments; they don't open a group. (The % implementation of @end takes care not to call \endgroup in this % special case.) % At run-time, environments start with this: \def\startenvironment#1{\begingroup\def\thisenv{#1}} % initialize \let\thisenv\empty % ... but they get defined via ``\envdef\foo{...}'': \long\def\envdef#1#2{\def#1{\startenvironment#1#2}} \long\def\envparseargdef#1#2{\parseargdef#1{\startenvironment#1#2}} % Check whether we're in the right environment: \def\checkenv#1{% \def\temp{#1}% \ifx\thisenv\temp \else \badenverr \fi } % Environment mismatch, #1 expected: \def\badenverr{% \errhelp = \EMsimple \errmessage{This command can appear only \inenvironment\temp, not \inenvironment\thisenv}% } \def\inenvironment#1{% \ifx#1\empty outside of any environment% \else in environment \expandafter\string#1% \fi } % @end foo calls \checkenv and executes the definition of \Efoo. \parseargdef\end{% \if 1\csname iscond.#1\endcsname \else % The general wording of \badenverr may not be ideal. \expandafter\checkenv\csname#1\endcsname \csname E#1\endcsname \endgroup \fi } \newhelp\EMsimple{Press RETURN to continue.} % Be sure we're in horizontal mode when doing a tie, since we make space % equivalent to this in @example-like environments. Otherwise, a space % at the beginning of a line will start with \penalty -- and % since \penalty is valid in vertical mode, we'd end up putting the % penalty on the vertical list instead of in the new paragraph. {\catcode`@ = 11 % Avoid using \@M directly, because that causes trouble % if the definition is written into an index file. \global\let\tiepenalty = \@M \gdef\tie{\leavevmode\penalty\tiepenalty\ } } % @: forces normal size whitespace following. \def\:{\spacefactor=1000 } % @* forces a line break. \def\*{\unskip\hfil\break\hbox{}\ignorespaces} % @/ allows a line break. \let\/=\allowbreak % @- allows explicit insertion of hyphenation points \def\-{\discretionary{\normaldash}{}{}}% % @. is an end-of-sentence period. \def\.{.\spacefactor=\endofsentencespacefactor\space} % @! is an end-of-sentence bang. \def\!{!\spacefactor=\endofsentencespacefactor\space} % @? is an end-of-sentence query. \def\?{?\spacefactor=\endofsentencespacefactor\space} % @w prevents a word break. Without the \leavevmode, @w at the % beginning of a paragraph, when TeX is still in vertical mode, would % produce a whole line of output instead of starting the paragraph. \def\w#1{\leavevmode\hbox{#1}} % @group ... @end group forces ... to be all on one page, by enclosing % it in a TeX vbox. We use \vtop instead of \vbox to construct the box % to keep its height that of a normal line. According to the rules for % \topskip (p.114 of the TeXbook), the glue inserted is % max (\topskip - \ht (first item), 0). If that height is large, % therefore, no glue is inserted, and the space between the headline and % the text is small, which looks bad. % % Another complication is that the group might be very large. This can % cause the glue on the previous page to be unduly stretched, because it % does not have much material. In this case, it's better to add an % explicit \vfill so that the extra space is at the bottom. The % threshold for doing this is if the group is more than \vfilllimit % percent of a page (\vfilllimit can be changed inside of @tex). % \newbox\groupbox \def\vfilllimit{0.7} % \envdef\group{% \ifnum\catcode`\^^M=\active \else \errhelp = \groupinvalidhelp \errmessage{@group invalid in context where filling is enabled}% \fi \startsavinginserts % \setbox\groupbox = \vtop\bgroup % Do @comment since we are called inside an environment such as % @example, where each end-of-line in the input causes an % end-of-line in the output. We don't want the end-of-line after % the `@group' to put extra space in the output. Since @group % should appear on a line by itself (according to the Texinfo % manual), we don't worry about eating any user text. \comment } % % The \vtop produces a box with normal height and large depth; thus, TeX puts % \baselineskip glue before it, and (when the next line of text is done) % \lineskip glue after it. Thus, space below is not quite equal to space % above. But it's pretty close. \def\Egroup{% % To get correct interline space between the last line of the group % and the first line afterwards, we have to propagate \prevdepth. \endgraf % Not \par, as it may have been set to \lisppar. \global\dimen1 = \prevdepth \egroup % End the \vtop. \addgroupbox \prevdepth = \dimen1 \checkinserts } \def\addgroupbox{ % \dimen0 is the vertical size of the group's box. \dimen0 = \ht\groupbox \advance\dimen0 by \dp\groupbox % \dimen2 is how much space is left on the page (more or less). \dimen2 = \txipageheight \advance\dimen2 by -\pagetotal % if the group doesn't fit on the current page, and it's a big big % group, force a page break. \ifdim \dimen0 > \dimen2 \ifdim \pagetotal < \vfilllimit\txipageheight \page \fi \fi \box\groupbox } % % TeX puts in an \escapechar (i.e., `@') at the beginning of the help % message, so this ends up printing `@group can only ...'. % \newhelp\groupinvalidhelp{% group can only be used in environments such as @example,^^J% where each line of input produces a line of output.} % @need space-in-mils % forces a page break if there is not space-in-mils remaining. \newdimen\mil \mil=0.001in \parseargdef\need{% % Ensure vertical mode, so we don't make a big box in the middle of a % paragraph. \par % % If the @need value is less than one line space, it's useless. \dimen0 = #1\mil \dimen2 = \ht\strutbox \advance\dimen2 by \dp\strutbox \ifdim\dimen0 > \dimen2 % This is similar to the 'needspace' module in LaTeX. % The first penalty allows a break if the end of the page is % not too far away. Following penalties and skips are discarded. % Otherwise, require at least \dimen0 of vertical space. % % (We used to use a \vtop to reserve space, but this had spacing issues % when followed by a section heading, as it was not a "discardable item". % This also has the benefit of providing glue before the page break if % there isn't enough space.) \vskip0pt plus \dimen0 \penalty-100 \vskip0pt plus -\dimen0 \vskip \dimen0 \penalty9999 \vskip -\dimen0 \penalty0\relax % this hides the above glue from \safewhatsit and \dobreak \fi } % @br forces paragraph break (and is undocumented). \let\br = \par % @page forces the start of a new page. % \def\page{\par\vfill\supereject} % @exdent text.... % outputs text on separate line in roman font, starting at standard page margin % This records the amount of indent in the innermost environment. % That's how much \exdent should take out. \newskip\exdentamount % This defn is used inside fill environments such as @defun. \parseargdef\exdent{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break} % This defn is used inside nofill environments such as @example. \parseargdef\nofillexdent{{\advance \leftskip by -\exdentamount \leftline{\hskip\leftskip{\rm#1}}}} % @inmargin{WHICH}{TEXT} puts TEXT in the WHICH margin next to the current % paragraph. For more general purposes, use the \margin insertion % class. WHICH is `l' or `r'. Not documented, written for gawk manual. % \newskip\inmarginspacing \inmarginspacing=1cm \def\strutdepth{\dp\strutbox} % \def\doinmargin#1#2{\strut\vadjust{% \nobreak \kern-\strutdepth \vtop to \strutdepth{% \baselineskip=\strutdepth \vss % if you have multiple lines of stuff to put here, you'll need to % make the vbox yourself of the appropriate size. \ifx#1l% \llap{\ignorespaces #2\hskip\inmarginspacing}% \else \rlap{\hskip\hsize \hskip\inmarginspacing \ignorespaces #2}% \fi \null }% }} \def\inleftmargin{\doinmargin l} \def\inrightmargin{\doinmargin r} % % @inmargin{TEXT [, RIGHT-TEXT]} % (if RIGHT-TEXT is given, use TEXT for left page, RIGHT-TEXT for right; % else use TEXT for both). % \def\inmargin#1{\parseinmargin #1,,\finish} \def\parseinmargin#1,#2,#3\finish{% not perfect, but better than nothing. \setbox0 = \hbox{\ignorespaces #2}% \ifdim\wd0 > 0pt \def\lefttext{#1}% have both texts \def\righttext{#2}% \else \def\lefttext{#1}% have only one text \def\righttext{#1}% \fi % \ifodd\pageno \def\temp{\inrightmargin\righttext}% odd page -> outside is right margin \else \def\temp{\inleftmargin\lefttext}% \fi \temp } % @include FILE -- \input text of FILE. % \def\include{\parseargusing\filenamecatcodes\includezzz} \def\includezzz#1{% \pushthisfilestack \def\thisfile{#1}% {% \makevalueexpandable % we want to expand any @value in FILE. \turnoffactive % and allow special characters in the expansion \indexnofonts % Allow `@@' and other weird things in file names. \wlog{texinfo.tex: doing @include of #1^^J}% \edef\temp{\noexpand\input #1 }% % % This trickery is to read FILE outside of a group, in case it makes % definitions, etc. \expandafter }\temp \popthisfilestack } \def\filenamecatcodes{% \catcode`\\=\other \catcode`~=\other \catcode`^=\other \catcode`_=\other \catcode`|=\other \catcode`<=\other \catcode`>=\other \catcode`+=\other \catcode`-=\other \catcode`\`=\other \catcode`\'=\other } \def\pushthisfilestack{% \expandafter\pushthisfilestackX\popthisfilestack\StackTerm } \def\pushthisfilestackX{% \expandafter\pushthisfilestackY\thisfile\StackTerm } \def\pushthisfilestackY #1\StackTerm #2\StackTerm {% \gdef\popthisfilestack{\gdef\thisfile{#1}\gdef\popthisfilestack{#2}}% } \def\popthisfilestack{\errthisfilestackempty} \def\errthisfilestackempty{\errmessage{Internal error: the stack of filenames is empty.}} % \def\thisfile{} % @center line % outputs that line, centered. % \parseargdef\center{% \ifhmode \let\centersub\centerH \else \let\centersub\centerV \fi \centersub{\hfil \ignorespaces#1\unskip \hfil}% \let\centersub\relax % don't let the definition persist, just in case } \def\centerH#1{{% \hfil\break \advance\hsize by -\leftskip \advance\hsize by -\rightskip \line{#1}% \break }} % \newcount\centerpenalty \def\centerV#1{% % The idea here is the same as in \startdefun, \cartouche, etc.: if % @center is the first thing after a section heading, we need to wipe % out the negative parskip inserted by \sectionheading, but still % prevent a page break here. \centerpenalty = \lastpenalty \ifnum\centerpenalty>10000 \vskip\parskip \fi \ifnum\centerpenalty>9999 \penalty\centerpenalty \fi \line{\kern\leftskip #1\kern\rightskip}% } % @sp n outputs n lines of vertical space % \parseargdef\sp{\vskip #1\baselineskip} % @comment ...line which is ignored... % @c is the same as @comment % @ignore ... @end ignore is another way to write a comment \def\c{\begingroup \catcode`\^^M=\active% \catcode`\@=\other \catcode`\{=\other \catcode`\}=\other% \cxxx} {\catcode`\^^M=\active \gdef\cxxx#1^^M{\endgroup}} % \let\comment\c % @paragraphindent NCHARS % We'll use ems for NCHARS, close enough. % NCHARS can also be the word `asis' or `none'. % We cannot feasibly implement @paragraphindent asis, though. % \def\asisword{asis} % no translation, these are keywords \def\noneword{none} % \parseargdef\paragraphindent{% \def\temp{#1}% \ifx\temp\asisword \else \ifx\temp\noneword \defaultparindent = 0pt \else \defaultparindent = #1em \fi \fi \parindent = \defaultparindent } % @exampleindent NCHARS % We'll use ems for NCHARS like @paragraphindent. % It seems @exampleindent asis isn't necessary, but % I preserve it to make it similar to @paragraphindent. \parseargdef\exampleindent{% \def\temp{#1}% \ifx\temp\asisword \else \ifx\temp\noneword \lispnarrowing = 0pt \else \lispnarrowing = #1em \fi \fi } % @firstparagraphindent WORD % If WORD is `none', then suppress indentation of the first paragraph % after a section heading. If WORD is `insert', then do indent at such % paragraphs. % % The paragraph indentation is suppressed or not by calling % \suppressfirstparagraphindent, which the sectioning commands do. % We switch the definition of this back and forth according to WORD. % By default, we suppress indentation. % \def\suppressfirstparagraphindent{\dosuppressfirstparagraphindent} \def\insertword{insert} % \parseargdef\firstparagraphindent{% \def\temp{#1}% \ifx\temp\noneword \let\suppressfirstparagraphindent = \dosuppressfirstparagraphindent \else\ifx\temp\insertword \let\suppressfirstparagraphindent = \relax \else \errhelp = \EMsimple \errmessage{Unknown @firstparagraphindent option `\temp'}% \fi\fi } % Here is how we actually suppress indentation. Redefine \everypar to % \kern backwards by \parindent, and then reset itself to empty. % % We also make \indent itself not actually do anything until the next % paragraph. % \gdef\dosuppressfirstparagraphindent{% \gdef\indent {\restorefirstparagraphindent \indent}% \gdef\noindent{\restorefirstparagraphindent \noindent}% \global\everypar = {\kern -\parindent \restorefirstparagraphindent}% } % \gdef\restorefirstparagraphindent{% \global\let\indent = \ptexindent \global\let\noindent = \ptexnoindent \global\everypar = {}% } % leave vertical mode without cancelling any first paragraph indent \gdef\imageindent{% \toks0=\everypar \everypar={}% \ptexnoindent \global\everypar=\toks0 } % @refill is a no-op. \let\refill=\relax % @setfilename INFO-FILENAME - ignored \let\setfilename=\comment % @bye. \outer\def\bye{\chappager\pagelabels\tracingstats=1\ptexend} \message{pdf,} % adobe `portable' document format \newcount\tempnum \newcount\lnkcount \newtoks\filename \newcount\filenamelength \newcount\pgn \newtoks\toksA \newtoks\toksB \newtoks\toksC \newtoks\toksD \newbox\boxA \newbox\boxB \newcount\countA \newif\ifpdf \newif\ifpdfmakepagedest % % For LuaTeX % \newif\iftxiuseunicodedestname \txiuseunicodedestnamefalse % For pdfTeX etc. \ifx\luatexversion\thisisundefined \else % Use Unicode destination names \txiuseunicodedestnametrue % Escape PDF strings with converting UTF-16 from UTF-8 \begingroup \catcode`\%=12 \directlua{ function UTF16oct(str) tex.sprint(string.char(0x5c) .. '376' .. string.char(0x5c) .. '377') for c in string.utfvalues(str) do if c < 0x10000 then tex.sprint( string.format(string.char(0x5c) .. string.char(0x25) .. '03o' .. string.char(0x5c) .. string.char(0x25) .. '03o', math.floor(c / 256), math.floor(c % 256))) else c = c - 0x10000 local c_hi = c / 1024 + 0xd800 local c_lo = c % 1024 + 0xdc00 tex.sprint( string.format(string.char(0x5c) .. string.char(0x25) .. '03o' .. string.char(0x5c) .. string.char(0x25) .. '03o' .. string.char(0x5c) .. string.char(0x25) .. '03o' .. string.char(0x5c) .. string.char(0x25) .. '03o', math.floor(c_hi / 256), math.floor(c_hi % 256), math.floor(c_lo / 256), math.floor(c_lo % 256))) end end end } \endgroup \def\pdfescapestrutfsixteen#1{\directlua{UTF16oct('\luaescapestring{#1}')}} % Escape PDF strings without converting \begingroup \directlua{ function PDFescstr(str) for c in string.bytes(str) do if c <= 0x20 or c >= 0x80 or c == 0x28 or c == 0x29 or c == 0x5c then tex.sprint(-2, string.format(string.char(0x5c) .. string.char(0x25) .. '03o', c)) else tex.sprint(-2, string.char(c)) end end end } % The -2 in the arguments here gives all the input to TeX catcode 12 % (other) or 10 (space), preventing undefined control sequence errors. See % https://lists.gnu.org/archive/html/bug-texinfo/2019-08/msg00031.html % \endgroup \def\pdfescapestring#1{\directlua{PDFescstr('\luaescapestring{#1}')}} \ifnum\luatexversion>84 % For LuaTeX >= 0.85 \def\pdfdest{\pdfextension dest} \let\pdfoutput\outputmode \def\pdfliteral{\pdfextension literal} \def\pdfcatalog{\pdfextension catalog} \def\pdftexversion{\numexpr\pdffeedback version\relax} \let\pdfximage\saveimageresource \let\pdfrefximage\useimageresource \let\pdflastximage\lastsavedimageresourceindex \def\pdfendlink{\pdfextension endlink\relax} \def\pdfoutline{\pdfextension outline} \def\pdfstartlink{\pdfextension startlink} \def\pdffontattr{\pdfextension fontattr} \def\pdfobj{\pdfextension obj} \def\pdflastobj{\numexpr\pdffeedback lastobj\relax} \let\pdfpagewidth\pagewidth \let\pdfpageheight\pageheight \edef\pdfhorigin{\pdfvariable horigin} \edef\pdfvorigin{\pdfvariable vorigin} \fi \fi % when pdftex is run in dvi mode, \pdfoutput is defined (so \pdfoutput=1 % can be set). So we test for \relax and 0 as well as being undefined. \ifx\pdfoutput\thisisundefined \else \ifx\pdfoutput\relax \else \ifcase\pdfoutput \else \pdftrue \fi \fi \fi \newif\ifpdforxetex \pdforxetexfalse \ifpdf \pdforxetextrue \fi \ifx\XeTeXrevision\thisisundefined\else \pdforxetextrue \fi % Output page labels information. % See PDF reference v.1.7 p.594, section 8.3.1. % Page label ranges must be increasing. \ifpdf \def\pagelabels{% \def\title{0 << /P (T-) /S /D >>}% % % support @contents at very end of document \ifnum\contentsendcount=\pagecount \ifnum\arabiccount<\romancount \pdfcatalog{/PageLabels << /Nums [\title \the\arabiccount << /S /D >> \the\romancount << /S /r >> ] >> }\relax \fi % no contents in document \else\ifnum\contentsendcount=0 \pdfcatalog{/PageLabels << /Nums [\title \the\arabiccount << /S /D >> ] >> }\relax \else \pdfcatalog{/PageLabels << /Nums [\title \the\romancount << /S /r >> \the\contentsendcount << /S /D >> ] >> }\relax \fi\fi } \else \let\pagelabels\relax \fi \newcount\pagecount \pagecount=0 \newcount\romancount \romancount=0 \newcount\arabiccount \arabiccount=0 \newcount\contentsendcount \contentsendcount=0 \ifpdf \let\ptxadvancepageno\advancepageno \def\advancepageno{% \ptxadvancepageno\global\advance\pagecount by 1 } \fi % PDF uses PostScript string constants for the names of xref targets, % for display in the outlines, and in other places. Thus, we have to % double any backslashes. Otherwise, a name like "\node" will be % interpreted as a newline (\n), followed by o, d, e. Not good. % % See http://www.ntg.nl/pipermail/ntg-pdftex/2004-July/000654.html and % related messages. The final outcome is that it is up to the TeX user % to double the backslashes and otherwise make the string valid, so % that's what we do. pdftex 1.30.0 (ca.2005) introduced a primitive to % do this reliably, so we use it. % #1 is a control sequence in which to do the replacements, % which we \xdef. \def\txiescapepdf#1{% \ifx\pdfescapestring\thisisundefined % No primitive available; should we give a warning or log? % Many times it won't matter. \xdef#1{#1}% \else % The expandable \pdfescapestring primitive escapes parentheses, % backslashes, and other special chars. \xdef#1{\pdfescapestring{#1}}% \fi } \def\txiescapepdfutfsixteen#1{% \ifx\pdfescapestrutfsixteen\thisisundefined % No UTF-16 converting macro available. \txiescapepdf{#1}% \else \xdef#1{\pdfescapestrutfsixteen{#1}}% \fi } \newhelp\nopdfimagehelp{Texinfo supports .png, .jpg, .jpeg, and .pdf images with PDF output, and none of those formats could be found. (.eps cannot be supported due to the design of the PDF format; use regular TeX (DVI output) for that.)} \ifpdf % % Color manipulation macros using ideas from pdfcolor.tex, % except using rgb instead of cmyk; the latter is said to render as a % very dark gray on-screen and a very dark halftone in print, instead % of actual black. The dark red here is dark enough to print on paper as % nearly black, but still distinguishable for online viewing. We use % black by default, though. \def\rgbDarkRed{0.50 0.09 0.12} \def\rgbBlack{0 0 0} % % rg sets the color for filling (usual text, etc.); % RG sets the color for stroking (thin rules, e.g., normal _'s). \def\pdfsetcolor#1{\pdfliteral{#1 rg #1 RG}} % % Set color, and create a mark which defines \thiscolor accordingly, % so that \makeheadline knows which color to restore. \def\curcolor{0 0 0}% \def\setcolor#1{% \ifx#1\curcolor\else \xdef\currentcolordefs{\gdef\noexpand\thiscolor{#1}}% \domark \pdfsetcolor{#1}% \xdef\curcolor{#1}% \fi } % \let\maincolor\rgbBlack \pdfsetcolor{\maincolor} \edef\thiscolor{\maincolor} \def\currentcolordefs{} % \def\makefootline{% \baselineskip24pt \line{\pdfsetcolor{\maincolor}\the\footline}% } % \def\makeheadline{% \vbox to 0pt{% \vskip-22.5pt \line{% \vbox to8.5pt{}% % Extract \thiscolor definition from the marks. \getcolormarks % Typeset the headline with \maincolor, then restore the color. \pdfsetcolor{\maincolor}\the\headline\pdfsetcolor{\thiscolor}% }% \vss }% \nointerlineskip } % % \pdfcatalog{/PageMode /UseOutlines} % % #1 is image name, #2 width (might be empty/whitespace), #3 height (ditto). \def\dopdfimage#1#2#3{% \def\pdfimagewidth{#2}\setbox0 = \hbox{\ignorespaces #2}% \def\pdfimageheight{#3}\setbox2 = \hbox{\ignorespaces #3}% % % pdftex (and the PDF format) support .pdf, .png, .jpg (among % others). Let's try in that order, PDF first since if % someone has a scalable image, presumably better to use that than a % bitmap. \let\pdfimgext=\empty \begingroup \openin 1 #1.pdf \ifeof 1 \openin 1 #1.PDF \ifeof 1 \openin 1 #1.png \ifeof 1 \openin 1 #1.jpg \ifeof 1 \openin 1 #1.jpeg \ifeof 1 \openin 1 #1.JPG \ifeof 1 \errhelp = \nopdfimagehelp \errmessage{Could not find image file #1 for pdf}% \else \gdef\pdfimgext{JPG}% \fi \else \gdef\pdfimgext{jpeg}% \fi \else \gdef\pdfimgext{jpg}% \fi \else \gdef\pdfimgext{png}% \fi \else \gdef\pdfimgext{PDF}% \fi \else \gdef\pdfimgext{pdf}% \fi \closein 1 \endgroup % % without \immediate, ancient pdftex seg faults when the same image is % included twice. (Version 3.14159-pre-1.0-unofficial-20010704.) \ifnum\pdftexversion < 14 \immediate\pdfimage \else \immediate\pdfximage \fi \ifdim \wd0 >0pt width \pdfimagewidth \fi \ifdim \wd2 >0pt height \pdfimageheight \fi \ifnum\pdftexversion<13 #1.\pdfimgext \else {#1.\pdfimgext}% \fi \ifnum\pdftexversion < 14 \else \pdfrefximage \pdflastximage \fi} % \def\setpdfdestname#1{{% % We have to set dummies so commands such as @code, and characters % such as \, aren't expanded when present in a section title. \indexnofonts \makevalueexpandable \turnoffactive \iftxiuseunicodedestname \ifx \declaredencoding \latone % Pass through Latin-1 characters. % LuaTeX with byte wise I/O converts Latin-1 characters to Unicode. \else \ifx \declaredencoding \utfeight % Pass through Unicode characters. \else % Use ASCII approximations in destination names. \passthroughcharsfalse \fi \fi \else % Use ASCII approximations in destination names. \passthroughcharsfalse \fi \def\pdfdestname{#1}% \txiescapepdf\pdfdestname }} % \def\setpdfoutlinetext#1{{% \indexnofonts \makevalueexpandable \turnoffactive \ifx \declaredencoding \latone % The PDF format can use an extended form of Latin-1 in bookmark % strings. See Appendix D of the PDF Reference, Sixth Edition, for % the "PDFDocEncoding". \passthroughcharstrue % Pass through Latin-1 characters. % LuaTeX: Convert to Unicode % pdfTeX: Use Latin-1 as PDFDocEncoding \def\pdfoutlinetext{#1}% \else \ifx \declaredencoding \utfeight \ifx\luatexversion\thisisundefined % For pdfTeX with UTF-8. % TODO: the PDF format can use UTF-16 in bookmark strings, % but the code for this isn't done yet. % Use ASCII approximations. \passthroughcharsfalse \def\pdfoutlinetext{#1}% \else % For LuaTeX with UTF-8. % Pass through Unicode characters for title texts. \passthroughcharstrue \def\pdfoutlinetext{#1}% \fi \else % For non-Latin-1 or non-UTF-8 encodings. % Use ASCII approximations. \passthroughcharsfalse \def\pdfoutlinetext{#1}% \fi \fi % LuaTeX: Convert to UTF-16 % pdfTeX: Use Latin-1 as PDFDocEncoding \txiescapepdfutfsixteen\pdfoutlinetext }} % \def\pdfmkdest#1{% \setpdfdestname{#1}% \safewhatsit{\pdfdest name{\pdfdestname} xyz}% } % % used to mark target names; must be expandable. \def\pdfmkpgn#1{#1} % % by default, use black for everything. \def\urlcolor{\rgbBlack} \let\linkcolor\rgbBlack \def\endlink{\setcolor{\maincolor}\pdfendlink} % % Adding outlines to PDF; macros for calculating structure of outlines % come from Petr Olsak \def\expnumber#1{\expandafter\ifx\csname#1\endcsname\relax 0% \else \csname#1\endcsname \fi} \def\advancenumber#1{\tempnum=\expnumber{#1}\relax \advance\tempnum by 1 \expandafter\xdef\csname#1\endcsname{\the\tempnum}} % % #1 is the section text, which is what will be displayed in the % outline by the pdf viewer. #2 is the pdf expression for the number % of subentries (or empty, for subsubsections). #3 is the node text, % which might be empty if this toc entry had no corresponding node. % #4 is the page number % \def\dopdfoutline#1#2#3#4{% % Generate a link to the node text if that exists; else, use the % page number. We could generate a destination for the section % text in the case where a section has no node, but it doesn't % seem worth the trouble, since most documents are normally structured. \setpdfoutlinetext{#1} \setpdfdestname{#3} \ifx\pdfdestname\empty \def\pdfdestname{#4}% \fi % \pdfoutline goto name{\pdfmkpgn{\pdfdestname}}#2{\pdfoutlinetext}% } % \def\pdfmakeoutlines{% \begingroup % Read toc silently, to get counts of subentries for \pdfoutline. \def\partentry##1##2##3##4{}% ignore parts in the outlines \def\numchapentry##1##2##3##4{% \def\thischapnum{##2}% \def\thissecnum{0}% \def\thissubsecnum{0}% }% \def\numsecentry##1##2##3##4{% \advancenumber{chap\thischapnum}% \def\thissecnum{##2}% \def\thissubsecnum{0}% }% \def\numsubsecentry##1##2##3##4{% \advancenumber{sec\thissecnum}% \def\thissubsecnum{##2}% }% \def\numsubsubsecentry##1##2##3##4{% \advancenumber{subsec\thissubsecnum}% }% \def\thischapnum{0}% \def\thissecnum{0}% \def\thissubsecnum{0}% % % use \def rather than \let here because we redefine \chapentry et % al. a second time, below. \def\appentry{\numchapentry}% \def\appsecentry{\numsecentry}% \def\appsubsecentry{\numsubsecentry}% \def\appsubsubsecentry{\numsubsubsecentry}% \def\unnchapentry{\numchapentry}% \def\unnsecentry{\numsecentry}% \def\unnsubsecentry{\numsubsecentry}% \def\unnsubsubsecentry{\numsubsubsecentry}% \readdatafile{toc}% % % Read toc second time, this time actually producing the outlines. % The `-' means take the \expnumber as the absolute number of % subentries, which we calculated on our first read of the .toc above. % % We use the node names as the destinations. % % Currently we prefix the section name with the section number % for chapter and appendix headings only in order to avoid too much % horizontal space being required in the PDF viewer. \def\numchapentry##1##2##3##4{% \dopdfoutline{##2 ##1}{count-\expnumber{chap##2}}{##3}{##4}}% \def\unnchapentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{chap##2}}{##3}{##4}}% \def\numsecentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{sec##2}}{##3}{##4}}% \def\numsubsecentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{subsec##2}}{##3}{##4}}% \def\numsubsubsecentry##1##2##3##4{% count is always zero \dopdfoutline{##1}{}{##3}{##4}}% % % PDF outlines are displayed using system fonts, instead of % document fonts. Therefore we cannot use special characters, % since the encoding is unknown. For example, the eogonek from % Latin 2 (0xea) gets translated to a | character. Info from % Staszek Wawrykiewicz, 19 Jan 2004 04:09:24 +0100. % % TODO this right, we have to translate 8-bit characters to % their "best" equivalent, based on the @documentencoding. Too % much work for too little return. Just use the ASCII equivalents % we use for the index sort strings. % \indexnofonts \setupdatafile % We can have normal brace characters in the PDF outlines, unlike % Texinfo index files. So set that up. \def\{{\lbracecharliteral}% \def\}{\rbracecharliteral}% \catcode`\\=\active \otherbackslash \input \tocreadfilename \endgroup } {\catcode`[=1 \catcode`]=2 \catcode`{=\other \catcode`}=\other \gdef\lbracecharliteral[{]% \gdef\rbracecharliteral[}]% ] % \def\skipspaces#1{\def\PP{#1}\def\D{|}% \ifx\PP\D\let\nextsp\relax \else\let\nextsp\skipspaces \addtokens{\filename}{\PP}% \advance\filenamelength by 1 \fi \nextsp} \def\getfilename#1{% \filenamelength=0 % If we don't expand the argument now, \skipspaces will get % snagged on things like "@value{foo}". \edef\temp{#1}% \expandafter\skipspaces\temp|\relax } \ifnum\pdftexversion < 14 \let \startlink \pdfannotlink \else \let \startlink \pdfstartlink \fi % make a live url in pdf output. \def\pdfurl#1{% \begingroup % it seems we really need yet another set of dummies; have not % tried to figure out what each command should do in the context % of @url. for now, just make @/ a no-op, that's the only one % people have actually reported a problem with. % \normalturnoffactive \def\@{@}% \let\/=\empty \makevalueexpandable % do we want to go so far as to use \indexnofonts instead of just % special-casing \var here? \def\var##1{##1}% % \leavevmode\setcolor{\urlcolor}% \startlink attr{/Border [0 0 0]}% user{/Subtype /Link /A << /S /URI /URI (#1) >>}% \endgroup} % \pdfgettoks - Surround page numbers in #1 with @pdflink. #1 may % be a simple number, or a list of numbers in the case of an index % entry. \def\pdfgettoks#1.{\setbox\boxA=\hbox{\toksA={#1.}\toksB={}\maketoks}} \def\addtokens#1#2{\edef\addtoks{\noexpand#1={\the#1#2}}\addtoks} \def\adn#1{\addtokens{\toksC}{#1}\global\countA=1\let\next=\maketoks} \def\poptoks#1#2|ENDTOKS|{\let\first=#1\toksD={#1}\toksA={#2}} \def\maketoks{% \expandafter\poptoks\the\toksA|ENDTOKS|\relax \ifx\first0\adn0 \else\ifx\first1\adn1 \else\ifx\first2\adn2 \else\ifx\first3\adn3 \else\ifx\first4\adn4 \else\ifx\first5\adn5 \else\ifx\first6\adn6 \else\ifx\first7\adn7 \else\ifx\first8\adn8 \else\ifx\first9\adn9 \else \ifnum0=\countA\else\makelink\fi \ifx\first.\let\next=\done\else \let\next=\maketoks \addtokens{\toksB}{\the\toksD} \ifx\first,\addtokens{\toksB}{\space}\fi \fi \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi \next} \def\makelink{\addtokens{\toksB}% {\noexpand\pdflink{\the\toksC}}\toksC={}\global\countA=0} \def\pdflink#1{\pdflinkpage{#1}{#1}}% \def\pdflinkpage#1#2{% \startlink attr{/Border [0 0 0]} goto name{\pdfmkpgn{#1}} \setcolor{\linkcolor}#2\endlink} \def\done{\edef\st{\global\noexpand\toksA={\the\toksB}}\st} \else % non-pdf mode \let\pdfmkdest = \gobble \let\pdfurl = \gobble \let\endlink = \relax \let\setcolor = \gobble \let\pdfsetcolor = \gobble \let\pdfmakeoutlines = \relax \fi % \ifx\pdfoutput % % For XeTeX % \ifx\XeTeXrevision\thisisundefined \else % % XeTeX version check % \ifnum\strcmp{\the\XeTeXversion\XeTeXrevision}{0.99996}>-1 % TeX Live 2016 contains XeTeX 0.99996 and xdvipdfmx 20160307. % It can use the `dvipdfmx:config' special (from TeX Live SVN r40941). % For avoiding PDF destination name replacement, we use this special % instead of xdvipdfmx's command line option `-C 0x0010'. \special{dvipdfmx:config C 0x0010} % XeTeX 0.99995+ comes with xdvipdfmx 20160307+. % It can handle Unicode destination names for PDF. \txiuseunicodedestnametrue \else % XeTeX < 0.99996 (TeX Live < 2016) cannot use the % `dvipdfmx:config' special. % So for avoiding PDF destination name replacement, % xdvipdfmx's command line option `-C 0x0010' is necessary. % % XeTeX < 0.99995 can not handle Unicode destination names for PDF % because xdvipdfmx 20150315 has a UTF-16 conversion issue. % It is fixed by xdvipdfmx 20160106 (TeX Live SVN r39753). \txiuseunicodedestnamefalse \fi % % Color support % \def\rgbDarkRed{0.50 0.09 0.12} \def\rgbBlack{0 0 0} % \def\pdfsetcolor#1{\special{pdf:scolor [#1]}} % % Set color, and create a mark which defines \thiscolor accordingly, % so that \makeheadline knows which color to restore. \def\setcolor#1{% \xdef\currentcolordefs{\gdef\noexpand\thiscolor{#1}}% \domark \pdfsetcolor{#1}% } % \def\maincolor{\rgbBlack} \pdfsetcolor{\maincolor} \edef\thiscolor{\maincolor} \def\currentcolordefs{} % \def\makefootline{% \baselineskip24pt \line{\pdfsetcolor{\maincolor}\the\footline}% } % \def\makeheadline{% \vbox to 0pt{% \vskip-22.5pt \line{% \vbox to8.5pt{}% % Extract \thiscolor definition from the marks. \getcolormarks % Typeset the headline with \maincolor, then restore the color. \pdfsetcolor{\maincolor}\the\headline\pdfsetcolor{\thiscolor}% }% \vss }% \nointerlineskip } % % PDF outline support % % Emulate pdfTeX primitive \def\pdfdest name#1 xyz{% \special{pdf:dest (#1) [@thispage /XYZ @xpos @ypos null]}% } % \def\setpdfdestname#1{{% % We have to set dummies so commands such as @code, and characters % such as \, aren't expanded when present in a section title. \indexnofonts \makevalueexpandable \turnoffactive \iftxiuseunicodedestname % Pass through Unicode characters. \else % Use ASCII approximations in destination names. \passthroughcharsfalse \fi \def\pdfdestname{#1}% \txiescapepdf\pdfdestname }} % \def\setpdfoutlinetext#1{{% \turnoffactive % Always use Unicode characters in title texts. \def\pdfoutlinetext{#1}% % For XeTeX, xdvipdfmx converts to UTF-16. % So we do not convert. \txiescapepdf\pdfoutlinetext }} % \def\pdfmkdest#1{% \setpdfdestname{#1}% \safewhatsit{\pdfdest name{\pdfdestname} xyz}% } % % by default, use black for everything. \def\urlcolor{\rgbBlack} \def\linkcolor{\rgbBlack} \def\endlink{\setcolor{\maincolor}\pdfendlink} % \def\dopdfoutline#1#2#3#4{% \setpdfoutlinetext{#1} \setpdfdestname{#3} \ifx\pdfdestname\empty \def\pdfdestname{#4}% \fi % \special{pdf:out [-] #2 << /Title (\pdfoutlinetext) /A << /S /GoTo /D (\pdfdestname) >> >> }% } % \def\pdfmakeoutlines{% \begingroup % % For XeTeX, counts of subentries are not necessary. % Therefore, we read toc only once. % % We use node names as destinations. % % Currently we prefix the section name with the section number % for chapter and appendix headings only in order to avoid too much % horizontal space being required in the PDF viewer. \def\partentry##1##2##3##4{}% ignore parts in the outlines \def\numchapentry##1##2##3##4{% \dopdfoutline{##2 ##1}{1}{##3}{##4}}% \def\numsecentry##1##2##3##4{% \dopdfoutline{##1}{2}{##3}{##4}}% \def\numsubsecentry##1##2##3##4{% \dopdfoutline{##1}{3}{##3}{##4}}% \def\numsubsubsecentry##1##2##3##4{% \dopdfoutline{##1}{4}{##3}{##4}}% % \let\appentry\numchapentry% \let\appsecentry\numsecentry% \let\appsubsecentry\numsubsecentry% \let\appsubsubsecentry\numsubsubsecentry% \def\unnchapentry##1##2##3##4{% \dopdfoutline{##1}{1}{##3}{##4}}% \let\unnsecentry\numsecentry% \let\unnsubsecentry\numsubsecentry% \let\unnsubsubsecentry\numsubsubsecentry% % % For XeTeX, xdvipdfmx converts strings to UTF-16. % Therefore, the encoding and the language may not be considered. % \indexnofonts \setupdatafile % We can have normal brace characters in the PDF outlines, unlike % Texinfo index files. So set that up. \def\{{\lbracecharliteral}% \def\}{\rbracecharliteral}% \catcode`\\=\active \otherbackslash \input \tocreadfilename \endgroup } {\catcode`[=1 \catcode`]=2 \catcode`{=\other \catcode`}=\other \gdef\lbracecharliteral[{]% \gdef\rbracecharliteral[}]% ] \special{pdf:docview << /PageMode /UseOutlines >> } % ``\special{pdf:tounicode ...}'' is not necessary % because xdvipdfmx converts strings from UTF-8 to UTF-16 without it. % However, due to a UTF-16 conversion issue of xdvipdfmx 20150315, % ``\special{pdf:dest ...}'' cannot handle non-ASCII strings. % It is fixed by xdvipdfmx 20160106 (TeX Live SVN r39753). % \def\skipspaces#1{\def\PP{#1}\def\D{|}% \ifx\PP\D\let\nextsp\relax \else\let\nextsp\skipspaces \addtokens{\filename}{\PP}% \advance\filenamelength by 1 \fi \nextsp} \def\getfilename#1{% \filenamelength=0 % If we don't expand the argument now, \skipspaces will get % snagged on things like "@value{foo}". \edef\temp{#1}% \expandafter\skipspaces\temp|\relax } % make a live url in pdf output. \def\pdfurl#1{% \begingroup % it seems we really need yet another set of dummies; have not % tried to figure out what each command should do in the context % of @url. for now, just make @/ a no-op, that's the only one % people have actually reported a problem with. % \normalturnoffactive \def\@{@}% \let\/=\empty \makevalueexpandable % do we want to go so far as to use \indexnofonts instead of just % special-casing \var here? \def\var##1{##1}% % \leavevmode\setcolor{\urlcolor}% \special{pdf:bann << /Border [0 0 0] /Subtype /Link /A << /S /URI /URI (#1) >> >>}% \endgroup} \def\endlink{\setcolor{\maincolor}\special{pdf:eann}} \def\pdfgettoks#1.{\setbox\boxA=\hbox{\toksA={#1.}\toksB={}\maketoks}} \def\addtokens#1#2{\edef\addtoks{\noexpand#1={\the#1#2}}\addtoks} \def\adn#1{\addtokens{\toksC}{#1}\global\countA=1\let\next=\maketoks} \def\poptoks#1#2|ENDTOKS|{\let\first=#1\toksD={#1}\toksA={#2}} \def\maketoks{% \expandafter\poptoks\the\toksA|ENDTOKS|\relax \ifx\first0\adn0 \else\ifx\first1\adn1 \else\ifx\first2\adn2 \else\ifx\first3\adn3 \else\ifx\first4\adn4 \else\ifx\first5\adn5 \else\ifx\first6\adn6 \else\ifx\first7\adn7 \else\ifx\first8\adn8 \else\ifx\first9\adn9 \else \ifnum0=\countA\else\makelink\fi \ifx\first.\let\next=\done\else \let\next=\maketoks \addtokens{\toksB}{\the\toksD} \ifx\first,\addtokens{\toksB}{\space}\fi \fi \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi \next} \def\makelink{\addtokens{\toksB}% {\noexpand\pdflink{\the\toksC}}\toksC={}\global\countA=0} \def\pdflink#1{\pdflinkpage{#1}{#1}}% \def\pdflinkpage#1#2{% \special{pdf:bann << /Border [0 0 0] /Type /Annot /Subtype /Link /A << /S /GoTo /D (#1) >> >>}% \setcolor{\linkcolor}#2\endlink} \def\done{\edef\st{\global\noexpand\toksA={\the\toksB}}\st} % % % @image support % % #1 is image name, #2 width (might be empty/whitespace), #3 height (ditto). \def\doxeteximage#1#2#3{% \def\xeteximagewidth{#2}\setbox0 = \hbox{\ignorespaces #2}% \def\xeteximageheight{#3}\setbox2 = \hbox{\ignorespaces #3}% % % XeTeX (and the PDF format) supports .pdf, .png, .jpg (among % others). Let's try in that order, PDF first since if % someone has a scalable image, presumably better to use that than a % bitmap. \let\xeteximgext=\empty \begingroup \openin 1 #1.pdf \ifeof 1 \openin 1 #1.PDF \ifeof 1 \openin 1 #1.png \ifeof 1 \openin 1 #1.jpg \ifeof 1 \openin 1 #1.jpeg \ifeof 1 \openin 1 #1.JPG \ifeof 1 \errmessage{Could not find image file #1 for XeTeX}% \else \gdef\xeteximgext{JPG}% \fi \else \gdef\xeteximgext{jpeg}% \fi \else \gdef\xeteximgext{jpg}% \fi \else \gdef\xeteximgext{png}% \fi \else \gdef\xeteximgext{PDF}% \fi \else \gdef\xeteximgext{pdf}% \fi \closein 1 \endgroup % % Putting an \hbox around the image can prevent an over-long line % after the image. \hbox\bgroup \def\xetexpdfext{pdf}% \ifx\xeteximgext\xetexpdfext \XeTeXpdffile "#1".\xeteximgext "" \else \def\xetexpdfext{PDF}% \ifx\xeteximgext\xetexpdfext \XeTeXpdffile "#1".\xeteximgext "" \else \XeTeXpicfile "#1".\xeteximgext "" \fi \fi \ifdim \wd0 >0pt width \xeteximagewidth \fi \ifdim \wd2 >0pt height \xeteximageheight \fi \relax \egroup } \fi % \message{fonts,} % Set the baselineskip to #1, and the lineskip and strut size % correspondingly. There is no deep meaning behind these magic numbers % used as factors; they just match (closely enough) what Knuth defined. % \def\lineskipfactor{.08333} \def\strutheightpercent{.70833} \def\strutdepthpercent {.29167} % % can get a sort of poor man's double spacing by redefining this. \def\baselinefactor{1} % \newdimen\textleading \def\setleading#1{% \dimen0 = #1\relax \normalbaselineskip = \baselinefactor\dimen0 \normallineskip = \lineskipfactor\normalbaselineskip \normalbaselines \setbox\strutbox =\hbox{% \vrule width0pt height\strutheightpercent\baselineskip depth \strutdepthpercent \baselineskip }% } % PDF CMaps. See also LaTeX's t1.cmap. % % do nothing with this by default. \expandafter\let\csname cmapOT1\endcsname\gobble \expandafter\let\csname cmapOT1IT\endcsname\gobble \expandafter\let\csname cmapOT1TT\endcsname\gobble % if we are producing pdf, and we have \pdffontattr, then define cmaps. % (\pdffontattr was introduced many years ago, but people still run % older pdftex's; it's easy to conditionalize, so we do.) \ifpdf \ifx\pdffontattr\thisisundefined \else \begingroup \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char. \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap %%DocumentNeededResources: ProcSet (CIDInit) %%IncludeResource: ProcSet (CIDInit) %%BeginResource: CMap (TeX-OT1-0) %%Title: (TeX-OT1-0 TeX OT1 0) %%Version: 1.000 %%EndComments /CIDInit /ProcSet findresource begin 12 dict begin begincmap /CIDSystemInfo << /Registry (TeX) /Ordering (OT1) /Supplement 0 >> def /CMapName /TeX-OT1-0 def /CMapType 2 def 1 begincodespacerange <00> <7F> endcodespacerange 8 beginbfrange <00> <01> <0393> <09> <0A> <03A8> <23> <26> <0023> <28> <3B> <0028> <3F> <5B> <003F> <5D> <5E> <005D> <61> <7A> <0061> <7B> <7C> <2013> endbfrange 40 beginbfchar <02> <0398> <03> <039B> <04> <039E> <05> <03A0> <06> <03A3> <07> <03D2> <08> <03A6> <0B> <00660066> <0C> <00660069> <0D> <0066006C> <0E> <006600660069> <0F> <00660066006C> <10> <0131> <11> <0237> <12> <0060> <13> <00B4> <14> <02C7> <15> <02D8> <16> <00AF> <17> <02DA> <18> <00B8> <19> <00DF> <1A> <00E6> <1B> <0153> <1C> <00F8> <1D> <00C6> <1E> <0152> <1F> <00D8> <21> <0021> <22> <201D> <27> <2019> <3C> <00A1> <3D> <003D> <3E> <00BF> <5C> <201C> <5F> <02D9> <60> <2018> <7D> <02DD> <7E> <007E> <7F> <00A8> endbfchar endcmap CMapName currentdict /CMap defineresource pop end end %%EndResource %%EOF }\endgroup \expandafter\edef\csname cmapOT1\endcsname#1{% \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}% }% % % \cmapOT1IT \begingroup \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char. \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap %%DocumentNeededResources: ProcSet (CIDInit) %%IncludeResource: ProcSet (CIDInit) %%BeginResource: CMap (TeX-OT1IT-0) %%Title: (TeX-OT1IT-0 TeX OT1IT 0) %%Version: 1.000 %%EndComments /CIDInit /ProcSet findresource begin 12 dict begin begincmap /CIDSystemInfo << /Registry (TeX) /Ordering (OT1IT) /Supplement 0 >> def /CMapName /TeX-OT1IT-0 def /CMapType 2 def 1 begincodespacerange <00> <7F> endcodespacerange 8 beginbfrange <00> <01> <0393> <09> <0A> <03A8> <25> <26> <0025> <28> <3B> <0028> <3F> <5B> <003F> <5D> <5E> <005D> <61> <7A> <0061> <7B> <7C> <2013> endbfrange 42 beginbfchar <02> <0398> <03> <039B> <04> <039E> <05> <03A0> <06> <03A3> <07> <03D2> <08> <03A6> <0B> <00660066> <0C> <00660069> <0D> <0066006C> <0E> <006600660069> <0F> <00660066006C> <10> <0131> <11> <0237> <12> <0060> <13> <00B4> <14> <02C7> <15> <02D8> <16> <00AF> <17> <02DA> <18> <00B8> <19> <00DF> <1A> <00E6> <1B> <0153> <1C> <00F8> <1D> <00C6> <1E> <0152> <1F> <00D8> <21> <0021> <22> <201D> <23> <0023> <24> <00A3> <27> <2019> <3C> <00A1> <3D> <003D> <3E> <00BF> <5C> <201C> <5F> <02D9> <60> <2018> <7D> <02DD> <7E> <007E> <7F> <00A8> endbfchar endcmap CMapName currentdict /CMap defineresource pop end end %%EndResource %%EOF }\endgroup \expandafter\edef\csname cmapOT1IT\endcsname#1{% \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}% }% % % \cmapOT1TT \begingroup \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char. \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap %%DocumentNeededResources: ProcSet (CIDInit) %%IncludeResource: ProcSet (CIDInit) %%BeginResource: CMap (TeX-OT1TT-0) %%Title: (TeX-OT1TT-0 TeX OT1TT 0) %%Version: 1.000 %%EndComments /CIDInit /ProcSet findresource begin 12 dict begin begincmap /CIDSystemInfo << /Registry (TeX) /Ordering (OT1TT) /Supplement 0 >> def /CMapName /TeX-OT1TT-0 def /CMapType 2 def 1 begincodespacerange <00> <7F> endcodespacerange 5 beginbfrange <00> <01> <0393> <09> <0A> <03A8> <21> <26> <0021> <28> <5F> <0028> <61> <7E> <0061> endbfrange 32 beginbfchar <02> <0398> <03> <039B> <04> <039E> <05> <03A0> <06> <03A3> <07> <03D2> <08> <03A6> <0B> <2191> <0C> <2193> <0D> <0027> <0E> <00A1> <0F> <00BF> <10> <0131> <11> <0237> <12> <0060> <13> <00B4> <14> <02C7> <15> <02D8> <16> <00AF> <17> <02DA> <18> <00B8> <19> <00DF> <1A> <00E6> <1B> <0153> <1C> <00F8> <1D> <00C6> <1E> <0152> <1F> <00D8> <20> <2423> <27> <2019> <60> <2018> <7F> <00A8> endbfchar endcmap CMapName currentdict /CMap defineresource pop end end %%EndResource %%EOF }\endgroup \expandafter\edef\csname cmapOT1TT\endcsname#1{% \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}% }% \fi\fi % % This is what gets called when #5 of \setfont is empty. \let\cmap\gobble % % (end of cmaps) % Set the font macro #1 to the font named \fontprefix#2. % #3 is the font's design size, #4 is a scale factor, #5 is the CMap % encoding (only OT1, OT1IT and OT1TT are allowed, or empty to omit). % Example: % #1 = \textrm % #2 = \rmshape % #3 = 10 % #4 = \mainmagstep % #5 = OT1 % \def\setfont#1#2#3#4#5{% \font#1=\fontprefix#2#3 scaled #4 \csname cmap#5\endcsname#1% \ifx#2\ttshape\hyphenchar#1=-1 \fi \ifx#2\ttbshape\hyphenchar#1=-1 \fi \ifx#2\ttslshape\hyphenchar#1=-1 \fi } % Use cm as the default font prefix. % To specify the font prefix, you must define \fontprefix % before you read in texinfo.tex. \ifx\fontprefix\thisisundefined \def\fontprefix{cm} \fi % Support font families that don't use the same naming scheme as CM. \def\rmshape{r} \def\rmbshape{bx} % where the normal face is bold \def\bfshape{b} \def\bxshape{bx} \def\ttshape{tt} \def\ttbshape{tt} \def\ttslshape{sltt} \def\itshape{ti} \def\itbshape{bxti} \def\slshape{sl} \def\slbshape{bxsl} \def\sfshape{ss} \def\sfbshape{ss} \def\scshape{csc} \def\scbshape{csc} % Definitions for a main text size of 11pt. (The default in Texinfo.) % \def\definetextfontsizexi{% % Text fonts (11.2pt, magstep1). \def\textnominalsize{11pt} \edef\mainmagstep{\magstephalf} \setfont\textrm\rmshape{10}{\mainmagstep}{OT1} \setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT} \setfont\textbf\bfshape{10}{\mainmagstep}{OT1} \setfont\textit\itshape{10}{\mainmagstep}{OT1IT} \setfont\textsl\slshape{10}{\mainmagstep}{OT1} \setfont\textsf\sfshape{10}{\mainmagstep}{OT1} \setfont\textsc\scshape{10}{\mainmagstep}{OT1} \setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT} \font\texti=cmmi10 scaled \mainmagstep \font\textsy=cmsy10 scaled \mainmagstep \def\textecsize{1095} % A few fonts for @defun names and args. \setfont\defbf\bfshape{10}{\magstep1}{OT1} \setfont\deftt\ttshape{10}{\magstep1}{OT1TT} \setfont\defsl\slshape{10}{\magstep1}{OT1} \setfont\defttsl\ttslshape{10}{\magstep1}{OT1TT} \def\df{\let\ttfont=\deftt \let\bffont = \defbf \let\ttslfont=\defttsl \let\slfont=\defsl \bf} % Fonts for indices, footnotes, small examples (9pt). \def\smallnominalsize{9pt} \setfont\smallrm\rmshape{9}{1000}{OT1} \setfont\smalltt\ttshape{9}{1000}{OT1TT} \setfont\smallbf\bfshape{10}{900}{OT1} \setfont\smallit\itshape{9}{1000}{OT1IT} \setfont\smallsl\slshape{9}{1000}{OT1} \setfont\smallsf\sfshape{9}{1000}{OT1} \setfont\smallsc\scshape{10}{900}{OT1} \setfont\smallttsl\ttslshape{10}{900}{OT1TT} \font\smalli=cmmi9 \font\smallsy=cmsy9 \def\smallecsize{0900} % Fonts for small examples (8pt). \def\smallernominalsize{8pt} \setfont\smallerrm\rmshape{8}{1000}{OT1} \setfont\smallertt\ttshape{8}{1000}{OT1TT} \setfont\smallerbf\bfshape{10}{800}{OT1} \setfont\smallerit\itshape{8}{1000}{OT1IT} \setfont\smallersl\slshape{8}{1000}{OT1} \setfont\smallersf\sfshape{8}{1000}{OT1} \setfont\smallersc\scshape{10}{800}{OT1} \setfont\smallerttsl\ttslshape{10}{800}{OT1TT} \font\smalleri=cmmi8 \font\smallersy=cmsy8 \def\smallerecsize{0800} % Fonts for math mode superscripts (7pt). \def\sevennominalsize{7pt} \setfont\sevenrm\rmshape{7}{1000}{OT1} \setfont\seventt\ttshape{10}{700}{OT1TT} \setfont\sevenbf\bfshape{10}{700}{OT1} \setfont\sevenit\itshape{7}{1000}{OT1IT} \setfont\sevensl\slshape{10}{700}{OT1} \setfont\sevensf\sfshape{10}{700}{OT1} \setfont\sevensc\scshape{10}{700}{OT1} \setfont\seventtsl\ttslshape{10}{700}{OT1TT} \font\seveni=cmmi7 \font\sevensy=cmsy7 \def\sevenecsize{0700} % Fonts for title page (20.4pt): \def\titlenominalsize{20pt} \setfont\titlerm\rmbshape{12}{\magstep3}{OT1} \setfont\titleit\itbshape{10}{\magstep4}{OT1IT} \setfont\titlesl\slbshape{10}{\magstep4}{OT1} \setfont\titlett\ttbshape{12}{\magstep3}{OT1TT} \setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT} \setfont\titlesf\sfbshape{17}{\magstep1}{OT1} \let\titlebf=\titlerm \setfont\titlesc\scbshape{10}{\magstep4}{OT1} \font\titlei=cmmi12 scaled \magstep3 \font\titlesy=cmsy10 scaled \magstep4 \def\titleecsize{2074} % Chapter (and unnumbered) fonts (17.28pt). \def\chapnominalsize{17pt} \setfont\chaprm\rmbshape{12}{\magstep2}{OT1} \setfont\chapit\itbshape{10}{\magstep3}{OT1IT} \setfont\chapsl\slbshape{10}{\magstep3}{OT1} \setfont\chaptt\ttbshape{12}{\magstep2}{OT1TT} \setfont\chapttsl\ttslshape{10}{\magstep3}{OT1TT} \setfont\chapsf\sfbshape{17}{1000}{OT1} \let\chapbf=\chaprm \setfont\chapsc\scbshape{10}{\magstep3}{OT1} \font\chapi=cmmi12 scaled \magstep2 \font\chapsy=cmsy10 scaled \magstep3 \def\chapecsize{1728} % Section fonts (14.4pt). \def\secnominalsize{14pt} \setfont\secrm\rmbshape{12}{\magstep1}{OT1} \setfont\secrmnotbold\rmshape{12}{\magstep1}{OT1} \setfont\secit\itbshape{10}{\magstep2}{OT1IT} \setfont\secsl\slbshape{10}{\magstep2}{OT1} \setfont\sectt\ttbshape{12}{\magstep1}{OT1TT} \setfont\secttsl\ttslshape{10}{\magstep2}{OT1TT} \setfont\secsf\sfbshape{12}{\magstep1}{OT1} \let\secbf\secrm \setfont\secsc\scbshape{10}{\magstep2}{OT1} \font\seci=cmmi12 scaled \magstep1 \font\secsy=cmsy10 scaled \magstep2 \def\sececsize{1440} % Subsection fonts (13.15pt). \def\ssecnominalsize{13pt} \setfont\ssecrm\rmbshape{12}{\magstephalf}{OT1} \setfont\ssecit\itbshape{10}{1315}{OT1IT} \setfont\ssecsl\slbshape{10}{1315}{OT1} \setfont\ssectt\ttbshape{12}{\magstephalf}{OT1TT} \setfont\ssecttsl\ttslshape{10}{1315}{OT1TT} \setfont\ssecsf\sfbshape{12}{\magstephalf}{OT1} \let\ssecbf\ssecrm \setfont\ssecsc\scbshape{10}{1315}{OT1} \font\sseci=cmmi12 scaled \magstephalf \font\ssecsy=cmsy10 scaled 1315 \def\ssececsize{1200} % Reduced fonts for @acronym in text (10pt). \def\reducednominalsize{10pt} \setfont\reducedrm\rmshape{10}{1000}{OT1} \setfont\reducedtt\ttshape{10}{1000}{OT1TT} \setfont\reducedbf\bfshape{10}{1000}{OT1} \setfont\reducedit\itshape{10}{1000}{OT1IT} \setfont\reducedsl\slshape{10}{1000}{OT1} \setfont\reducedsf\sfshape{10}{1000}{OT1} \setfont\reducedsc\scshape{10}{1000}{OT1} \setfont\reducedttsl\ttslshape{10}{1000}{OT1TT} \font\reducedi=cmmi10 \font\reducedsy=cmsy10 \def\reducedecsize{1000} \textleading = 13.2pt % line spacing for 11pt CM \textfonts % reset the current fonts \rm } % end of 11pt text font size definitions, \definetextfontsizexi % Definitions to make the main text be 10pt Computer Modern, with % section, chapter, etc., sizes following suit. This is for the GNU % Press printing of the Emacs 22 manual. Maybe other manuals in the % future. Used with @smallbook, which sets the leading to 12pt. % \def\definetextfontsizex{% % Text fonts (10pt). \def\textnominalsize{10pt} \edef\mainmagstep{1000} \setfont\textrm\rmshape{10}{\mainmagstep}{OT1} \setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT} \setfont\textbf\bfshape{10}{\mainmagstep}{OT1} \setfont\textit\itshape{10}{\mainmagstep}{OT1IT} \setfont\textsl\slshape{10}{\mainmagstep}{OT1} \setfont\textsf\sfshape{10}{\mainmagstep}{OT1} \setfont\textsc\scshape{10}{\mainmagstep}{OT1} \setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT} \font\texti=cmmi10 scaled \mainmagstep \font\textsy=cmsy10 scaled \mainmagstep \def\textecsize{1000} % A few fonts for @defun names and args. \setfont\defbf\bfshape{10}{\magstephalf}{OT1} \setfont\deftt\ttshape{10}{\magstephalf}{OT1TT} \setfont\defsl\slshape{10}{\magstephalf}{OT1} \setfont\defttsl\ttslshape{10}{\magstephalf}{OT1TT} \def\df{\let\ttfont=\deftt \let\bffont = \defbf \let\slfont=\defsl \let\ttslfont=\defttsl \bf} % Fonts for indices, footnotes, small examples (9pt). \def\smallnominalsize{9pt} \setfont\smallrm\rmshape{9}{1000}{OT1} \setfont\smalltt\ttshape{9}{1000}{OT1TT} \setfont\smallbf\bfshape{10}{900}{OT1} \setfont\smallit\itshape{9}{1000}{OT1IT} \setfont\smallsl\slshape{9}{1000}{OT1} \setfont\smallsf\sfshape{9}{1000}{OT1} \setfont\smallsc\scshape{10}{900}{OT1} \setfont\smallttsl\ttslshape{10}{900}{OT1TT} \font\smalli=cmmi9 \font\smallsy=cmsy9 \def\smallecsize{0900} % Fonts for small examples (8pt). \def\smallernominalsize{8pt} \setfont\smallerrm\rmshape{8}{1000}{OT1} \setfont\smallertt\ttshape{8}{1000}{OT1TT} \setfont\smallerbf\bfshape{10}{800}{OT1} \setfont\smallerit\itshape{8}{1000}{OT1IT} \setfont\smallersl\slshape{8}{1000}{OT1} \setfont\smallersf\sfshape{8}{1000}{OT1} \setfont\smallersc\scshape{10}{800}{OT1} \setfont\smallerttsl\ttslshape{10}{800}{OT1TT} \font\smalleri=cmmi8 \font\smallersy=cmsy8 \def\smallerecsize{0800} % Fonts for math mode superscripts (7pt). \def\sevennominalsize{7pt} \setfont\sevenrm\rmshape{7}{1000}{OT1} \setfont\seventt\ttshape{10}{700}{OT1TT} \setfont\sevenbf\bfshape{10}{700}{OT1} \setfont\sevenit\itshape{7}{1000}{OT1IT} \setfont\sevensl\slshape{10}{700}{OT1} \setfont\sevensf\sfshape{10}{700}{OT1} \setfont\sevensc\scshape{10}{700}{OT1} \setfont\seventtsl\ttslshape{10}{700}{OT1TT} \font\seveni=cmmi7 \font\sevensy=cmsy7 \def\sevenecsize{0700} % Fonts for title page (20.4pt): \def\titlenominalsize{20pt} \setfont\titlerm\rmbshape{12}{\magstep3}{OT1} \setfont\titleit\itbshape{10}{\magstep4}{OT1IT} \setfont\titlesl\slbshape{10}{\magstep4}{OT1} \setfont\titlett\ttbshape{12}{\magstep3}{OT1TT} \setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT} \setfont\titlesf\sfbshape{17}{\magstep1}{OT1} \let\titlebf=\titlerm \setfont\titlesc\scbshape{10}{\magstep4}{OT1} \font\titlei=cmmi12 scaled \magstep3 \font\titlesy=cmsy10 scaled \magstep4 \def\titleecsize{2074} % Chapter fonts (14.4pt). \def\chapnominalsize{14pt} \setfont\chaprm\rmbshape{12}{\magstep1}{OT1} \setfont\chapit\itbshape{10}{\magstep2}{OT1IT} \setfont\chapsl\slbshape{10}{\magstep2}{OT1} \setfont\chaptt\ttbshape{12}{\magstep1}{OT1TT} \setfont\chapttsl\ttslshape{10}{\magstep2}{OT1TT} \setfont\chapsf\sfbshape{12}{\magstep1}{OT1} \let\chapbf\chaprm \setfont\chapsc\scbshape{10}{\magstep2}{OT1} \font\chapi=cmmi12 scaled \magstep1 \font\chapsy=cmsy10 scaled \magstep2 \def\chapecsize{1440} % Section fonts (12pt). \def\secnominalsize{12pt} \setfont\secrm\rmbshape{12}{1000}{OT1} \setfont\secit\itbshape{10}{\magstep1}{OT1IT} \setfont\secsl\slbshape{10}{\magstep1}{OT1} \setfont\sectt\ttbshape{12}{1000}{OT1TT} \setfont\secttsl\ttslshape{10}{\magstep1}{OT1TT} \setfont\secsf\sfbshape{12}{1000}{OT1} \let\secbf\secrm \setfont\secsc\scbshape{10}{\magstep1}{OT1} \font\seci=cmmi12 \font\secsy=cmsy10 scaled \magstep1 \def\sececsize{1200} % Subsection fonts (10pt). \def\ssecnominalsize{10pt} \setfont\ssecrm\rmbshape{10}{1000}{OT1} \setfont\ssecit\itbshape{10}{1000}{OT1IT} \setfont\ssecsl\slbshape{10}{1000}{OT1} \setfont\ssectt\ttbshape{10}{1000}{OT1TT} \setfont\ssecttsl\ttslshape{10}{1000}{OT1TT} \setfont\ssecsf\sfbshape{10}{1000}{OT1} \let\ssecbf\ssecrm \setfont\ssecsc\scbshape{10}{1000}{OT1} \font\sseci=cmmi10 \font\ssecsy=cmsy10 \def\ssececsize{1000} % Reduced fonts for @acronym in text (9pt). \def\reducednominalsize{9pt} \setfont\reducedrm\rmshape{9}{1000}{OT1} \setfont\reducedtt\ttshape{9}{1000}{OT1TT} \setfont\reducedbf\bfshape{10}{900}{OT1} \setfont\reducedit\itshape{9}{1000}{OT1IT} \setfont\reducedsl\slshape{9}{1000}{OT1} \setfont\reducedsf\sfshape{9}{1000}{OT1} \setfont\reducedsc\scshape{10}{900}{OT1} \setfont\reducedttsl\ttslshape{10}{900}{OT1TT} \font\reducedi=cmmi9 \font\reducedsy=cmsy9 \def\reducedecsize{0900} \divide\parskip by 2 % reduce space between paragraphs \textleading = 12pt % line spacing for 10pt CM \textfonts % reset the current fonts \rm } % end of 10pt text font size definitions, \definetextfontsizex % Fonts for short table of contents. \setfont\shortcontrm\rmshape{12}{1000}{OT1} \setfont\shortcontbf\bfshape{10}{\magstep1}{OT1} % no cmb12 \setfont\shortcontsl\slshape{12}{1000}{OT1} \setfont\shortconttt\ttshape{12}{1000}{OT1TT} % We provide the user-level command % @fonttextsize 10 % (or 11) to redefine the text font size. pt is assumed. % \def\xiword{11} \def\xword{10} \def\xwordpt{10pt} % \parseargdef\fonttextsize{% \def\textsizearg{#1}% %\wlog{doing @fonttextsize \textsizearg}% % % Set \globaldefs so that documents can use this inside @tex, since % makeinfo 4.8 does not support it, but we need it nonetheless. % \begingroup \globaldefs=1 \ifx\textsizearg\xword \definetextfontsizex \else \ifx\textsizearg\xiword \definetextfontsizexi \else \errhelp=\EMsimple \errmessage{@fonttextsize only supports `10' or `11', not `\textsizearg'} \fi\fi \endgroup } % % Change the current font style to #1, remembering it in \curfontstyle. % For now, we do not accumulate font styles: @b{@i{foo}} prints foo in % italics, not bold italics. % \def\setfontstyle#1{% \def\curfontstyle{#1}% not as a control sequence, because we are \edef'd. \csname #1font\endcsname % change the current font } \def\rm{\fam=0 \setfontstyle{rm}} \def\it{\fam=\itfam \setfontstyle{it}} \def\sl{\fam=\slfam \setfontstyle{sl}} \def\bf{\fam=\bffam \setfontstyle{bf}}\def\bfstylename{bf} \def\tt{\fam=\ttfam \setfontstyle{tt}} % Texinfo sort of supports the sans serif font style, which plain TeX does not. % So we set up a \sf. \newfam\sffam \def\sf{\fam=\sffam \setfontstyle{sf}} % We don't need math for this font style. \def\ttsl{\setfontstyle{ttsl}} % In order for the font changes to affect most math symbols and letters, % we have to define the \textfont of the standard families. % We don't bother to reset \scriptscriptfont; awaiting user need. % \def\resetmathfonts{% \textfont0=\rmfont \textfont1=\ifont \textfont2=\syfont \textfont\itfam=\itfont \textfont\slfam=\slfont \textfont\bffam=\bffont \textfont\ttfam=\ttfont \textfont\sffam=\sffont % % Fonts for superscript. Note that the 7pt fonts are used regardless % of the current font size. \scriptfont0=\sevenrm \scriptfont1=\seveni \scriptfont2=\sevensy \scriptfont\itfam=\sevenit \scriptfont\slfam=\sevensl \scriptfont\bffam=\sevenbf \scriptfont\ttfam=\seventt \scriptfont\sffam=\sevensf } % \defineassignfonts{SIZE} - % Define sequence \assignfontsSIZE, which switches between font sizes % by redefining the meanings of \STYLEfont. (Just \STYLE additionally sets % the current \fam for math mode.) % \def\defineassignfonts#1{% \expandafter\edef\csname assignfonts#1\endcsname{% \let\noexpand\rmfont\csname #1rm\endcsname \let\noexpand\itfont\csname #1it\endcsname \let\noexpand\slfont\csname #1sl\endcsname \let\noexpand\bffont\csname #1bf\endcsname \let\noexpand\ttfont\csname #1tt\endcsname \let\noexpand\smallcaps\csname #1sc\endcsname \let\noexpand\sffont \csname #1sf\endcsname \let\noexpand\ifont \csname #1i\endcsname \let\noexpand\syfont \csname #1sy\endcsname \let\noexpand\ttslfont\csname #1ttsl\endcsname } } \def\assignfonts#1{% \csname assignfonts#1\endcsname } \newif\ifrmisbold % Select smaller font size with the current style. Used to change font size % in, e.g., the LaTeX logo and acronyms. If we are using bold fonts for % normal roman text, also use bold fonts for roman text in the smaller size. \def\switchtolllsize{% \expandafter\assignfonts\expandafter{\lllsize}% \ifrmisbold \let\rmfont\bffont \fi \csname\curfontstyle\endcsname }% \def\switchtolsize{% \expandafter\assignfonts\expandafter{\lsize}% \ifrmisbold \let\rmfont\bffont \fi \csname\curfontstyle\endcsname }% % Define the font-changing commands (all called \...fonts). % Each font-changing command also sets the names \lsize (one size lower) % and \lllsize (three sizes lower). These relative commands are used % in, e.g., the LaTeX logo and acronyms. % % Note: The fonts used for \ifont are for "math italics" (\itfont is for % italics in regular text). \syfont is also used in math mode only. % \def\definefontsetatsize#1#2#3#4#5{% \defineassignfonts{#1}% \expandafter\def\csname #1fonts\endcsname{% \def\curfontsize{#1}% \def\lsize{#2}\def\lllsize{#3}% \csname rmisbold#5\endcsname \csname assignfonts#1\endcsname \resetmathfonts \setleading{#4}% }} \definefontsetatsize{text} {reduced}{smaller}{\textleading}{false} \definefontsetatsize{title} {chap} {subsec} {27pt} {true} \definefontsetatsize{chap} {sec} {text} {19pt} {true} \definefontsetatsize{sec} {subsec} {reduced}{17pt} {true} \definefontsetatsize{ssec} {text} {small} {15pt} {true} \definefontsetatsize{reduced}{small} {smaller}{10.5pt}{false} \definefontsetatsize{small} {smaller}{smaller}{10.5pt}{false} \definefontsetatsize{smaller}{smaller}{smaller}{9.5pt} {false} \def\titlefont#1{{\titlefonts\rm #1}} \let\subsecfonts = \ssecfonts \let\subsubsecfonts = \ssecfonts % Define these just so they can be easily changed for other fonts. \def\angleleft{$\langle$} \def\angleright{$\rangle$} % Set the fonts to use with the @small... environments. \let\smallexamplefonts = \smallfonts % About \smallexamplefonts. If we use \smallfonts (9pt), @smallexample % can fit this many characters: % 8.5x11=86 smallbook=72 a4=90 a5=69 % If we use \scriptfonts (8pt), then we can fit this many characters: % 8.5x11=90+ smallbook=80 a4=90+ a5=77 % For me, subjectively, the few extra characters that fit aren't worth % the additional smallness of 8pt. So I'm making the default 9pt. % % By the way, for comparison, here's what fits with @example (10pt): % 8.5x11=71 smallbook=60 a4=75 a5=58 % --karl, 24jan03. % Set up the default fonts, so we can use them for creating boxes. % \definetextfontsizexi % Check if we are currently using a typewriter font. Since all the % Computer Modern typewriter fonts have zero interword stretch (and % shrink), and it is reasonable to expect all typewriter fonts to have % this property, we can check that font parameter. #1 is what to % print if we are indeed using \tt; #2 is what to print otherwise. \def\ifusingtt#1#2{\ifdim \fontdimen3\font=0pt #1\else #2\fi} % Same as above, but check for italic font. Actually this also catches % non-italic slanted fonts since it is impossible to distinguish them from % italic fonts. But since this is only used by $ and it uses \sl anyway % this is not a problem. \def\ifusingit#1#2{\ifdim \fontdimen1\font>0pt #1\else #2\fi} % Check if internal flag is clear, i.e. has not been @set. \def\ifflagclear#1#2#3{% \expandafter\ifx\csname SET#1\endcsname\relax #2\else#3\fi } { \catcode`\'=\active \catcode`\`=\active \gdef\setcodequotes{\let`\codequoteleft \let'\codequoteright} \gdef\setregularquotes{\let`\lq \let'\rq} } \setregularquotes % output for ' in @code % in tt font hex 0D (undirected) or 27 (curly right quote) % \def\codequoteright{% \ifusingtt {\ifflagclear{txicodequoteundirected}% {\ifflagclear{codequoteundirected}% {'}% {\char"0D }}% {\char"0D }}% {'}% } % output for ` in @code % in tt font hex 12 (grave accent) or 60 (curly left quote) % \relax disables Spanish ligatures ?` and !` of \tt font. % \def\codequoteleft{% \ifusingtt {\ifflagclear{txicodequotebacktick}% {\ifflagclear{codequotebacktick}% {\relax`}% {\char"12 }}% {\char"12 }}% {\relax`}% } % Commands to set the quote options. % \parseargdef\codequoteundirected{% \def\temp{#1}% \ifx\temp\onword \expandafter\let\csname SETtxicodequoteundirected\endcsname = t% \else\ifx\temp\offword \expandafter\let\csname SETtxicodequoteundirected\endcsname = \relax \else \errhelp = \EMsimple \errmessage{Unknown @codequoteundirected value `\temp', must be on|off}% \fi\fi } \parseargdef\codequotebacktick{% \def\temp{#1}% \ifx\temp\onword \expandafter\let\csname SETtxicodequotebacktick\endcsname = t% \else\ifx\temp\offword \expandafter\let\csname SETtxicodequotebacktick\endcsname = \relax \else \errhelp = \EMsimple \errmessage{Unknown @codequotebacktick value `\temp', must be on|off}% \fi\fi } % Turn them on by default \let\SETtxicodequoteundirected = t \let\SETtxicodequotebacktick = t % [Knuth] pp. 380,381,391, disable Spanish ligatures ?` and !` of \tt font. \def\noligaturesquoteleft{\relax\lq} % Count depth in font-changes, for error checks \newcount\fontdepth \fontdepth=0 % Font commands. % #1 is the font command (\sl or \it), #2 is the text to slant. % If we are in a monospaced environment, however, 1) always use \ttsl, % and 2) do not add an italic correction. \def\dosmartslant#1#2{% \ifusingtt {{\ttsl #2}\let\next=\relax}% {\def\next{{#1#2}\smartitaliccorrection}}% \next } \def\smartslanted{\dosmartslant\sl} \def\smartitalic{\dosmartslant\it} % Output an italic correction unless the following character is such as % not to need one. \def\smartitaliccorrection{\futurelet\next\smartitaliccorrectionx} \def\smartitaliccorrectionx{% \ifx\next,% \else\ifx\next-% \else\ifx\next.% \else\ifx\next\.% \else\ifx\next\comma% \else\ptexslash \fi\fi\fi\fi\fi \aftersmartic } % @cite unconditionally uses \sl with \smartitaliccorrection. \def\cite#1{{\sl #1}\smartitaliccorrection} % @var unconditionally uses \sl. This gives consistency for % parameter names whether they are in @def, @table @code or a % regular paragraph. % To get ttsl font for @var when used in code context, @set txicodevaristt. % The \null is to reset \spacefactor. \def\aftersmartic{} \def\var#1{% \let\saveaftersmartic = \aftersmartic \def\aftersmartic{\null\let\aftersmartic=\saveaftersmartic}% % \ifflagclear{txicodevaristt}% {\def\varnext{{{\sl #1}}\smartitaliccorrection}}% {\def\varnext{\smartslanted{#1}}}% \varnext } % To be removed after next release \def\SETtxicodevaristt{}% @set txicodevaristt \let\i=\smartitalic \let\slanted=\smartslanted \let\dfn=\smartslanted \let\emph=\smartitalic % @r for roman font, used for code comment \def\r#1{{% \usenormaldash % get --, --- ligatures even if in @code \defcharsdefault % in case on def line \rm #1}} {\catcode`-=\active \gdef\usenormaldash{\let-\normaldash}} % @sc, undocumented @ii. \def\sc#1{{\smallcaps#1}} % smallcaps font \def\ii#1{{\it #1}} % italic font % @b, explicit bold. Also @strong. \def\b#1{{\bf #1}} \let\strong=\b % @sansserif, explicit sans. \def\sansserif#1{{\sf #1}} \newif\iffrenchspacing \frenchspacingfalse % Set sfcode to normal for the chars that usually have another value. % Can't use plain's \frenchspacing because it uses the `\x notation, and % sometimes \x has an active definition that messes things up. % \catcode`@=11 \def\plainfrenchspacing{% \iffrenchspacing\else \frenchspacingtrue \sfcode`\.=\@m \sfcode`\?=\@m \sfcode`\!=\@m \sfcode`\:=\@m \sfcode`\;=\@m \sfcode`\,=\@m \def\endofsentencespacefactor{1000}% for @. and friends \fi } \def\plainnonfrenchspacing{% \iffrenchspacing \frenchspacingfalse \sfcode`\.3000\sfcode`\?3000\sfcode`\!3000 \sfcode`\:2000\sfcode`\;1500\sfcode`\,1250 \def\endofsentencespacefactor{3000}% for @. and friends \fi } \catcode`@=\other \def\endofsentencespacefactor{3000}% default % @frenchspacing on|off says whether to put extra space after punctuation. % \def\onword{on} \def\offword{off} % \let\frenchspacingsetting\plainnonfrenchspacing % used in output routine \parseargdef\frenchspacing{% \def\temp{#1}% \ifx\temp\onword \let\frenchspacingsetting\plainfrenchspacing \else\ifx\temp\offword \let\frenchspacingsetting\plainnonfrenchspacing \else \errhelp = \EMsimple \errmessage{Unknown @frenchspacing option `\temp', must be on|off}% \fi\fi \frenchspacingsetting } % @t, explicit typewriter. \def\t#1{% {\tt \defcharsdefault \plainfrenchspacing #1}% \null } % @samp. \def\samp#1{{\setcodequotes\lq\tclose{#1}\rq\null}} % @indicateurl is \samp, that is, with quotes. \let\indicateurl=\samp % @code (and similar) prints in typewriter, but with spaces the same % size as normal in the surrounding text, without hyphenation, etc. % This is a subroutine for that. \def\tclose#1{% {% % Change normal interword space to be same as for the current font. \spaceskip = \fontdimen2\font % % Switch to typewriter. \tt % % `\ ' produces the large typewriter interword space. \def\ {{\spaceskip = 0pt{} }}% % \plainfrenchspacing #1% }% \null % reset spacefactor to 1000 } % This is for LuaTeX: It is not sufficient to disable hyphenation at % explicit dashes by setting `\hyphenchar` to -1. \def\dashnobreak{% \normaldash \penalty 10000 } % We must turn on hyphenation at `-' and `_' in @code. % Otherwise, it is too hard to avoid overfull hboxes % in the Emacs manual, the Library manual, etc. % We explicitly allow hyphenation at these characters % using \discretionary. % % Hyphenation at - and hyphenation within words was turned off % by default for the tt fonts using the \hyphenchar parameter of TeX. { \catcode`\-=\active \catcode`\_=\active \catcode`\'=\active \catcode`\`=\active \global\let'=\rq \global\let`=\lq % default definitions % \global\def\code{\begingroup \setcodequotes \catcode\dashChar=\active \catcode\underChar=\active \ifallowcodebreaks \let-\codedash \let_\codeunder \else \let-\dashnobreak \let_\realunder \fi \codex } % \gdef\codedash{\futurelet\next\codedashfinish} \gdef\codedashfinish{% \normaldash % always output the dash character itself. % % Now, output a discretionary to allow a line break, unless % (a) the next character is a -, or % (b) the preceding character is a -, or % (c) we are at the start of the string. % In both cases (b) and (c), \codedashnobreak should be set to \codedash. % % E.g., given --posix, we do not want to allow a break after either -. % Given --foo-bar, we do want to allow a break between the - and the b. \ifx\next\codedash \else \ifx\codedashnobreak\codedash \else \discretionary{}{}{}\fi \fi % we need the space after the = for the case when \next itself is a % space token; it would get swallowed otherwise. As in @code{- a}. \global\let\codedashnobreak= \next } } \def\normaldash{-} % \def\codex #1{\tclose{% % Given -foo (with a single dash), we do not want to allow a break % after the -. \codedashnobreak is set to the first character in % @code. \futurelet\codedashnobreak\relax #1% }\endgroup} \def\codeunder{% % this is all so @math{@code{var_name}+1} can work. In math mode, _ % is "active" (mathcode"8000) and \normalunderscore (or \char95, etc.) % will therefore expand the active definition of _, which is us % (inside @code that is), therefore an endless loop. \ifusingtt{\ifmmode \mathchar"075F % class 0=ordinary, family 7=ttfam, pos 0x5F=_. \else\normalunderscore \fi \discretionary{}{}{}}% {\_}% } % An additional complication: the above will allow breaks after, e.g., % each of the four underscores in __typeof__. This is bad. % @allowcodebreaks provides a document-level way to turn breaking at - % and _ on and off. % \newif\ifallowcodebreaks \allowcodebreakstrue \def\keywordtrue{true} \def\keywordfalse{false} \parseargdef\allowcodebreaks{% \def\txiarg{#1}% \ifx\txiarg\keywordtrue \allowcodebreakstrue \else\ifx\txiarg\keywordfalse \allowcodebreaksfalse \else \errhelp = \EMsimple \errmessage{Unknown @allowcodebreaks option `\txiarg', must be true|false}% \fi\fi } % For @command, @env, @file, @option quotes seem unnecessary, % so use \code rather than \samp. \let\command=\code \let\env=\code \let\file=\code \let\option=\code % @uref (abbreviation for `urlref') aka @url takes an optional % (comma-separated) second argument specifying the text to display and % an optional third arg as text to display instead of (rather than in % addition to) the url itself. First (mandatory) arg is the url. % TeX-only option to allow changing PDF output to show only the second % arg (if given), and not the url (which is then just the link target). \newif\ifurefurlonlylink % The default \pretolerance setting stops the penalty inserted in % \urefallowbreak being a discouragement to line breaking. Set it to % a negative value for this paragraph only. Hopefully this does not % conflict with redefinitions of \par done elsewhere. \def\nopretolerance{% \pretolerance=-1 \def\par{\endgraf\pretolerance=100 \let\par\endgraf}% } % The main macro is \urefbreak, which allows breaking at expected % places within the url. \def\urefbreak{\nopretolerance \begingroup \urefcatcodes \dourefbreak} \let\uref=\urefbreak % \def\dourefbreak#1{\urefbreakfinish #1,,,\finish} \def\urefbreakfinish#1,#2,#3,#4\finish{% doesn't work in @example \unsepspaces \pdfurl{#1}% \setbox0 = \hbox{\ignorespaces #3}% \ifdim\wd0 > 0pt \unhbox0 % third arg given, show only that \else \setbox0 = \hbox{\ignorespaces #2}% look for second arg \ifdim\wd0 > 0pt \ifpdf % For pdfTeX and LuaTeX \ifurefurlonlylink % PDF plus option to not display url, show just arg \unhbox0 \else % PDF, normally display both arg and url for consistency, % visibility, if the pdf is eventually used to print, etc. \unhbox0\ (\urefcode{#1})% \fi \else \ifx\XeTeXrevision\thisisundefined \unhbox0\ (\urefcode{#1})% DVI, always show arg and url \else % For XeTeX \ifurefurlonlylink % PDF plus option to not display url, show just arg \unhbox0 \else % PDF, normally display both arg and url for consistency, % visibility, if the pdf is eventually used to print, etc. \unhbox0\ (\urefcode{#1})% \fi \fi \fi \else \urefcode{#1}% only url given, so show it \fi \fi \endlink \endgroup} % Allow line breaks around only a few characters (only). \def\urefcatcodes{% \catcode`\&=\active \catcode`\.=\active \catcode`\#=\active \catcode`\?=\active \catcode`\/=\active } { \urefcatcodes % \global\def\urefcode{\begingroup \setcodequotes \urefcatcodes \let&\urefcodeamp \let.\urefcodedot \let#\urefcodehash \let?\urefcodequest \let/\urefcodeslash \codex } % % By default, they are just regular characters. \global\def&{\normalamp} \global\def.{\normaldot} \global\def#{\normalhash} \global\def?{\normalquest} \global\def/{\normalslash} } \def\urefcodeamp{\urefprebreak \&\urefpostbreak} \def\urefcodedot{\urefprebreak .\urefpostbreak} \def\urefcodehash{\urefprebreak \#\urefpostbreak} \def\urefcodequest{\urefprebreak ?\urefpostbreak} \def\urefcodeslash{\futurelet\next\urefcodeslashfinish} { \catcode`\/=\active \global\def\urefcodeslashfinish{% \urefprebreak \slashChar % Allow line break only after the final / in a sequence of % slashes, to avoid line break between the slashes in http://. \ifx\next/\else \urefpostbreak \fi } } % By default we'll break after the special characters, but some people like to % break before the special chars, so allow that. Also allow no breaking at % all, for manual control. % \parseargdef\urefbreakstyle{% \def\txiarg{#1}% \ifx\txiarg\wordnone \def\urefprebreak{\nobreak}\def\urefpostbreak{\nobreak} \else\ifx\txiarg\wordbefore \def\urefprebreak{\urefallowbreak}\def\urefpostbreak{\nobreak} \else\ifx\txiarg\wordafter \def\urefprebreak{\nobreak}\def\urefpostbreak{\urefallowbreak} \else \errhelp = \EMsimple \errmessage{Unknown @urefbreakstyle setting `\txiarg'}% \fi\fi\fi } \def\wordafter{after} \def\wordbefore{before} \def\wordnone{none} % Allow a ragged right output to aid breaking long URL's. There can % be a break at the \allowbreak with no extra glue (if the existing stretch in % the line is sufficient), a break at the \penalty with extra glue added % at the end of the line, or no break at all here. % Changing the value of the penalty and/or the amount of stretch affects how % preferable one choice is over the other. \def\urefallowbreak{% \penalty0\relax \hskip 0pt plus 2 em\relax \penalty1000\relax \hskip 0pt plus -2 em\relax } \urefbreakstyle after % @url synonym for @uref, since that's how everyone uses it. % \let\url=\uref % rms does not like angle brackets --karl, 17may97. % So now @email is just like @uref, unless we are pdf. % %\def\email#1{\angleleft{\tt #1}\angleright} \ifpdforxetex \def\email#1{\doemail#1,,\finish} \def\doemail#1,#2,#3\finish{\begingroup \unsepspaces \pdfurl{mailto:#1}% \setbox0 = \hbox{\ignorespaces #2}% \ifdim\wd0>0pt\unhbox0\else\code{#1}\fi \endlink \endgroup} \else \let\email=\uref \fi % @kbdinputstyle -- arg is `distinct' (@kbd uses slanted tty font always), % `example' (@kbd uses ttsl only inside of @example and friends), % or `code' (@kbd uses normal tty font always). \parseargdef\kbdinputstyle{% \def\txiarg{#1}% \ifx\txiarg\worddistinct \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\ttsl}% \else\ifx\txiarg\wordexample \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\tt}% \else\ifx\txiarg\wordcode \gdef\kbdexamplefont{\tt}\gdef\kbdfont{\tt}% \else \errhelp = \EMsimple \errmessage{Unknown @kbdinputstyle setting `\txiarg'}% \fi\fi\fi } \def\worddistinct{distinct} \def\wordexample{example} \def\wordcode{code} % Default is `distinct'. \kbdinputstyle distinct \def\kbd#1{% \tclose{\kbdfont\setcodequotes#1}% } % definition of @key that produces a lozenge. Doesn't adjust to text size. %\setfont\keyrm\rmshape{8}{1000}{OT1} %\font\keysy=cmsy9 %\def\key#1{{\keyrm\textfont2=\keysy \leavevmode\hbox{% % \raise0.4pt\hbox{\angleleft}\kern-.08em\vtop{% % \vbox{\hrule\kern-0.4pt % \hbox{\raise0.4pt\hbox{\vphantom{\angleleft}}#1}}% % \kern-0.4pt\hrule}% % \kern-.06em\raise0.4pt\hbox{\angleright}}}} % definition of @key with no lozenge. % \def\key#1{{\setregularquotes \tt #1}\null} % @clicksequence{File @click{} Open ...} \def\clicksequence#1{\begingroup #1\endgroup} % @clickstyle @arrow (by default) \parseargdef\clickstyle{\def\click{#1}} \def\click{\arrow} % Typeset a dimension, e.g., `in' or `pt'. The only reason for the % argument is to make the input look right: @dmn{pt} instead of @dmn{}pt. % \def\dmn#1{\thinspace #1} % @acronym for "FBI", "NATO", and the like. % We print this one point size smaller, since it's intended for % all-uppercase. % \def\acronym#1{\doacronym #1,,\finish} \def\doacronym#1,#2,#3\finish{% {\switchtolsize #1}% \def\temp{#2}% \ifx\temp\empty \else \space ({\unsepspaces \ignorespaces \temp \unskip})% \fi \null % reset \spacefactor=1000 } % @abbr for "Comput. J." and the like. % No font change, but don't do end-of-sentence spacing. % \def\abbr#1{\doabbr #1,,\finish} \def\doabbr#1,#2,#3\finish{% {\plainfrenchspacing #1}% \def\temp{#2}% \ifx\temp\empty \else \space ({\unsepspaces \ignorespaces \temp \unskip})% \fi \null % reset \spacefactor=1000 } % @asis just yields its argument. Used with @table, for example. % \def\asis#1{#1} % @math outputs its argument in math mode. % % One complication: _ usually means subscripts, but it could also mean % an actual _ character, as in @math{@var{some_variable} + 1}. So make % _ active, and distinguish by seeing if the current family is \slfam, % which is what @var uses. { \catcode`\_ = \active \gdef\mathunderscore{% \catcode`\_=\active \def_{\ifnum\fam=\slfam \_\else\sb\fi}% } } % Another complication: we want \\ (and @\) to output a math (or tt) \. % FYI, plain.tex uses \\ as a temporary control sequence (for no % particular reason), but this is not advertised and we don't care. % % The \mathchar is class=0=ordinary, family=7=ttfam, position=5C=\. \def\mathbackslash{\ifnum\fam=\ttfam \mathchar"075C \else\backslash \fi} % \def\math{% \ifmmode\else % only go into math if not in math mode already \tex \mathunderscore \let\\ = \mathbackslash \mathactive % make the texinfo accent commands work in math mode \let\"=\ddot \let\'=\acute \let\==\bar \let\^=\hat \let\`=\grave \let\u=\breve \let\v=\check \let\~=\tilde \let\dotaccent=\dot % have to provide another name for sup operator \let\mathopsup=\sup $\expandafter\finishmath\fi } \def\finishmath#1{#1$\endgroup} % Close the group opened by \tex. % Some active characters (such as <) are spaced differently in math. % We have to reset their definitions in case the @math was an argument % to a command which sets the catcodes (such as @item or @section). % { \catcode`^ = \active \catcode`< = \active \catcode`> = \active \catcode`+ = \active \catcode`' = \active \gdef\mathactive{% \let^ = \ptexhat \let< = \ptexless \let> = \ptexgtr \let+ = \ptexplus \let' = \ptexquoteright } } % for @sub and @sup, if in math mode, just do a normal sub/superscript. % If in text, use math to place as sub/superscript, but switch % into text mode, with smaller fonts. This is a different font than the % one used for real math sub/superscripts (8pt vs. 7pt), but let's not % fix it (significant additions to font machinery) until someone notices. % \def\sub{\ifmmode \expandafter\sb \else \expandafter\finishsub\fi} \def\finishsub#1{$\sb{\hbox{\switchtolllsize #1}}$}% % \def\sup{\ifmmode \expandafter\ptexsp \else \expandafter\finishsup\fi} \def\finishsup#1{$\ptexsp{\hbox{\switchtolllsize #1}}$}% % provide this command from LaTeX as it is very common \def\frac#1#2{{{#1}\over{#2}}} % @displaymath. % \globaldefs is needed to recognize the end lines in \tex and % \end tex. Set \thisenv as @end displaymath is seen before @end tex. {\obeylines \globaldefs=1 \envdef\displaymath{% \tex% \def\thisenv{\displaymath}% \begingroup\let\end\displaymathend% $$% } \def\displaymathend{$$\endgroup\end}% \def\Edisplaymath{% \def\thisenv{\tex}% \end tex }} % @inlinefmt{FMTNAME,PROCESSED-TEXT} and @inlineraw{FMTNAME,RAW-TEXT}. % Ignore unless FMTNAME == tex; then it is like @iftex and @tex, % except specified as a normal braced arg, so no newlines to worry about. % \def\outfmtnametex{tex} % \long\def\inlinefmt#1{\doinlinefmt #1,\finish} \long\def\doinlinefmt#1,#2,\finish{% \def\inlinefmtname{#1}% \ifx\inlinefmtname\outfmtnametex \ignorespaces #2\fi } % % @inlinefmtifelse{FMTNAME,THEN-TEXT,ELSE-TEXT} expands THEN-TEXT if % FMTNAME is tex, else ELSE-TEXT. \long\def\inlinefmtifelse#1{\doinlinefmtifelse #1,,,\finish} \long\def\doinlinefmtifelse#1,#2,#3,#4,\finish{% \def\inlinefmtname{#1}% \ifx\inlinefmtname\outfmtnametex \ignorespaces #2\else \ignorespaces #3\fi } % % For raw, must switch into @tex before parsing the argument, to avoid % setting catcodes prematurely. Doing it this way means that, for % example, @inlineraw{html, foo{bar} gets a parse error instead of being % ignored. But this isn't important because if people want a literal % *right* brace they would have to use a command anyway, so they may as % well use a command to get a left brace too. We could re-use the % delimiter character idea from \verb, but it seems like overkill. % \long\def\inlineraw{\tex \doinlineraw} \long\def\doinlineraw#1{\doinlinerawtwo #1,\finish} \def\doinlinerawtwo#1,#2,\finish{% \def\inlinerawname{#1}% \ifx\inlinerawname\outfmtnametex \ignorespaces #2\fi \endgroup % close group opened by \tex. } % @inlineifset{VAR, TEXT} expands TEXT if VAR is @set. % \long\def\inlineifset#1{\doinlineifset #1,\finish} \long\def\doinlineifset#1,#2,\finish{% \def\inlinevarname{#1}% \expandafter\ifx\csname SET\inlinevarname\endcsname\relax \else\ignorespaces#2\fi } % @inlineifclear{VAR, TEXT} expands TEXT if VAR is not @set. % \long\def\inlineifclear#1{\doinlineifclear #1,\finish} \long\def\doinlineifclear#1,#2,\finish{% \def\inlinevarname{#1}% \expandafter\ifx\csname SET\inlinevarname\endcsname\relax \ignorespaces#2\fi } \message{glyphs,} % and logos. % @@ prints an @, as does @atchar{}. \def\@{\char64 } \let\atchar=\@ % @{ @} @lbracechar{} @rbracechar{} all generate brace characters. \def\lbracechar{{\ifusingtt{\char123}{\ensuremath\lbrace}}} \def\rbracechar{{\ifusingtt{\char125}{\ensuremath\rbrace}}} \let\{=\lbracechar \let\}=\rbracechar % @comma{} to avoid , parsing problems. \let\comma = , % Accents: @, @dotaccent @ringaccent @ubaraccent @udotaccent % Others are defined by plain TeX: @` @' @" @^ @~ @= @u @v @H. \let\, = \ptexc \let\dotaccent = \ptexdot \def\ringaccent#1{{\accent23 #1}} \let\tieaccent = \ptext \let\ubaraccent = \ptexb \let\udotaccent = \d % Other special characters: @questiondown @exclamdown @ordf @ordm % Plain TeX defines: @AA @AE @O @OE @L (plus lowercase versions) @ss. \def\questiondown{?`} \def\exclamdown{!`} \def\ordf{\leavevmode\raise1ex\hbox{\switchtolllsize \underbar{a}}} \def\ordm{\leavevmode\raise1ex\hbox{\switchtolllsize \underbar{o}}} % Dotless i and dotless j, used for accents. \def\imacro{i} \def\jmacro{j} \def\dotless#1{% \def\temp{#1}% \ifx\temp\imacro \ifmmode\imath \else\ptexi \fi \else\ifx\temp\jmacro \ifmmode\jmath \else\j \fi \else \errmessage{@dotless can be used only with i or j}% \fi\fi } % The \TeX{} logo, as in plain, but resetting the spacing so that a % period following counts as ending a sentence. (Idea found in latex.) % \edef\TeX{\TeX \spacefactor=1000 } % @LaTeX{} logo. Not quite the same results as the definition in % latex.ltx, since we use a different font for the raised A; it's most % convenient for us to use an explicitly smaller font, rather than using % the \scriptstyle font (since we don't reset \scriptstyle and % \scriptscriptstyle). % \def\LaTeX{% L\kern-.36em {\setbox0=\hbox{T}% \vbox to \ht0{\hbox{% \ifx\textnominalsize\xwordpt % for 10pt running text, lllsize (8pt) is too small for the A in LaTeX. % Revert to plain's \scriptsize, which is 7pt. \count255=\the\fam $\fam\count255 \scriptstyle A$% \else \ifx\curfontsize\smallword % For footnotes and indices \count255=\the\fam $\fam\count255 \scriptstyle A$% \else % For 11pt, we can use our lllsize. \switchtolllsize A% \fi \fi }% \vss }}% \kern-.15em \TeX } \def\smallword{small} % Some math mode symbols. Define \ensuremath to switch into math mode % unless we are already there. Expansion tricks may not be needed here, % but safer, and can't hurt. \def\ensuremath{\ifmmode \expandafter\asis \else\expandafter\ensuredmath \fi} \def\ensuredmath#1{$\relax#1$} % \def\bullet{\ensuremath\ptexbullet} \def\geq{\ensuremath\ge} \def\leq{\ensuremath\le} \def\minus{\ensuremath-} % @dots{} outputs an ellipsis using the current font. % We do .5em per period so that it has the same spacing in the cm % typewriter fonts as three actual period characters; on the other hand, % in other typewriter fonts three periods are wider than 1.5em. So do % whichever is larger. % \def\dots{% \leavevmode \setbox0=\hbox{...}% get width of three periods \ifdim\wd0 > 1.5em \dimen0 = \wd0 \else \dimen0 = 1.5em \fi \hbox to \dimen0{% \hskip 0pt plus.25fil .\hskip 0pt plus1fil .\hskip 0pt plus1fil .\hskip 0pt plus.5fil }% } % @enddots{} is an end-of-sentence ellipsis. % \def\enddots{% \dots \spacefactor=\endofsentencespacefactor } % @point{}, @result{}, @expansion{}, @print{}, @equiv{}. % % Since these characters are used in examples, they should be an even number of % \tt widths. Each \tt character is 1en, so two makes it 1em. % \def\point{$\star$} \def\arrow{\leavevmode\raise.05ex\hbox to 1em{\hfil$\rightarrow$\hfil}} \def\result{\leavevmode\raise.05ex\hbox to 1em{\hfil$\Rightarrow$\hfil}} \def\expansion{\leavevmode\hbox to 1em{\hfil$\mapsto$\hfil}} \def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}} \def\equiv{\leavevmode\hbox to 1em{\hfil$\ptexequiv$\hfil}} % The @error{} command. % Adapted from the TeXbook's \boxit. % \newbox\errorbox % {\ttfont \global\dimen0 = 3em}% Width of the box. \dimen2 = .55pt % Thickness of rules % The text. (`r' is open on the right, `e' somewhat less so on the left.) \setbox0 = \hbox{\kern-.75pt \reducedsf \putworderror\kern-1.5pt} % \setbox\errorbox=\hbox to \dimen0{\hfil \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right. \advance\hsize by -2\dimen2 % Rules. \vbox{% \hrule height\dimen2 \hbox{\vrule width\dimen2 \kern3pt % Space to left of text. \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below. \kern3pt\vrule width\dimen2}% Space to right. \hrule height\dimen2} \hfil} % \def\error{\leavevmode\lower.7ex\copy\errorbox} % @pounds{} is a sterling sign, which Knuth put in the CM italic font. % \def\pounds{{\ifusingtt{\ecfont\char"BF}{\it\$}}} % @euro{} comes from a separate font, depending on the current style. % We use the free feym* fonts from the eurosym package by Henrik % Theiling, which support regular, slanted, bold and bold slanted (and % "outlined" (blackboard board, sort of) versions, which we don't need). % It is available from http://www.ctan.org/tex-archive/fonts/eurosym. % % Although only regular is the truly official Euro symbol, we ignore % that. The Euro is designed to be slightly taller than the regular % font height. % % feymr - regular % feymo - slanted % feybr - bold % feybo - bold slanted % % There is no good (free) typewriter version, to my knowledge. % A feymr10 euro is ~7.3pt wide, while a normal cmtt10 char is ~5.25pt wide. % Hmm. % % Also doesn't work in math. Do we need to do math with euro symbols? % Hope not. % % \def\euro{{\eurofont e}} \def\eurofont{% % We set the font at each command, rather than predefining it in % \textfonts and the other font-switching commands, so that % installations which never need the symbol don't have to have the % font installed. % % There is only one designed size (nominal 10pt), so we always scale % that to the current nominal size. % % By the way, simply using "at 1em" works for cmr10 and the like, but % does not work for cmbx10 and other extended/shrunken fonts. % \def\eurosize{\csname\curfontsize nominalsize\endcsname}% % \ifx\curfontstyle\bfstylename % bold: \font\thiseurofont = \ifusingit{feybo10}{feybr10} at \eurosize \else % regular: \font\thiseurofont = \ifusingit{feymo10}{feymr10} at \eurosize \fi \thiseurofont } % Glyphs from the EC fonts. We don't use \let for the aliases, because % sometimes we redefine the original macro, and the alias should reflect % the redefinition. % % Use LaTeX names for the Icelandic letters. \def\DH{{\ecfont \char"D0}} % Eth \def\dh{{\ecfont \char"F0}} % eth \def\TH{{\ecfont \char"DE}} % Thorn \def\th{{\ecfont \char"FE}} % thorn % \def\guillemetleft{{\ecfont \char"13}} \def\guillemotleft{\guillemetleft} \def\guillemetright{{\ecfont \char"14}} \def\guillemotright{\guillemetright} \def\guilsinglleft{{\ecfont \char"0E}} \def\guilsinglright{{\ecfont \char"0F}} \def\quotedblbase{{\ecfont \char"12}} \def\quotesinglbase{{\ecfont \char"0D}} % \def\L{{\ecfont \char"8A}} % L with stroke \def\l{{\ecfont \char"AA}} % l with stroke % % This positioning is not perfect (see the ogonek LaTeX package), but % we have the precomposed glyphs for the most common cases. We put the % tests to use those glyphs in the single \ogonek macro so we have fewer % dummy definitions to worry about for index entries, etc. % % ogonek is also used with other letters in Lithuanian (IOU), but using % the precomposed glyphs for those is not so easy since they aren't in % the same EC font. \def\ogonek#1{{% \def\temp{#1}% \ifx\temp\macrocharA\Aogonek \else\ifx\temp\macrochara\aogonek \else\ifx\temp\macrocharE\Eogonek \else\ifx\temp\macrochare\eogonek \else \ecfont \setbox0=\hbox{#1}% \ifdim\ht0=1ex\accent"0C #1% \else\ooalign{\unhbox0\crcr\hidewidth\char"0C \hidewidth}% \fi \fi\fi\fi\fi }% } \def\Aogonek{{\ecfont \char"81}}\def\macrocharA{A} \def\aogonek{{\ecfont \char"A1}}\def\macrochara{a} \def\Eogonek{{\ecfont \char"86}}\def\macrocharE{E} \def\eogonek{{\ecfont \char"A6}}\def\macrochare{e} % % Use the European Computer Modern fonts (cm-super in outline format) % for non-CM glyphs. That is ec* for regular text and tc* for the text % companion symbols (LaTeX TS1 encoding). Both are part of the ec % package and follow the same conventions. % \def\ecfont{\etcfont{e}} \def\tcfont{\etcfont{t}} % \def\etcfont#1{% % We can't distinguish serif/sans and italic/slanted, but this % is used for crude hacks anyway (like adding French and German % quotes to documents typeset with CM, where we lose kerning), so % hopefully nobody will notice/care. \edef\ecsize{\csname\curfontsize ecsize\endcsname}% \edef\nominalsize{\csname\curfontsize nominalsize\endcsname}% \ifusingtt % typewriter: {\font\thisecfont = #1ctt\ecsize \space at \nominalsize}% % else {\ifx\curfontstyle\bfstylename % bold: \font\thisecfont = #1cb\ifusingit{i}{x}\ecsize \space at \nominalsize \else % regular: \font\thisecfont = #1c\ifusingit{ti}{rm}\ecsize \space at \nominalsize \fi}% \thisecfont } % @registeredsymbol - R in a circle. The font for the R should really % be smaller yet, but lllsize is the best we can do for now. % Adapted from the plain.tex definition of \copyright. % \def\registeredsymbol{% $^{{\ooalign{\hfil\raise.07ex\hbox{\switchtolllsize R}% \hfil\crcr\Orb}}% }$% } % @textdegree - the normal degrees sign. % \def\textdegree{% \ifmmode ^\circ \else {\tcfont \char 176}% \fi} % Laurent Siebenmann reports \Orb undefined with: % Textures 1.7.7 (preloaded format=plain 93.10.14) (68K) 16 APR 2004 02:38 % so we'll define it if necessary. % \ifx\Orb\thisisundefined \def\Orb{\mathhexbox20D} \fi % Quotes. \chardef\quoteleft=`\` \chardef\quoteright=`\' % only change font for tt for correct kerning and to avoid using % \ecfont unless necessary. \def\quotedblleft{% \ifusingtt{{\ecfont\char"10}}{{\char"5C}}% } \def\quotedblright{% \ifusingtt{{\ecfont\char"11}}{{\char`\"}}% } \message{page headings,} \newskip\titlepagetopglue \titlepagetopglue = 1.5in \newskip\titlepagebottomglue \titlepagebottomglue = 2pc % First the title page. Must do @settitle before @titlepage. \newif\ifseenauthor \newif\iffinishedtitlepage % @setcontentsaftertitlepage used to do an implicit @contents or % @shortcontents after @end titlepage, but it is now obsolete. \def\setcontentsaftertitlepage{% \errmessage{@setcontentsaftertitlepage has been removed as a Texinfo command; move your @contents command if you want the contents after the title page.}}% \def\setshortcontentsaftertitlepage{% \errmessage{@setshortcontentsaftertitlepage has been removed as a Texinfo command; move your @shortcontents and @contents commands if you want the contents after the title page.}}% \parseargdef\shorttitlepage{% {\headingsoff \begingroup \hbox{}\vskip 1.5in \chaprm \centerline{#1}% \endgroup\page\hbox{}\page}\pageone} \envdef\titlepage{% % Open one extra group, as we want to close it in the middle of \Etitlepage. \begingroup \parindent=0pt \textfonts \headingsoff % Leave some space at the very top of the page. \vglue\titlepagetopglue % No rule at page bottom unless we print one at the top with @title. \finishedtitlepagetrue % % Most title ``pages'' are actually two pages long, with space % at the top of the second. We don't want the ragged left on the second. \let\oldpage = \page \def\page{% \iffinishedtitlepage\else \finishtitlepage \fi \let\page = \oldpage \page \null }% } \def\Etitlepage{% \iffinishedtitlepage\else \finishtitlepage \fi % It is important to do the page break before ending the group, % because the headline and footline are only empty inside the group. % If we use the new definition of \page, we always get a blank page % after the title page, which we certainly don't want. \oldpage \pageone \endgroup % } \def\finishtitlepage{% \vskip4pt \hrule height 2pt width \hsize \vskip\titlepagebottomglue \finishedtitlepagetrue } % Settings used for typesetting titles: no hyphenation, no indentation, % don't worry much about spacing, ragged right. This should be used % inside a \vbox, and fonts need to be set appropriately first. \par should % be specified before the end of the \vbox, since a vbox is a group. % \def\raggedtitlesettings{% \rm \hyphenpenalty=10000 \parindent=0pt \tolerance=5000 \ptexraggedright } % Macros to be used within @titlepage: \let\subtitlerm=\rmfont \def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines} \parseargdef\title{% \checkenv\titlepage \vbox{\titlefonts \raggedtitlesettings #1\par}% % print a rule at the page bottom also. \finishedtitlepagefalse \vskip4pt \hrule height 4pt width \hsize \vskip4pt } \parseargdef\subtitle{% \checkenv\titlepage {\subtitlefont \rightline{#1}}% } % @author should come last, but may come many times. % It can also be used inside @quotation. % \parseargdef\author{% \def\temp{\quotation}% \ifx\thisenv\temp \def\quotationauthor{#1}% printed in \Equotation. \else \checkenv\titlepage \ifseenauthor\else \vskip 0pt plus 1filll \seenauthortrue \fi {\secfonts\rm \leftline{#1}}% \fi } % Set up page headings and footings. \let\thispage=\folio \newtoks\evenheadline % headline on even pages \newtoks\oddheadline % headline on odd pages \newtoks\evenchapheadline% headline on even pages with a new chapter \newtoks\oddchapheadline % headline on odd pages with a new chapter \newtoks\evenfootline % footline on even pages \newtoks\oddfootline % footline on odd pages % Now make \makeheadline and \makefootline in Plain TeX use those variables \headline={{\textfonts\rm\frenchspacingsetting \ifchapterpage \ifodd\pageno\the\oddchapheadline\else\the\evenchapheadline\fi \else \ifodd\pageno\the\oddheadline\else\the\evenheadline\fi \fi}} \footline={{\textfonts\rm\frenchspacingsetting \ifodd\pageno \the\oddfootline \else \the\evenfootline \fi}% \HEADINGShook} \let\HEADINGShook=\relax % Commands to set those variables. % For example, this is what @headings on does % @evenheading @thistitle|@thispage|@thischapter % @oddheading @thischapter|@thispage|@thistitle % @evenfooting @thisfile|| % @oddfooting ||@thisfile \def\evenheading{\parsearg\evenheadingxxx} \def\evenheadingxxx #1{\evenheadingyyy #1\|\|\|\|\finish} \def\evenheadingyyy #1\|#2\|#3\|#4\finish{% \global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}} \global\evenchapheadline=\evenheadline} \def\oddheading{\parsearg\oddheadingxxx} \def\oddheadingxxx #1{\oddheadingyyy #1\|\|\|\|\finish} \def\oddheadingyyy #1\|#2\|#3\|#4\finish{% \global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}% \global\oddchapheadline=\oddheadline} \parseargdef\everyheading{\oddheadingxxx{#1}\evenheadingxxx{#1}}% \def\evenfooting{\parsearg\evenfootingxxx} \def\evenfootingxxx #1{\evenfootingyyy #1\|\|\|\|\finish} \def\evenfootingyyy #1\|#2\|#3\|#4\finish{% \global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} \def\oddfooting{\parsearg\oddfootingxxx} \def\oddfootingxxx #1{\oddfootingyyy #1\|\|\|\|\finish} \def\oddfootingyyy #1\|#2\|#3\|#4\finish{% \global\oddfootline = {\rlap{\centerline{#2}}\line{#1\hfil#3}}% % % Leave some space for the footline. Hopefully ok to assume % @evenfooting will not be used by itself. \global\advance\txipageheight by -12pt \global\advance\vsize by -12pt } \parseargdef\everyfooting{\oddfootingxxx{#1}\evenfootingxxx{#1}} % @evenheadingmarks top \thischapter <- chapter at the top of a page % @evenheadingmarks bottom \thischapter <- chapter at the bottom of a page % % The same set of arguments for: % % @oddheadingmarks % @evenfootingmarks % @oddfootingmarks % @everyheadingmarks % @everyfootingmarks % These define \getoddheadingmarks, \getevenheadingmarks, % \getoddfootingmarks, and \getevenfootingmarks, each to one of % \gettopheadingmarks, \getbottomheadingmarks. % \def\evenheadingmarks{\headingmarks{even}{heading}} \def\oddheadingmarks{\headingmarks{odd}{heading}} \def\evenfootingmarks{\headingmarks{even}{footing}} \def\oddfootingmarks{\headingmarks{odd}{footing}} \parseargdef\everyheadingmarks{\headingmarks{even}{heading}{#1} \headingmarks{odd}{heading}{#1} } \parseargdef\everyfootingmarks{\headingmarks{even}{footing}{#1} \headingmarks{odd}{footing}{#1} } % #1 = even/odd, #2 = heading/footing, #3 = top/bottom. \def\headingmarks#1#2#3 {% \expandafter\let\expandafter\temp \csname get#3headingmarks\endcsname \global\expandafter\let\csname get#1#2marks\endcsname \temp } \everyheadingmarks bottom \everyfootingmarks bottom % @headings double turns headings on for double-sided printing. % @headings single turns headings on for single-sided printing. % @headings off turns them off. % @headings on same as @headings double, retained for compatibility. % @headings after turns on double-sided headings after this page. % @headings doubleafter turns on double-sided headings after this page. % @headings singleafter turns on single-sided headings after this page. % By default, they are off at the start of a document, % and turned `on' after @end titlepage. \parseargdef\headings{\csname HEADINGS#1\endcsname} \def\headingsoff{% non-global headings elimination \evenheadline={\hfil}\evenfootline={\hfil}\evenchapheadline={\hfil}% \oddheadline={\hfil}\oddfootline={\hfil}\oddchapheadline={\hfil}% } \def\HEADINGSoff{{\globaldefs=1 \headingsoff}} % global setting % Set the page number to 1. \def\pageone{ \global\pageno=1 \global\arabiccount = \pagecount } \let\contentsalignmacro = \chappager % \def\HEADINGSon{\HEADINGSdouble} % defined by \CHAPPAGon % For double-sided printing, put current file name in lower left corner, % chapter name on inside top of right hand pages, document % title on inside top of left hand pages, and page numbers on outside top % edge of all pages. \def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdouble} \let\HEADINGSdoubleafter=\HEADINGSafter \def\HEADINGSdouble{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\folio\hfil\thistitle}} \global\oddheadline={\line{\thischapter\hfil\folio}} \global\evenchapheadline={\line{\folio\hfil\thistitle}} \global\oddchapheadline={\line{\hfil\folio}} \global\let\contentsalignmacro = \chapoddpage } % For single-sided printing, chapter title goes across top left of page, % page number on top right. \def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsingle} \def\HEADINGSsingle{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\thischapter\hfil\folio}} \global\oddheadline={\line{\thischapter\hfil\folio}} \global\evenchapheadline={\line{\hfil\folio}} \global\oddchapheadline={\line{\hfil\folio}} \global\let\contentsalignmacro = \chappager } % for @setchapternewpage off \def\HEADINGSsinglechapoff{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\thischapter\hfil\folio}} \global\oddheadline={\line{\thischapter\hfil\folio}} \global\evenchapheadline=\evenheadline \global\oddchapheadline=\oddheadline \global\let\contentsalignmacro = \chappager } % Subroutines used in generating headings % This produces Day Month Year style of output. % Only define if not already defined, in case a txi-??.tex file has set % up a different format (e.g., txi-cs.tex does this). \ifx\today\thisisundefined \def\today{% \number\day\space \ifcase\month \or\putwordMJan\or\putwordMFeb\or\putwordMMar\or\putwordMApr \or\putwordMMay\or\putwordMJun\or\putwordMJul\or\putwordMAug \or\putwordMSep\or\putwordMOct\or\putwordMNov\or\putwordMDec \fi \space\number\year} \fi % @settitle line... specifies the title of the document, for headings. % It generates no output of its own. \def\thistitle{\putwordNoTitle} \def\settitle{\parsearg{\gdef\thistitle}} \message{tables,} % Tables -- @table, @ftable, @vtable, @item(x). % default indentation of table text \newdimen\tableindent \tableindent=.8in % default indentation of @itemize and @enumerate text \newdimen\itemindent \itemindent=.3in % margin between end of table item and start of table text. \newdimen\itemmargin \itemmargin=.1in % used internally for \itemindent minus \itemmargin \newdimen\itemmax % Note @table, @ftable, and @vtable define @item, @itemx, etc., with % these defs. % They also define \itemindex % to index the item name in whatever manner is desired (perhaps none). \newif\ifitemxneedsnegativevskip \def\itemxpar{\par\ifitemxneedsnegativevskip\nobreak\vskip-\parskip\nobreak\fi} \def\internalBitem{\smallbreak \parsearg\itemzzz} \def\internalBitemx{\itemxpar \parsearg\itemzzz} \def\itemzzz #1{\begingroup % \advance\hsize by -\rightskip \advance\hsize by -\tableindent \setbox0=\hbox{\itemindicate{#1}}% \itemindex{#1}% \nobreak % This prevents a break before @itemx. % % If the item text does not fit in the space we have, put it on a line % by itself, and do not allow a page break either before or after that % line. We do not start a paragraph here because then if the next % command is, e.g., @kindex, the whatsit would get put into the % horizontal list on a line by itself, resulting in extra blank space. \ifdim \wd0>\itemmax % % Make this a paragraph so we get the \parskip glue and wrapping, % but leave it ragged-right. \begingroup \advance\leftskip by-\tableindent \advance\hsize by\tableindent \advance\rightskip by0pt plus1fil\relax \leavevmode\unhbox0\par \endgroup % % We're going to be starting a paragraph, but we don't want the % \parskip glue -- logically it's part of the @item we just started. \nobreak \vskip-\parskip % % Stop a page break at the \parskip glue coming up. However, if % what follows is an environment such as @example, there will be no % \parskip glue; then the negative vskip we just inserted would % cause the example and the item to crash together. So we use this % bizarre value of 10001 as a signal to \aboveenvbreak to insert % \parskip glue after all. Section titles are handled this way also. % \penalty 10001 \endgroup \itemxneedsnegativevskipfalse \else % The item text fits into the space. Start a paragraph, so that the % following text (if any) will end up on the same line. \noindent % Do this with kerns and \unhbox so that if there is a footnote in % the item text, it can migrate to the main vertical list and % eventually be printed. \nobreak\kern-\tableindent \dimen0 = \itemmax \advance\dimen0 by \itemmargin \advance\dimen0 by -\wd0 \unhbox0 \nobreak\kern\dimen0 \endgroup \itemxneedsnegativevskiptrue \fi } \def\item{\errmessage{@item while not in a list environment}} \def\itemx{\errmessage{@itemx while not in a list environment}} % @table, @ftable, @vtable. \envdef\table{% \let\itemindex\gobble \tablecheck{table}% } \envdef\ftable{% \def\itemindex ##1{\doind {fn}{\code{##1}}}% \tablecheck{ftable}% } \envdef\vtable{% \def\itemindex ##1{\doind {vr}{\code{##1}}}% \tablecheck{vtable}% } \def\tablecheck#1{% \ifnum \the\catcode`\^^M=\active \endgroup \errmessage{This command won't work in this context; perhaps the problem is that we are \inenvironment\thisenv}% \def\next{\doignore{#1}}% \else \let\next\tablex \fi \next } \def\tablex#1{% \def\itemindicate{#1}% \parsearg\tabley } \def\tabley#1{% {% \makevalueexpandable \edef\temp{\noexpand\tablez #1\space\space\space}% \expandafter }\temp \endtablez } \def\tablez #1 #2 #3 #4\endtablez{% \aboveenvbreak \ifnum 0#1>0 \advance \leftskip by #1\mil \fi \ifnum 0#2>0 \tableindent=#2\mil \fi \ifnum 0#3>0 \advance \rightskip by #3\mil \fi \itemmax=\tableindent \advance \itemmax by -\itemmargin \advance \leftskip by \tableindent \exdentamount=\tableindent \parindent = 0pt \parskip = \smallskipamount \ifdim \parskip=0pt \parskip=2pt \fi \let\item = \internalBitem \let\itemx = \internalBitemx } \def\Etable{\endgraf\afterenvbreak} \let\Eftable\Etable \let\Evtable\Etable \let\Eitemize\Etable \let\Eenumerate\Etable % This is the counter used by @enumerate, which is really @itemize \newcount \itemno \envdef\itemize{\parsearg\doitemize} \def\doitemize#1{% \aboveenvbreak \itemmax=\itemindent \advance\itemmax by -\itemmargin \advance\leftskip by \itemindent \exdentamount=\itemindent \parindent=0pt \parskip=\smallskipamount \ifdim\parskip=0pt \parskip=2pt \fi % % Try typesetting the item mark so that if the document erroneously says % something like @itemize @samp (intending @table), there's an error % right away at the @itemize. It's not the best error message in the % world, but it's better than leaving it to the @item. This means if % the user wants an empty mark, they have to say @w{} not just @w. \def\itemcontents{#1}% \setbox0 = \hbox{\itemcontents}% % % @itemize with no arg is equivalent to @itemize @bullet. \ifx\itemcontents\empty\def\itemcontents{\bullet}\fi % \let\item=\itemizeitem } % Definition of @item while inside @itemize and @enumerate. % \def\itemizeitem{% \advance\itemno by 1 % for enumerations {\let\par=\endgraf \smallbreak}% reasonable place to break {% % If the document has an @itemize directly after a section title, a % \nobreak will be last on the list, and \sectionheading will have % done a \vskip-\parskip. In that case, we don't want to zero % parskip, or the item text will crash with the heading. On the % other hand, when there is normal text preceding the item (as there % usually is), we do want to zero parskip, or there would be too much % space. In that case, we won't have a \nobreak before. At least % that's the theory. \ifnum\lastpenalty<10000 \parskip=0in \fi \noindent \hbox to 0pt{\hss \itemcontents \kern\itemmargin}% % \ifinner\else \vadjust{\penalty 1200}% not good to break after first line of item. \fi % We can be in inner vertical mode in a footnote, although an % @itemize looks awful there. }% \flushcr } % \splitoff TOKENS\endmark defines \first to be the first token in % TOKENS, and \rest to be the remainder. % \def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}% % Allow an optional argument of an uppercase letter, lowercase letter, % or number, to specify the first label in the enumerated list. No % argument is the same as `1'. % \envparseargdef\enumerate{\enumeratey #1 \endenumeratey} \def\enumeratey #1 #2\endenumeratey{% % If we were given no argument, pretend we were given `1'. \def\thearg{#1}% \ifx\thearg\empty \def\thearg{1}\fi % % Detect if the argument is a single token. If so, it might be a % letter. Otherwise, the only valid thing it can be is a number. % (We will always have one token, because of the test we just made. % This is a good thing, since \splitoff doesn't work given nothing at % all -- the first parameter is undelimited.) \expandafter\splitoff\thearg\endmark \ifx\rest\empty % Only one token in the argument. It could still be anything. % A ``lowercase letter'' is one whose \lccode is nonzero. % An ``uppercase letter'' is one whose \lccode is both nonzero, and % not equal to itself. % Otherwise, we assume it's a number. % % We need the \relax at the end of the \ifnum lines to stop TeX from % continuing to look for a . % \ifnum\lccode\expandafter`\thearg=0\relax \numericenumerate % a number (we hope) \else % It's a letter. \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax \lowercaseenumerate % lowercase letter \else \uppercaseenumerate % uppercase letter \fi \fi \else % Multiple tokens in the argument. We hope it's a number. \numericenumerate \fi } % An @enumerate whose labels are integers. The starting integer is % given in \thearg. % \def\numericenumerate{% \itemno = \thearg \startenumeration{\the\itemno}% } % The starting (lowercase) letter is in \thearg. \def\lowercaseenumerate{% \itemno = \expandafter`\thearg \startenumeration{% % Be sure we're not beyond the end of the alphabet. \ifnum\itemno=0 \errmessage{No more lowercase letters in @enumerate; get a bigger alphabet}% \fi \char\lccode\itemno }% } % The starting (uppercase) letter is in \thearg. \def\uppercaseenumerate{% \itemno = \expandafter`\thearg \startenumeration{% % Be sure we're not beyond the end of the alphabet. \ifnum\itemno=0 \errmessage{No more uppercase letters in @enumerate; get a bigger alphabet} \fi \char\uccode\itemno }% } % Call \doitemize, adding a period to the first argument and supplying the % common last two arguments. Also subtract one from the initial value in % \itemno, since @item increments \itemno. % \def\startenumeration#1{% \advance\itemno by -1 \doitemize{#1.}\flushcr } % @multitable macros % Macros used to set up halign preamble: % \let\endsetuptable\relax \def\xendsetuptable{\endsetuptable} \let\columnfractions\relax \def\xcolumnfractions{\columnfractions} \newif\ifsetpercent % #1 is the @columnfraction, usually a decimal number like .5, but might % be just 1. We just use it, whatever it is. % \def\pickupwholefraction#1 {% \global\advance\colcount by 1 \expandafter\xdef\csname col\the\colcount\endcsname{#1\hsize}% \setuptable } \newcount\colcount \def\setuptable#1{% \def\firstarg{#1}% \ifx\firstarg\xendsetuptable \let\go = \relax \else \ifx\firstarg\xcolumnfractions \global\setpercenttrue \else \ifsetpercent \let\go\pickupwholefraction \else \global\advance\colcount by 1 \setbox0=\hbox{#1\unskip\space}% Add a normal word space as a % separator; typically that is always in the input, anyway. \expandafter\xdef\csname col\the\colcount\endcsname{\the\wd0}% \fi \fi \ifx\go\pickupwholefraction % Put the argument back for the \pickupwholefraction call, so % we'll always have a period there to be parsed. \def\go{\pickupwholefraction#1}% \else \let\go = \setuptable \fi% \fi \go } % @headitem starts a heading row, which we typeset in bold. Assignments % have to be global since we are inside the implicit group of an % alignment entry. \everycr below resets \everytab so we don't have to % undo it ourselves. \def\headitemfont{\b}% for people to use in the template row; not changeable \def\headitem{% \crcr % must appear first \gdef\headitemcrhook{\nobreak}% attempt to avoid page break after headings \global\everytab={\bf}% can't use \headitemfont since the parsing differs \the\everytab % for the first item }% % % default for tables with no headings. \let\headitemcrhook=\relax % \def\tab{\checkenv\multitable &\the\everytab}% \newtoks\everytab % insert after every tab. % \envdef\multitable{% \vskip\parskip \startsavinginserts % % @item within a multitable starts a normal row. % We use \def instead of \let so that if one of the multitable entries % contains an @itemize, we don't choke on the \item (seen as \crcr aka % \endtemplate) expanding \doitemize. \def\item{\crcr}% % \tolerance=9500 \hbadness=9500 \parskip=0pt \parindent=6pt \overfullrule=0pt \global\colcount=0 % \everycr = {% \noalign{% \global\everytab={}% Reset from possible headitem. \global\colcount=0 % Reset the column counter. % % Check for saved footnotes, etc.: \checkinserts % % Perhaps a \nobreak, then reset: \headitemcrhook \global\let\headitemcrhook=\relax }% }% % \parsearg\domultitable } \def\domultitable#1{% % To parse everything between @multitable and @item: \setuptable#1 \endsetuptable % % This preamble sets up a generic column definition, which will % be used as many times as user calls for columns. % \vtop will set a single line and will also let text wrap and % continue for many paragraphs if desired. \halign\bgroup &% \global\advance\colcount by 1 \strut \vtop{% \advance\hsize by -1\leftskip % Find the correct column width \hsize=\expandafter\csname col\the\colcount\endcsname % \advance\rightskip by -1\rightskip % Zero leaving only any stretch \ifnum\colcount=1 \advance\hsize by\leftskip % Add indent of surrounding text \else % In order to keep entries from bumping into each other. \leftskip=12pt \ifsetpercent \else % If a template has been used \advance\hsize by \leftskip \fi \fi \noindent\ignorespaces##\unskip\strut }\cr } \def\Emultitable{% \crcr \egroup % end the \halign \global\setpercentfalse } \message{conditionals,} % @iftex, @ifnotdocbook, @ifnothtml, @ifnotinfo, @ifnotlatex, @ifnotplaintext, % @ifnotxml always succeed. They currently do nothing; we don't % attempt to check whether the conditionals are properly nested. But we % have to remember that they are conditionals, so that @end doesn't % attempt to close an environment group. % \def\makecond#1{% \expandafter\let\csname #1\endcsname = \relax \expandafter\let\csname iscond.#1\endcsname = 1 } \makecond{iftex} \makecond{ifnotdocbook} \makecond{ifnothtml} \makecond{ifnotinfo} \makecond{ifnotlatex} \makecond{ifnotplaintext} \makecond{ifnotxml} % Ignore @ignore, @ifhtml, @ifinfo, and the like. % \def\direntry{\doignore{direntry}} \def\documentdescription{\doignore{documentdescription}} \def\docbook{\doignore{docbook}} \def\html{\doignore{html}} \def\ifdocbook{\doignore{ifdocbook}} \def\ifhtml{\doignore{ifhtml}} \def\ifinfo{\doignore{ifinfo}} \def\iflatex{\doignore{iflatex}} \def\ifnottex{\doignore{ifnottex}} \def\ifplaintext{\doignore{ifplaintext}} \def\ifxml{\doignore{ifxml}} \def\ignore{\doignore{ignore}} \def\latex{\doignore{latex}} \def\menu{\doignore{menu}} \def\xml{\doignore{xml}} % Ignore text until a line `@end #1', keeping track of nested conditionals. % % A count to remember the depth of nesting. \newcount\doignorecount \def\doignore#1{\begingroup % Scan in ``verbatim'' mode: \obeylines \catcode`\@ = \other \catcode`\{ = \other \catcode`\} = \other % % Make sure that spaces turn into tokens that match what \doignoretext wants. \spaceisspace % % Count number of #1's that we've seen. \doignorecount = 0 % % Swallow text until we reach the matching `@end #1'. \dodoignore{#1}% } { \catcode`_=11 % We want to use \_STOP_ which cannot appear in texinfo source. \obeylines % % \gdef\dodoignore#1{% % #1 contains the command name as a string, e.g., `ifinfo'. % % Define a command to find the next `@end #1'. \long\def\doignoretext##1^^M@end #1{% \doignoretextyyy##1^^M@#1\_STOP_}% % % And this command to find another #1 command, at the beginning of a % line. (Otherwise, we would consider a line `@c @ifset', for % example, to count as an @ifset for nesting.) \long\def\doignoretextyyy##1^^M@#1##2\_STOP_{\doignoreyyy{##2}\_STOP_}% % % And now expand that command. \doignoretext ^^M% }% } \def\doignoreyyy#1{% \def\temp{#1}% \ifx\temp\empty % Nothing found. \let\next\doignoretextzzz \else % Found a nested condition, ... \advance\doignorecount by 1 \let\next\doignoretextyyy % ..., look for another. % If we're here, #1 ends with ^^M\ifinfo (for example). \fi \next #1% the token \_STOP_ is present just after this macro. } % We have to swallow the remaining "\_STOP_". % \def\doignoretextzzz#1{% \ifnum\doignorecount = 0 % We have just found the outermost @end. \let\next\enddoignore \else % Still inside a nested condition. \advance\doignorecount by -1 \let\next\doignoretext % Look for the next @end. \fi \next } % Finish off ignored text. { \obeylines% % Ignore anything after the last `@end #1'; this matters in verbatim % environments, where otherwise the newline after an ignored conditional % would result in a blank line in the output. \gdef\enddoignore#1^^M{\endgroup\ignorespaces}% } % @set VAR sets the variable VAR to an empty value. % @set VAR REST-OF-LINE sets VAR to the value REST-OF-LINE. % % Since we want to separate VAR from REST-OF-LINE (which might be % empty), we can't just use \parsearg; we have to insert a space of our % own to delimit the rest of the line, and then take it out again if we % didn't need it. % We rely on the fact that \parsearg sets \catcode`\ =10. % \parseargdef\set{\setyyy#1 \endsetyyy} \def\setyyy#1 #2\endsetyyy{% {% \makevalueexpandable \def\temp{#2}% \edef\next{\gdef\makecsname{SET#1}}% \ifx\temp\empty \next{}% \else \setzzz#2\endsetzzz \fi }% } % Remove the trailing space \setxxx inserted. \def\setzzz#1 \endsetzzz{\next{#1}} % @clear VAR clears (i.e., unsets) the variable VAR. % \parseargdef\clear{% {% \makevalueexpandable \global\expandafter\let\csname SET#1\endcsname=\relax }% } % @value{foo} gets the text saved in variable foo. \def\value{\begingroup\makevalueexpandable\valuexxx} \def\valuexxx#1{\expandablevalue{#1}\endgroup} { \catcode`\-=\active \catcode`\_=\active % \gdef\makevalueexpandable{% \let\value = \expandablevalue % We don't want these characters active, ... \catcode`\-=\other \catcode`\_=\other % ..., but we might end up with active ones in the argument if % we're called from @code, as @code{@value{foo-bar_}}, though. % So \let them to their normal equivalents. \let-\normaldash \let_\normalunderscore } } \def\expandablevalue#1{% \expandafter\ifx\csname SET#1\endcsname\relax {[No value for ``#1'']}% \message{Variable `#1', used in @value, is not set.}% \else \csname SET#1\endcsname \fi } % Like \expandablevalue, but completely expandable (the \message in the % definition above operates at the execution level of TeX). Used when % writing to auxiliary files, due to the expansion that \write does. % If flag is undefined, pass through an unexpanded @value command: maybe it % will be set by the time it is read back in. % % NB flag names containing - or _ may not work here. \def\dummyvalue#1{% \expandafter\ifx\csname SET#1\endcsname\relax \string\value{#1}% \else \csname SET#1\endcsname \fi } % Used for @value's in index entries to form the sort key: expand the @value % if possible, otherwise sort late. \def\indexnofontsvalue#1{% \expandafter\ifx\csname SET#1\endcsname\relax ZZZZZZZ% \else \csname SET#1\endcsname \fi } % @ifset VAR ... @end ifset reads the `...' iff VAR has been defined % with @set. % % To get the special treatment we need for `@end ifset,' we call % \makecond and then redefine. % \makecond{ifset} \def\ifset{\parsearg{\doifset{\let\next=\ifsetfail}}} \def\doifset#1#2{% {% \makevalueexpandable \let\next=\empty \expandafter\ifx\csname SET#2\endcsname\relax #1% If not set, redefine \next. \fi \expandafter }\next } \def\ifsetfail{\doignore{ifset}} % @ifclear VAR ... @end executes the `...' iff VAR has never been % defined with @set, or has been undefined with @clear. % % The `\else' inside the `\doifset' parameter is a trick to reuse the % above code: if the variable is not set, do nothing, if it is set, % then redefine \next to \ifclearfail. % \makecond{ifclear} \def\ifclear{\parsearg{\doifset{\else \let\next=\ifclearfail}}} \def\ifclearfail{\doignore{ifclear}} % @ifcommandisdefined CMD ... @end executes the `...' if CMD (written % without the @) is in fact defined. We can only feasibly check at the % TeX level, so something like `mathcode' is going to considered % defined even though it is not a Texinfo command. % \makecond{ifcommanddefined} \def\ifcommanddefined{\parsearg{\doifcmddefined{\let\next=\ifcmddefinedfail}}} % \def\doifcmddefined#1#2{{% \makevalueexpandable \let\next=\empty \expandafter\ifx\csname #2\endcsname\relax #1% If not defined, \let\next as above. \fi \expandafter }\next } \def\ifcmddefinedfail{\doignore{ifcommanddefined}} % @ifcommandnotdefined CMD ... handled similar to @ifclear above. \makecond{ifcommandnotdefined} \def\ifcommandnotdefined{% \parsearg{\doifcmddefined{\else \let\next=\ifcmdnotdefinedfail}}} \def\ifcmdnotdefinedfail{\doignore{ifcommandnotdefined}} % Set the `txicommandconditionals' variable, so documents have a way to % test if the @ifcommand...defined conditionals are available. \set txicommandconditionals % @dircategory CATEGORY -- specify a category of the dir file % which this file should belong to. Ignore this in TeX. \let\dircategory=\comment % @defininfoenclose. \let\definfoenclose=\comment \message{indexing,} % Index generation facilities % Define \newwrite to be identical to plain tex's \newwrite % except not \outer, so it can be used within macros and \if's. \edef\newwrite{\makecsname{ptexnewwrite}} % \newindex {IX} defines an index named IX. % It automatically defines \IXindex such that % \IXindex ...rest of line... puts an entry in the index IX. % It also defines \IXindfile to be the number of the output channel for % the file that accumulates this index. The file's extension is IX. % \def\newindex#1{% \expandafter\chardef\csname#1indfile\endcsname=0 \expandafter\xdef\csname#1index\endcsname{% % Define @#1index \noexpand\doindex{#1}} } % @defindex foo == \newindex{foo} % \def\defindex{\parsearg\newindex} % Define @defcodeindex, like @defindex except put all entries in @code. % \def\defcodeindex{\parsearg\newcodeindex} % \def\newcodeindex#1{% \expandafter\chardef\csname#1indfile\endcsname=0 \expandafter\xdef\csname#1index\endcsname{% \noexpand\docodeindex{#1}}% } % The default indices: \newindex{cp}% concepts, \newcodeindex{fn}% functions, \newcodeindex{vr}% variables, \newcodeindex{tp}% types, \newcodeindex{ky}% keys \newcodeindex{pg}% and programs. % @synindex foo bar makes index foo feed into index bar. % Do this instead of @defindex foo if you don't want it as a separate index. % % @syncodeindex foo bar similar, but put all entries made for index foo % inside @code. % \def\synindex#1 #2 {\dosynindex\doindex{#1}{#2}} \def\syncodeindex#1 #2 {\dosynindex\docodeindex{#1}{#2}} % #1 is \doindex or \docodeindex, #2 the index getting redefined (foo), % #3 the target index (bar). \def\dosynindex#1#2#3{% \requireopenindexfile{#3}% % redefine \fooindfile: \expandafter\let\expandafter\temp\expandafter=\csname#3indfile\endcsname \expandafter\let\csname#2indfile\endcsname=\temp % redefine \fooindex: \expandafter\xdef\csname#2index\endcsname{\noexpand#1{#3}}% } % Define \doindex, the driver for all index macros. % Argument #1 is generated by the calling \fooindex macro, % and it is the two-letter name of the index. \def\doindex#1{\edef\indexname{#1}\parsearg\doindexxxx} \def\doindexxxx #1{\doind{\indexname}{#1}} % like the previous two, but they put @code around the argument. \def\docodeindex#1{\edef\indexname{#1}\parsearg\docodeindexxxx} \def\docodeindexxxx #1{\docind{\indexname}{#1}} % \definedummyword defines \#1 as \string\#1\space, thus effectively % preventing its expansion. This is used only for control words, % not control letters, because the \space would be incorrect for % control characters, but is needed to separate the control word % from whatever follows. % % These can be used both for control words that take an argument and % those that do not. If it is followed by {arg} in the input, then % that will dutifully get written to the index (or wherever). % % For control letters, we have \definedummyletter, which omits the % space. % \def\definedummyword #1{\def#1{\string#1\space}}% \def\definedummyletter#1{\def#1{\string#1}}% % Used for the aux, toc and index files to prevent expansion of Texinfo % commands. Most of the commands are controlled through the % \ifdummies conditional. % \def\atdummies{% \dummiestrue % \definedummyletter\@% \definedummyletter\ % \definedummyletter\{% \definedummyletter\}% \definedummyletter\&% % \definedummyletter\_% \definedummyletter\-% % \definedummyword\subentry % % We want to disable all macros so that they are not expanded by \write. \let\commondummyword\definedummyword \macrolist \let\value\dummyvalue % \turnoffactive } \newif\ifdummies \newif\ifindexnofonts \def\commondummyletter#1{% \expandafter\let\csname\string#1:impl\endcsname#1% \edef#1{% \noexpand\ifindexnofonts % empty expansion \noexpand\else \noexpand\ifdummies\string#1% \noexpand\else \noexpand\jumptwofi % dispose of the \fi \expandafter\noexpand\csname\string#1:impl\endcsname \noexpand\fi \noexpand\fi}% } \def\commondummyaccent#1{% \expandafter\let\csname\string#1:impl\endcsname#1% \edef#1{% \noexpand\ifindexnofonts \noexpand\expandafter % dispose of \else ... \fi \noexpand\asis \noexpand\else \noexpand\ifdummies\string#1% \noexpand\else \noexpand\jumptwofi % dispose of the \fi \expandafter\noexpand\csname\string#1:impl\endcsname \noexpand\fi \noexpand\fi}% } % Like \commondummyaccent but add a \space at the end of the dummy expansion % #2 is the expansion used for \indexnofonts. #2 is always followed by % \asis to remove a pair of following braces. \def\commondummyword#1#2{% \expandafter\let\csname\string#1:impl\endcsname#1% \expandafter\def\csname\string#1:ixnf\endcsname{#2\asis}% \edef#1{% \noexpand\ifindexnofonts \noexpand\expandafter % dispose of \else ... \fi \expandafter\noexpand\csname\string#1:ixnf\endcsname \noexpand\else \noexpand\ifdummies\string#1\space \noexpand\else \noexpand\jumptwofi % dispose of the \fi \fi \expandafter\noexpand\csname\string#1:impl\endcsname \noexpand\fi \noexpand\fi}% } \def\jumptwofi#1\fi\fi{\fi\fi#1} % For \atdummies and \indexnofonts. \atdummies sets % \dummiestrue and \indexnofonts sets \indexnofontstrue. \def\definedummies{ % @-sign is always an escape character when reading auxiliary files \escapechar = `\@ % \commondummyletter\!% \commondummyaccent\"% \commondummyaccent\'% \commondummyletter\*% \commondummyaccent\,% \commondummyletter\.% \commondummyletter\/% \commondummyletter\:% \commondummyaccent\=% \commondummyletter\?% \commondummyaccent\^% \commondummyaccent\`% \commondummyaccent\~% % % Control letters and accents. \commondummyword\u {}% \commondummyword\v {}% \commondummyword\H {}% \commondummyword\dotaccent {}% \commondummyword\ogonek {}% \commondummyword\ringaccent {}% \commondummyword\tieaccent {}% \commondummyword\ubaraccent {}% \commondummyword\udotaccent {}% \commondummyword\dotless {}% % % Texinfo font commands. \commondummyword\b {}% \commondummyword\i {}% \commondummyword\r {}% \commondummyword\sansserif {}% \commondummyword\sc {}% \commondummyword\slanted {}% \commondummyword\t {}% % % Commands that take arguments. \commondummyword\abbr {}% \commondummyword\acronym {}% \commondummyword\anchor {}% \commondummyword\cite {}% \commondummyword\code {}% \commondummyword\command {}% \commondummyword\dfn {}% \commondummyword\dmn {}% \commondummyword\email {}% \commondummyword\emph {}% \commondummyword\env {}% \commondummyword\file {}% \commondummyword\image {}% \commondummyword\indicateurl{}% \commondummyword\inforef {}% \commondummyword\kbd {}% \commondummyword\key {}% \commondummyword\link {}% \commondummyword\math {}% \commondummyword\option {}% \commondummyword\pxref {}% \commondummyword\ref {}% \commondummyword\samp {}% \commondummyword\strong {}% \commondummyword\tie {}% \commondummyword\U {}% \commondummyword\uref {}% \commondummyword\url {}% \commondummyword\var {}% \commondummyword\verb {}% \commondummyword\w {}% \commondummyword\xref {}% % \commondummyword\AA {AA}% \commondummyword\AE {AE}% \commondummyword\DH {DZZ}% \commondummyword\L {L}% \commondummyword\O {O}% \commondummyword\OE {OE}% \commondummyword\TH {TH}% \commondummyword\aa {aa}% \commondummyword\ae {ae}% \commondummyword\dh {dzz}% \commondummyword\exclamdown {!}% \commondummyword\l {l}% \commondummyword\o {o}% \commondummyword\oe {oe}% \commondummyword\ordf {a}% \commondummyword\ordm {o}% \commondummyword\questiondown {?}% \commondummyword\ss {ss}% \commondummyword\th {th}% % \commondummyword\LaTeX {LaTeX}% \commondummyword\TeX {TeX}% % % Assorted special characters. \commondummyword\ampchar {\normalamp}% \commondummyword\atchar {\@}% \commondummyword\arrow {->}% \commondummyword\backslashchar {\realbackslash}% \commondummyword\bullet {bullet}% \commondummyword\comma {,}% \commondummyword\copyright {copyright}% \commondummyword\dots {...}% \commondummyword\enddots {...}% \commondummyword\entrybreak {}% \commondummyword\equiv {===}% \commondummyword\error {error}% \commondummyword\euro {euro}% \commondummyword\expansion {==>}% \commondummyword\geq {>=}% \commondummyword\guillemetleft {<<}% \commondummyword\guillemetright {>>}% \commondummyword\guilsinglleft {<}% \commondummyword\guilsinglright {>}% \commondummyword\lbracechar {\{}% \commondummyword\leq {<=}% \commondummyword\mathopsup {sup}% \commondummyword\minus {-}% \commondummyword\pounds {pounds}% \commondummyword\point {.}% \commondummyword\print {-|}% \commondummyword\quotedblbase {"}% \commondummyword\quotedblleft {"}% \commondummyword\quotedblright {"}% \commondummyword\quoteleft {`}% \commondummyword\quoteright {'}% \commondummyword\quotesinglbase {,}% \commondummyword\rbracechar {\}}% \commondummyword\registeredsymbol {R}% \commondummyword\result {=>}% \commondummyword\sub {}% \commondummyword\sup {}% \commondummyword\textdegree {o}% } \let\indexlbrace\relax \let\indexrbrace\relax \let\indexatchar\relax \let\indexbackslash\relax {\catcode`\@=0 \catcode`\\=13 @gdef@backslashdisappear{@def\{}} } { \catcode`\<=13 \catcode`\-=13 \catcode`\`=13 \gdef\indexnonalnumdisappear{% \ifflagclear{txiindexlquoteignore}{}{% % @set txiindexlquoteignore makes us ignore left quotes in the sort term. % (Introduced for FSFS 2nd ed.) \let`=\empty }% % \ifflagclear{txiindexbackslashignore}{}{% \backslashdisappear }% \ifflagclear{txiindexhyphenignore}{}{% \def-{}% }% \ifflagclear{txiindexlessthanignore}{}{% \def<{}% }% \ifflagclear{txiindexatsignignore}{}{% \def\@{}% }% } \gdef\indexnonalnumreappear{% \let-\normaldash \let<\normalless } } % \indexnofonts is used when outputting the strings to sort the index % by, and when constructing control sequence names. It eliminates all % control sequences and just writes whatever the best ASCII sort string % would be for a given command (usually its argument). % \def\indexnofonts{% \indexnofontstrue % \def\ { }% \def\@{@}% \def\_{\normalunderscore}% \def\-{}% @- shouldn't affect sorting % \uccode`\1=`\{ \uppercase{\def\{{1}}% \uccode`\1=`\} \uppercase{\def\}{1}}% \let\lbracechar\{% \let\rbracechar\}% % % % We need to get rid of all macros, leaving only the arguments (if present). % Of course this is not nearly correct, but it is the best we can do for now. % % Since macro invocations are followed by braces, we can just redefine them % to take a single TeX argument. The case of a macro invocation that % goes to end-of-line is not handled. % \def\commondummyword##1{\let##1\asis}% \macrolist \let\value\indexnofontsvalue } % #1 is the index name, #2 is the entry text. \def\doind#1#2{% \iflinks {% % \requireopenindexfile{#1}% \edef\writeto{\csname#1indfile\endcsname}% % \def\indextext{#2}% \safewhatsit\doindwrite }% \fi } % Same as \doind, but for code indices \def\docind#1#2{% \iflinks {% % \requireopenindexfile{#1}% \edef\writeto{\csname#1indfile\endcsname}% % \def\indextext{#2}% \safewhatsit\docindwrite }% \fi } % Check if an index file has been opened, and if not, open it. \def\requireopenindexfile#1{% \ifnum\csname #1indfile\endcsname=0 \expandafter\newwrite \csname#1indfile\endcsname \edef\suffix{#1}% % A .fls suffix would conflict with the file extension for the output % of -recorder, so use .f1s instead. \ifx\suffix\indexisfl\def\suffix{f1}\fi % Open the file \immediate\openout\csname#1indfile\endcsname \jobname.\suffix % Using \immediate above here prevents an object entering into the current % box, which could confound checks such as those in \safewhatsit for % preceding skips. \typeout{Writing index file \jobname.\suffix}% \fi} \def\indexisfl{fl} % Definition for writing index entry sort key. { \catcode`\-=13 \gdef\indexwritesortas{% \begingroup \indexnonalnumreappear \indexwritesortasxxx} \gdef\indexwritesortasxxx#1{% \xdef\indexsortkey{#1}\endgroup} } \def\indexwriteseealso#1{ \gdef\pagenumbertext{\string\seealso{#1}}% } \def\indexwriteseeentry#1{ \gdef\pagenumbertext{\string\seeentry{#1}}% } % The default definitions \def\sortas#1{}% \def\seealso#1{\i{\putwordSeeAlso}\ #1}% for sorted index file only \def\putwordSeeAlso{See also} \def\seeentry#1{\i{\putwordSee}\ #1}% for sorted index file only % Given index entry text like "aaa @subentry bbb @sortas{ZZZ}": % * Set \bracedtext to "{aaa}{bbb}" % * Set \fullindexsortkey to "aaa @subentry ZZZ" % * If @seealso occurs, set \pagenumbertext % \def\splitindexentry#1{% \gdef\fullindexsortkey{}% \xdef\bracedtext{}% \def\sep{}% \def\seealso##1{}% \def\seeentry##1{}% \expandafter\doindexsegment#1\subentry\finish\subentry } % append the results from the next segment \def\doindexsegment#1\subentry{% \def\segment{#1}% \ifx\segment\isfinish \else % % Fully expand the segment, throwing away any @sortas directives, and % trim spaces. \edef\trimmed{\segment}% \edef\trimmed{\expandafter\eatspaces\expandafter{\trimmed}}% \ifincodeindex \edef\trimmed{\noexpand\code{\trimmed}}% \fi % \xdef\bracedtext{\bracedtext{\trimmed}}% % % Get the string to sort by. Process the segment with all % font commands turned off. \bgroup \let\sortas\indexwritesortas \let\seealso\indexwriteseealso \let\seeentry\indexwriteseeentry \indexnofonts % The braces around the commands are recognized by texindex. \def\lbracechar{{\string\indexlbrace}}% \def\rbracechar{{\string\indexrbrace}}% \let\{=\lbracechar \let\}=\rbracechar \def\@{{\string\indexatchar}}% \def\atchar##1{\@}% \def\backslashchar{{\string\indexbackslash}}% \uccode`\~=`\\ \uppercase{\let~\backslashchar}% % \let\indexsortkey\empty \global\let\pagenumbertext\empty % Execute the segment and throw away the typeset output. This executes % any @sortas or @seealso commands in this segment. \setbox\dummybox = \hbox{\segment}% \ifx\indexsortkey\empty{% \indexnonalnumdisappear \xdef\trimmed{\segment}% \xdef\trimmed{\expandafter\eatspaces\expandafter{\trimmed}}% \xdef\indexsortkey{\trimmed}% \ifx\indexsortkey\empty \message{Empty index sort key near line \the\inputlineno}% \xdef\indexsortkey{ }% \fi }\fi % % Append to \fullindexsortkey. \edef\tmp{\gdef\noexpand\fullindexsortkey{% \fullindexsortkey\sep\indexsortkey}}% \tmp \egroup \def\sep{\subentry}% % \expandafter\doindexsegment \fi } \def\isfinish{\finish}% \newbox\dummybox % used above \let\subentry\relax % Use \ instead of @ in index files. To support old texi2dvi and texindex. % This works without changing the escape character used in the toc or aux % files because the index entries are fully expanded here, and \string uses % the current value of \escapechar. \def\escapeisbackslash{\escapechar=`\\} % Uncomment to use \ in index files by default. Old texi2dvi (before 2019) % didn't support @ as the escape character (as it checked for "\entry" in % the files, and not "@entry"). % In the future we can remove this flag and simplify the code for % index files and backslashes, once the support is no longer likely to be % useful. % % \set txiindexescapeisbackslash % Write the entry in \indextext to the index file. % \newif\ifincodeindex \def\doindwrite{\incodeindexfalse\doindwritex} \def\docindwrite{\incodeindextrue\doindwritex} \def\doindwritex{% \maybemarginindex % \atdummies % \ifflagclear{txiindexescapeisbackslash}{}{\escapeisbackslash}% % % For texindex which always views { and } as separators. \def\{{\lbracechar{}}% \def\}{\rbracechar{}}% \uccode`\~=`\\ \uppercase{\def~{\backslashchar{}}}% % % Split the entry into primary entry and any subentries, and get the index % sort key. \splitindexentry\indextext % % Set up the complete index entry, with both the sort key and % the original text, including any font commands. We write % three arguments to \entry to the .?? file (four in the % subentry case), texindex reduces to two when writing the .??s % sorted result. % \edef\temp{% \write\writeto{% \string\entry{\fullindexsortkey}% {\ifx\pagenumbertext\empty\noexpand\folio\else\pagenumbertext\fi}% \bracedtext}% }% \temp } % Put the index entry in the margin if desired (undocumented). \def\maybemarginindex{% \ifx\SETmarginindex\relax\else \insert\margin{\hbox{\vrule height8pt depth3pt width0pt \relax\indextext}}% \fi } \let\SETmarginindex=\relax % Take care of unwanted page breaks/skips around a whatsit: % % If a skip is the last thing on the list now, preserve it % by backing up by \lastskip, doing the \write, then inserting % the skip again. Otherwise, the whatsit generated by the % \write or \pdfdest will make \lastskip zero. The result is that % sequences like this: % @end defun % @tindex whatever % @defun ... % will have extra space inserted, because the \medbreak in the % start of the @defun won't see the skip inserted by the @end of % the previous defun. % % But don't do any of this if we're not in vertical mode. We % don't want to do a \vskip and prematurely end a paragraph. % % Avoid page breaks due to these extra skips, too. % % But wait, there is a catch there: % We'll have to check whether \lastskip is zero skip. \ifdim is not % sufficient for this purpose, as it ignores stretch and shrink parts % of the skip. The only way seems to be to check the textual % representation of the skip. % % The following is almost like \def\zeroskipmacro{0.0pt} except that % the ``p'' and ``t'' characters have catcode \other, not 11 (letter). % \edef\zeroskipmacro{\expandafter\the\csname z@skip\endcsname} % \newskip\whatsitskip \newcount\whatsitpenalty % % ..., ready, GO: % \def\safewhatsit#1{\ifhmode #1% \else % \lastskip and \lastpenalty cannot both be nonzero simultaneously. \whatsitskip = \lastskip \edef\lastskipmacro{\the\lastskip}% \whatsitpenalty = \lastpenalty % % If \lastskip is nonzero, that means the last item was a % skip. And since a skip is discardable, that means this % -\whatsitskip glue we're inserting is preceded by a % non-discardable item, therefore it is not a potential % breakpoint, therefore no \nobreak needed. \ifx\lastskipmacro\zeroskipmacro \else \vskip-\whatsitskip \fi % #1% % \ifx\lastskipmacro\zeroskipmacro % If \lastskip was zero, perhaps the last item was a penalty, and % perhaps it was >=10000, e.g., a \nobreak. In that case, we want % to re-insert the same penalty (values >10000 are used for various % signals); since we just inserted a non-discardable item, any % following glue (such as a \parskip) would be a breakpoint. For example: % @deffn deffn-whatever % @vindex index-whatever % Description. % would allow a break between the index-whatever whatsit % and the "Description." paragraph. \ifnum\whatsitpenalty>9999 \penalty\whatsitpenalty \fi \else % On the other hand, if we had a nonzero \lastskip, % this make-up glue would be preceded by a non-discardable item % (the whatsit from the \write), so we must insert a \nobreak. \nobreak\vskip\whatsitskip \fi \fi} % The index entry written in the file actually looks like % \entry {sortstring}{page}{topic} % or % \entry {sortstring}{page}{topic}{subtopic} % The texindex program reads in these files and writes files % containing these kinds of lines: % \initial {c} % before the first topic whose initial is c % \entry {topic}{pagelist} % for a topic that is used without subtopics % \primary {topic} % \entry {topic}{} % for the beginning of a topic that is used with subtopics % \secondary {subtopic}{pagelist} % for each subtopic. % \secondary {subtopic}{} % for a subtopic with sub-subtopics % \tertiary {subtopic}{subsubtopic}{pagelist} % for each sub-subtopic. % Define the user-accessible indexing commands % @findex, @vindex, @kindex, @cindex. \def\findex {\fnindex} \def\kindex {\kyindex} \def\cindex {\cpindex} \def\vindex {\vrindex} \def\tindex {\tpindex} \def\pindex {\pgindex} % Define the macros used in formatting output of the sorted index material. % @printindex causes a particular index (the ??s file) to get printed. % It does not print any chapter heading (usually an @unnumbered). % \parseargdef\printindex{\begingroup \dobreak \chapheadingskip{10000}% % \smallfonts \rm \tolerance = 9500 \plainfrenchspacing \everypar = {}% don't want the \kern\-parindent from indentation suppression. % % See comment in \requireopenindexfile. \def\indexname{#1}\ifx\indexname\indexisfl\def\indexname{f1}\fi % % See if the index file exists and is nonempty. \openin 1 \jobname.\indexname s \ifeof 1 % \enddoublecolumns gets confused if there is no text in the index, % and it loses the chapter title and the aux file entries for the % index. The easiest way to prevent this problem is to make sure % there is some text. \putwordIndexNonexistent \typeout{No file \jobname.\indexname s.}% \else % If the index file exists but is empty, then \openin leaves \ifeof % false. We have to make TeX try to read something from the file, so % it can discover if there is anything in it. \read 1 to \thisline \ifeof 1 \putwordIndexIsEmpty \else \expandafter\printindexzz\thisline\relax\relax\finish% \fi \fi \closein 1 \endgroup} % If the index file starts with a backslash, forgo reading the index % file altogether. If somebody upgrades texinfo.tex they may still have % old index files using \ as the escape character. Reading this would % at best lead to typesetting garbage, at worst a TeX syntax error. \def\printindexzz#1#2\finish{% \ifflagclear{txiindexescapeisbackslash}{% \uccode`\~=`\\ \uppercase{\if\noexpand~}\noexpand#1 \ifflagclear{txiskipindexfileswithbackslash}{% \errmessage{% ERROR: A sorted index file in an obsolete format was skipped. To fix this problem, please upgrade your version of 'texi2dvi' or 'texi2pdf' to that at . If you are using an old version of 'texindex' (part of the Texinfo distribution), you may also need to upgrade to a newer version (at least 6.0). You may be able to typeset the index if you run 'texindex \jobname.\indexname' yourself. You could also try setting the 'txiindexescapeisbackslash' flag by running a command like 'texi2dvi -t "@set txiindexescapeisbackslash" \jobname.texi'. If you do this, Texinfo will try to use index files in the old format. If you continue to have problems, deleting the index files and starting again might help (with 'rm \jobname.?? \jobname.??s')% }% }{% (Skipped sorted index file in obsolete format) }% \else \begindoublecolumns \input \jobname.\indexname s \enddoublecolumns \fi }{% \begindoublecolumns \catcode`\\=0\relax % % Make @ an escape character to give macros a chance to work. This % should work because we (hopefully) don't otherwise use @ in index files. %\catcode`\@=12\relax \catcode`\@=0\relax \input \jobname.\indexname s \enddoublecolumns }% } % These macros are used by the sorted index file itself. % Change them to control the appearance of the index. {\catcode`\/=13 \catcode`\-=13 \catcode`\^=13 \catcode`\~=13 \catcode`\_=13 \catcode`\|=13 \catcode`\<=13 \catcode`\>=13 \catcode`\+=13 \catcode`\"=13 \catcode`\$=3 \gdef\initialglyphs{% % special control sequences used in the index sort key \let\indexlbrace\{% \let\indexrbrace\}% \let\indexatchar\@% \def\indexbackslash{\math{\backslash}}% % % Some changes for non-alphabetic characters. Using the glyphs from the % math fonts looks more consistent than the typewriter font used elsewhere % for these characters. \uccode`\~=`\\ \uppercase{\def~{\math{\backslash}}} % % In case @\ is used for backslash \uppercase{\let\\=~} % Can't get bold backslash so don't use bold forward slash \catcode`\/=13 \def/{{\secrmnotbold \normalslash}}% \def-{{\normaldash\normaldash}}% en dash `--' \def^{{\chapbf \normalcaret}}% \def~{{\chapbf \normaltilde}}% \def\_{% \leavevmode \kern.07em \vbox{\hrule width.3em height.1ex}\kern .07em }% \def|{$\vert$}% \def<{$\less$}% \def>{$\gtr$}% \def+{$\normalplus$}% }} \def\initial{% \bgroup \initialglyphs \initialx } \def\initialx#1{% % Remove any glue we may have, we'll be inserting our own. \removelastskip % % We like breaks before the index initials, so insert a bonus. % The glue before the bonus allows a little bit of space at the % bottom of a column to reduce an increase in inter-line spacing. \nobreak \vskip 0pt plus 5\baselineskip \penalty -300 \vskip 0pt plus -5\baselineskip % % Typeset the initial. Making this add up to a whole number of % baselineskips increases the chance of the dots lining up from column % to column. It still won't often be perfect, because of the stretch % we need before each entry, but it's better. % % No shrink because it confuses \balancecolumns. \vskip 1.67\baselineskip plus 1\baselineskip \leftline{\secfonts \kern-0.05em \secbf #1}% % \secfonts is inside the argument of \leftline so that the change of % \baselineskip will not affect any glue inserted before the vbox that % \leftline creates. % Do our best not to break after the initial. \nobreak \vskip .33\baselineskip plus .1\baselineskip \egroup % \initialglyphs } \newdimen\entryrightmargin \entryrightmargin=0pt % amount to indent subsequent lines in an entry when it spans more than % one line. \newdimen\entrycontskip \entrycontskip=1em % for PDF output, whether to make the text of the entry a link to the page % number. set for @contents and @shortcontents where there is only one % page number. \newif\iflinkentrytext % \entry typesets a paragraph consisting of the text (#1), dot leaders, and % then page number (#2) flushed to the right margin. It is used for index % and table of contents entries. The paragraph is indented by \leftskip. % \def\entry{% \begingroup % % Start a new paragraph if necessary, so our assignments below can't % affect previous text. \par % % No extra space above this paragraph. \parskip = 0in % % When reading the text of entry, convert explicit line breaks % from @* into spaces. The user might give these in long section % titles, for instance. \def\*{\unskip\space\ignorespaces}% \def\entrybreak{\hfil\break}% An undocumented command % % Swallow the left brace of the text (first parameter): \afterassignment\doentry \let\temp = } \def\entrybreak{\unskip\space\ignorespaces}% \def\doentry{% % Save the text of the entry in \boxA \global\setbox\boxA=\hbox\bgroup \bgroup % Instead of the swallowed brace. \noindent \aftergroup\finishentry % And now comes the text of the entry. % Not absorbing as a macro argument reduces the chance of problems % with catcodes occurring. } {\catcode`\@=11 % #1 is the page number \gdef\finishentry#1{% \egroup % end \boxA \dimen@ = \wd\boxA % Length of text of entry % add any leaders and page number to \boxA. \global\setbox\boxA=\hbox\bgroup \ifpdforxetex \iflinkentrytext \pdflinkpage{#1}{\unhbox\boxA}% \else \unhbox\boxA \fi \else \unhbox\boxA \fi % % Get the width of the page numbers, and only use % leaders if they are present. \global\setbox\boxB = \hbox{#1}% \ifdim\wd\boxB = 0pt \null\nobreak\hfill\ % \else % \null\nobreak\indexdotfill % Have leaders before the page number. % \ifpdforxetex \pdfgettoks#1.% \hskip\skip\thinshrinkable\the\toksA \else \hskip\skip\thinshrinkable #1% \fi \fi \egroup % end \boxA % % now output \ifdim\wd\boxB = 0pt \noindent\unhbox\boxA\par \nobreak \else\bgroup % We want the text of the entries to be aligned to the left, and the % page numbers to be aligned to the right. % \parindent = 0pt \advance\leftskip by 0pt plus 1fil \advance\leftskip by 0pt plus -1fill \rightskip = 0pt plus -1fil \advance\rightskip by 0pt plus 1fill % Cause last line, which could consist of page numbers on their own % if the list of page numbers is long, to be aligned to the right. \parfillskip=0pt plus -1fill % \advance\rightskip by \entryrightmargin % \dimen@ii = \hsize \advance\dimen@ii by -1\leftskip \advance\dimen@ii by -1\entryrightmargin \ifdim\wd\boxA > \dimen@ii % If the entry doesn't fit in one line \ifdim\dimen@ > 0.8\dimen@ii % due to long index text \advance\leftskip by 0pt plus 1fill % ragged right % % Indent all lines but the first one. \advance\leftskip by \entrycontskip \advance\parindent by -\entrycontskip \fi\fi \indent % start paragraph \unhbox\boxA % % Do not prefer a separate line ending with a hyphen to fewer lines. \finalhyphendemerits = 0 % % Word spacing - no stretch \spaceskip=\fontdimen2\font minus \fontdimen4\font % \linepenalty=1000 % Discourage line breaks. \hyphenpenalty=5000 % Discourage hyphenation. % \par % format the paragraph \egroup % The \vbox \fi \endgroup }} \newskip\thinshrinkable \skip\thinshrinkable=.15em minus .15em % Like plain.tex's \dotfill, except uses up at least 0.5 em. % The filll stretch here overpowers both the fil and fill stretch to push % the page number to the right. \def\indexdotfill{\cleaders \hbox{$\mathsurround=0pt \mkern1.5mu.\mkern1.5mu$}\hskip 0.5em plus 1filll} \def\primary #1{\line{#1\hfil}} \def\secondary{\indententry{0.5cm}} \def\tertiary{\indententry{1cm}} \def\indententry#1#2#3{% \bgroup \leftskip=#1 \entry{#2}{#3}% \egroup } % Define two-column mode, which we use to typeset indexes. % Adapted from the TeXbook, page 416, which is to say, % the manmac.tex format used to print the TeXbook itself. \catcode`\@=11 % private names \newbox\partialpage \newdimen\doublecolumnhsize \def\begindoublecolumns{\begingroup % ended by \enddoublecolumns % If not much space left on page, start a new page. \ifdim\pagetotal>0.8\vsize\vfill\eject\fi % % Grab any single-column material above us. \output = {% \savetopmark % \global\setbox\partialpage = \vbox{% % Unvbox the main output page. \unvbox\PAGE \kern-\topskip \kern\baselineskip }% }% \eject % run that output routine to set \partialpage % % Use the double-column output routine for subsequent pages. \output = {\doublecolumnout}% % % Change the page size parameters. We could do this once outside this % routine, in each of @smallbook, @afourpaper, and the default 8.5x11 % format, but then we repeat the same computation. Repeating a couple % of assignments once per index is clearly meaningless for the % execution time, so we may as well do it in one place. % % First we halve the line length, less a little for the gutter between % the columns. We compute the gutter based on the line length, so it % changes automatically with the paper format. The magic constant % below is chosen so that the gutter has the same value (well, +-<1pt) % as it did when we hard-coded it. % % We put the result in a separate register, \doublecolumnhsize, so we % can restore it in \pagesofar, after \hsize itself has (potentially) % been clobbered. % \doublecolumnhsize = \hsize \advance\doublecolumnhsize by -.04154\hsize \divide\doublecolumnhsize by 2 \hsize = \doublecolumnhsize % % Get the available space for the double columns -- the normal % (undoubled) page height minus any material left over from the % previous page. \advance\vsize by -\ht\partialpage \vsize = 2\vsize % % For the benefit of balancing columns \advance\baselineskip by 0pt plus 0.5pt } % The double-column output routine for all double-column pages except % the last, which is done by \balancecolumns. % \def\doublecolumnout{% % \savetopmark \splittopskip=\topskip \splitmaxdepth=\maxdepth \dimen@ = \vsize \divide\dimen@ by 2 % % box0 will be the left-hand column, box2 the right. \setbox0=\vsplit\PAGE to\dimen@ \setbox2=\vsplit\PAGE to\dimen@ \global\advance\vsize by 2\ht\partialpage \onepageout\pagesofar % empty except for the first time we are called \unvbox\PAGE \penalty\outputpenalty } % % Re-output the contents of the output page -- any previous material, % followed by the two boxes we just split, in box0 and box2. \def\pagesofar{% \unvbox\partialpage % \hsize = \doublecolumnhsize \wd0=\hsize \wd2=\hsize \hbox to\txipagewidth{\box0\hfil\box2}% } % Finished with double columns. \def\enddoublecolumns{% % The following penalty ensures that the page builder is exercised % _before_ we change the output routine. This is necessary in the % following situation: % % The last section of the index consists only of a single entry. % Before this section, \pagetotal is less than \pagegoal, so no % break occurs before the last section starts. However, the last % section, consisting of \initial and the single \entry, does not % fit on the page and has to be broken off. Without the following % penalty the page builder will not be exercised until \eject % below, and by that time we'll already have changed the output % routine to the \balancecolumns version, so the next-to-last % double-column page will be processed with \balancecolumns, which % is wrong: The two columns will go to the main vertical list, with % the broken-off section in the recent contributions. As soon as % the output routine finishes, TeX starts reconsidering the page % break. The two columns and the broken-off section both fit on the % page, because the two columns now take up only half of the page % goal. When TeX sees \eject from below which follows the final % section, it invokes the new output routine that we've set after % \balancecolumns below; \onepageout will try to fit the two columns % and the final section into the vbox of \txipageheight (see % \pagebody), causing an overfull box. % % Note that glue won't work here, because glue does not exercise the % page builder, unlike penalties (see The TeXbook, pp. 280-281). \penalty0 % \output = {% % Split the last of the double-column material. \savetopmark \balancecolumns }% \eject % call the \output just set \ifdim\pagetotal=0pt % Having called \balancecolumns once, we do not % want to call it again. Therefore, reset \output to its normal % definition right away. \global\output=\expandafter{\the\defaultoutput} % \endgroup % started in \begindoublecolumns % Leave the double-column material on the current page, no automatic % page break. \box\balancedcolumns % % \pagegoal was set to the doubled \vsize above, since we restarted % the current page. We're now back to normal single-column % typesetting, so reset \pagegoal to the normal \vsize. \global\vsize = \txipageheight % \pagegoal = \txipageheight % \else % We had some left-over material. This might happen when \doublecolumnout % is called in \balancecolumns. Try again. \expandafter\enddoublecolumns \fi } \newbox\balancedcolumns \setbox\balancedcolumns=\vbox{shouldnt see this}% % % Only called for the last of the double column material. \doublecolumnout % does the others. \def\balancecolumns{% \setbox0 = \vbox{\unvbox\PAGE}% like \box255 but more efficient, see p.120. \dimen@ = \ht0 \ifdim\dimen@<7\baselineskip % Don't split a short final column in two. \setbox2=\vbox{}% \global\setbox\balancedcolumns=\vbox{\pagesofar}% \else % double the leading vertical space \advance\dimen@ by \topskip \advance\dimen@ by-\baselineskip \divide\dimen@ by 2 % target to split to \dimen@ii = \dimen@ \splittopskip = \topskip % Loop until left column is at least as high as the right column. {% \vbadness = 10000 \loop \global\setbox3 = \copy0 \global\setbox1 = \vsplit3 to \dimen@ \ifdim\ht1<\ht3 \global\advance\dimen@ by 1pt \repeat }% % Now the left column is in box 1, and the right column in box 3. % % Check whether the left column has come out higher than the page itself. % (Note that we have doubled \vsize for the double columns, so % the actual height of the page is 0.5\vsize). \ifdim2\ht1>\vsize % It appears that we have been called upon to balance too much material. % Output some of it with \doublecolumnout, leaving the rest on the page. \setbox\PAGE=\box0 \doublecolumnout \else % Compare the heights of the two columns. \ifdim4\ht1>5\ht3 % Column heights are too different, so don't make their bottoms % flush with each other. \setbox2=\vbox to \ht1 {\unvbox3\vfill}% \setbox0=\vbox to \ht1 {\unvbox1\vfill}% \else % Make column bottoms flush with each other. \setbox2=\vbox to\ht1{\unvbox3\unskip}% \setbox0=\vbox to\ht1{\unvbox1\unskip}% \fi \global\setbox\balancedcolumns=\vbox{\pagesofar}% \fi \fi % } \catcode`\@ = \other \message{sectioning,} % Chapters, sections, etc. % Let's start with @part. \parseargdef\part{\partzzz{#1}} \def\partzzz#1{% \chapoddpage \null \vskip.3\vsize % move it down on the page a bit \begingroup \noindent \titlefonts\rm #1\par % the text \let\lastnode=\empty % no node to associate with \writetocentry{part}{#1}{}% but put it in the toc \headingsoff % no headline or footline on the part page % This outputs a mark at the end of the page that clears \thischapter % and \thissection, as is done in \startcontents. \let\pchapsepmacro\relax \chapmacro{}{Yomitfromtoc}{}% \chapoddpage \endgroup } % \unnumberedno is an oxymoron. But we count the unnumbered % sections so that we can refer to them unambiguously in the pdf % outlines by their "section number". We avoid collisions with chapter % numbers by starting them at 10000. (If a document ever has 10000 % chapters, we're in trouble anyway, I'm sure.) \newcount\unnumberedno \unnumberedno = 10000 \newcount\chapno \newcount\secno \secno=0 \newcount\subsecno \subsecno=0 \newcount\subsubsecno \subsubsecno=0 % This counter is funny since it counts through charcodes of letters A, B, ... \newcount\appendixno \appendixno = `\@ % % \def\appendixletter{\char\the\appendixno} % We do the following ugly conditional instead of the above simple % construct for the sake of pdftex, which needs the actual % letter in the expansion, not just typeset. % \def\appendixletter{% \ifnum\appendixno=`A A% \else\ifnum\appendixno=`B B% \else\ifnum\appendixno=`C C% \else\ifnum\appendixno=`D D% \else\ifnum\appendixno=`E E% \else\ifnum\appendixno=`F F% \else\ifnum\appendixno=`G G% \else\ifnum\appendixno=`H H% \else\ifnum\appendixno=`I I% \else\ifnum\appendixno=`J J% \else\ifnum\appendixno=`K K% \else\ifnum\appendixno=`L L% \else\ifnum\appendixno=`M M% \else\ifnum\appendixno=`N N% \else\ifnum\appendixno=`O O% \else\ifnum\appendixno=`P P% \else\ifnum\appendixno=`Q Q% \else\ifnum\appendixno=`R R% \else\ifnum\appendixno=`S S% \else\ifnum\appendixno=`T T% \else\ifnum\appendixno=`U U% \else\ifnum\appendixno=`V V% \else\ifnum\appendixno=`W W% \else\ifnum\appendixno=`X X% \else\ifnum\appendixno=`Y Y% \else\ifnum\appendixno=`Z Z% % The \the is necessary, despite appearances, because \appendixletter is % expanded while writing the .toc file. \char\appendixno is not % expandable, thus it is written literally, thus all appendixes come out % with the same letter (or @) in the toc without it. \else\char\the\appendixno \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi} % Each @chapter defines these (using marks) as the number+name, number % and name of the chapter. Page headings and footings can use % these. @section does likewise. \def\thischapter{} \def\thischapternum{} \def\thischaptername{} \def\thissection{} \def\thissectionnum{} \def\thissectionname{} \newcount\absseclevel % used to calculate proper heading level \newcount\secbase\secbase=0 % @raisesections/@lowersections modify this count % @raisesections: treat @section as chapter, @subsection as section, etc. \def\raisesections{\global\advance\secbase by -1} % @lowersections: treat @chapter as section, @section as subsection, etc. \def\lowersections{\global\advance\secbase by 1} % we only have subsub. \chardef\maxseclevel = 3 % % A numbered section within an unnumbered changes to unnumbered too. % To achieve this, remember the "biggest" unnum. sec. we are currently in: \chardef\unnlevel = \maxseclevel % % Trace whether the current chapter is an appendix or not: % \chapheadtype is "N" or "A", unnumbered chapters are ignored. \def\chapheadtype{N} % Choose a heading macro % #1 is heading type % #2 is heading level % #3 is text for heading \def\genhead#1#2#3{% % Compute the abs. sec. level: \absseclevel=#2 \advance\absseclevel by \secbase % Make sure \absseclevel doesn't fall outside the range: \ifnum \absseclevel < 0 \absseclevel = 0 \else \ifnum \absseclevel > 3 \absseclevel = 3 \fi \fi % The heading type: \def\headtype{#1}% \if \headtype U% \ifnum \absseclevel < \unnlevel \chardef\unnlevel = \absseclevel \fi \else % Check for appendix sections: \ifnum \absseclevel = 0 \edef\chapheadtype{\headtype}% \else \if \headtype A\if \chapheadtype N% \errmessage{@appendix... within a non-appendix chapter}% \fi\fi \fi % Check for numbered within unnumbered: \ifnum \absseclevel > \unnlevel \def\headtype{U}% \else \chardef\unnlevel = 3 \fi \fi % Now print the heading: \if \headtype U% \ifcase\absseclevel \unnumberedzzz{#3}% \or \unnumberedseczzz{#3}% \or \unnumberedsubseczzz{#3}% \or \unnumberedsubsubseczzz{#3}% \fi \else \if \headtype A% \ifcase\absseclevel \appendixzzz{#3}% \or \appendixsectionzzz{#3}% \or \appendixsubseczzz{#3}% \or \appendixsubsubseczzz{#3}% \fi \else \ifcase\absseclevel \chapterzzz{#3}% \or \seczzz{#3}% \or \numberedsubseczzz{#3}% \or \numberedsubsubseczzz{#3}% \fi \fi \fi \suppressfirstparagraphindent } % an interface: \def\numhead{\genhead N} \def\apphead{\genhead A} \def\unnmhead{\genhead U} % @chapter, @appendix, @unnumbered. Increment top-level counter, reset % all lower-level sectioning counters to zero. % % Also set \chaplevelprefix, which we prepend to @float sequence numbers % (e.g., figures), q.v. By default (before any chapter), that is empty. \let\chaplevelprefix = \empty % \outer\parseargdef\chapter{\numhead0{#1}} % normally numhead0 calls chapterzzz \def\chapterzzz#1{% % section resetting is \global in case the chapter is in a group, such % as an @include file. \global\secno=0 \global\subsecno=0 \global\subsubsecno=0 \global\advance\chapno by 1 % % Used for \float. \gdef\chaplevelprefix{\the\chapno.}% \resetallfloatnos % % \putwordChapter can contain complex things in translations. \toks0=\expandafter{\putwordChapter}% \message{\the\toks0 \space \the\chapno}% % % Write the actual heading. \chapmacro{#1}{Ynumbered}{\the\chapno}% % % So @section and the like are numbered underneath this chapter. \global\let\section = \numberedsec \global\let\subsection = \numberedsubsec \global\let\subsubsection = \numberedsubsubsec } \outer\parseargdef\appendix{\apphead0{#1}} % normally calls appendixzzz % \def\appendixzzz#1{% \global\secno=0 \global\subsecno=0 \global\subsubsecno=0 \global\advance\appendixno by 1 \gdef\chaplevelprefix{\appendixletter.}% \resetallfloatnos % % \putwordAppendix can contain complex things in translations. \toks0=\expandafter{\putwordAppendix}% \message{\the\toks0 \space \appendixletter}% % \chapmacro{#1}{Yappendix}{\appendixletter}% % \global\let\section = \appendixsec \global\let\subsection = \appendixsubsec \global\let\subsubsection = \appendixsubsubsec } % normally unnmhead0 calls unnumberedzzz: \outer\parseargdef\unnumbered{\unnmhead0{#1}} \def\unnumberedzzz#1{% \global\advance\unnumberedno by 1 % % Since an unnumbered has no number, no prefix for figures. \global\let\chaplevelprefix = \empty \resetallfloatnos % % This used to be simply \message{#1}, but TeX fully expands the % argument to \message. Therefore, if #1 contained @-commands, TeX % expanded them. For example, in `@unnumbered The @cite{Book}', TeX % expanded @cite (which turns out to cause errors because \cite is meant % to be executed, not expanded). % % Anyway, we don't want the fully-expanded definition of @cite to appear % as a result of the \message, we just want `@cite' itself. We use % \the to achieve this: TeX expands \the only once, % simply yielding the contents of . (We also do this for % the toc entries.) \toks0 = {#1}% \message{(\the\toks0)}% % \chapmacro{#1}{Ynothing}{\the\unnumberedno}% % \global\let\section = \unnumberedsec \global\let\subsection = \unnumberedsubsec \global\let\subsubsection = \unnumberedsubsubsec } % @centerchap is like @unnumbered, but the heading is centered. \outer\parseargdef\centerchap{% \let\centerparametersmaybe = \centerparameters \unnmhead0{#1}% \let\centerparametersmaybe = \relax } % @top is like @unnumbered. \let\top\unnumbered % Sections. % \outer\parseargdef\numberedsec{\numhead1{#1}} % normally calls seczzz \def\seczzz#1{% \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1 \sectionheading{#1}{sec}{Ynumbered}{\the\chapno.\the\secno}% } % normally calls appendixsectionzzz: \outer\parseargdef\appendixsection{\apphead1{#1}} \def\appendixsectionzzz#1{% \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1 \sectionheading{#1}{sec}{Yappendix}{\appendixletter.\the\secno}% } \let\appendixsec\appendixsection % normally calls unnumberedseczzz: \outer\parseargdef\unnumberedsec{\unnmhead1{#1}} \def\unnumberedseczzz#1{% \global\advance\unnumberedno by 1 \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno}% } % Subsections. % % normally calls numberedsubseczzz: \outer\parseargdef\numberedsubsec{\numhead2{#1}} \def\numberedsubseczzz#1{% \global\subsubsecno=0 \global\advance\subsecno by 1 \sectionheading{#1}{subsec}{Ynumbered}{\the\chapno.\the\secno.\the\subsecno}% } % normally calls appendixsubseczzz: \outer\parseargdef\appendixsubsec{\apphead2{#1}} \def\appendixsubseczzz#1{% \global\subsubsecno=0 \global\advance\subsecno by 1 \sectionheading{#1}{subsec}{Yappendix}% {\appendixletter.\the\secno.\the\subsecno}% } % normally calls unnumberedsubseczzz: \outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}} \def\unnumberedsubseczzz#1{% \global\advance\unnumberedno by 1 \sectionheading{#1}{subsec}{Ynothing}{\the\unnumberedno}% } % Subsubsections. % % normally numberedsubsubseczzz: \outer\parseargdef\numberedsubsubsec{\numhead3{#1}} \def\numberedsubsubseczzz#1{% \global\advance\subsubsecno by 1 \sectionheading{#1}{subsubsec}{Ynumbered}% {\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno}% } % normally appendixsubsubseczzz: \outer\parseargdef\appendixsubsubsec{\apphead3{#1}} \def\appendixsubsubseczzz#1{% \global\advance\subsubsecno by 1 \sectionheading{#1}{subsubsec}{Yappendix}% {\appendixletter.\the\secno.\the\subsecno.\the\subsubsecno}% } % normally unnumberedsubsubseczzz: \outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}} \def\unnumberedsubsubseczzz#1{% \global\advance\unnumberedno by 1 \sectionheading{#1}{subsubsec}{Ynothing}{\the\unnumberedno}% } % These macros control what the section commands do, according % to what kind of chapter we are in (ordinary, appendix, or unnumbered). % Define them by default for a numbered chapter. \let\section = \numberedsec \let\subsection = \numberedsubsec \let\subsubsection = \numberedsubsubsec % Define @majorheading, @heading and @subheading \def\majorheading{% {\advance\chapheadingskip by 10pt \chapbreak }% \parsearg\chapheadingzzz } \def\chapheading{\chapbreak \parsearg\chapheadingzzz} \def\chapheadingzzz#1{% \vbox{\chapfonts \raggedtitlesettings #1\par}% \nobreak\bigskip \nobreak \suppressfirstparagraphindent } % @heading, @subheading, @subsubheading. \parseargdef\heading{\sectionheading{#1}{sec}{Yomitfromtoc}{} \suppressfirstparagraphindent} \parseargdef\subheading{\sectionheading{#1}{subsec}{Yomitfromtoc}{} \suppressfirstparagraphindent} \parseargdef\subsubheading{\sectionheading{#1}{subsubsec}{Yomitfromtoc}{} \suppressfirstparagraphindent} % These macros generate a chapter, section, etc. heading only % (including whitespace, linebreaking, etc. around it), % given all the information in convenient, parsed form. % Args are the skip and penalty (usually negative) \def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi} % Parameter controlling skip before chapter headings (if needed) \newskip\chapheadingskip % Define plain chapter starts, and page on/off switching for it. \def\chapbreak{\dobreak \chapheadingskip {-4000}} % Start a new page \def\chappager{\par\vfill\supereject} % \chapoddpage - start on an odd page for a new chapter % Because \domark is called before \chapoddpage, the filler page will % get the headings for the next chapter, which is wrong. But we don't % care -- we just disable all headings on the filler page. \def\chapoddpage{% \chappager \ifodd\pageno \else \begingroup \headingsoff \null \chappager \endgroup \fi } \parseargdef\setchapternewpage{\csname CHAPPAG#1\endcsname\HEADINGSon} \def\CHAPPAGoff{% \global\let\contentsalignmacro = \chappager \global\let\pchapsepmacro=\chapbreak \global\def\HEADINGSon{\HEADINGSsinglechapoff}} \def\CHAPPAGon{% \global\let\contentsalignmacro = \chappager \global\let\pchapsepmacro=\chappager \global\def\HEADINGSon{\HEADINGSsingle}} \def\CHAPPAGodd{% \global\let\contentsalignmacro = \chapoddpage \global\let\pchapsepmacro=\chapoddpage \global\def\HEADINGSon{\HEADINGSdouble}} \setchapternewpage on % \chapmacro - Chapter opening. % % #1 is the text, #2 is the section type (Ynumbered, Ynothing, % Yappendix, Yomitfromtoc), #3 the chapter number. % Not used for @heading series. % % To test against our argument. \def\Ynothingkeyword{Ynothing} \def\Yappendixkeyword{Yappendix} \def\Yomitfromtockeyword{Yomitfromtoc} % % % Definitions for @thischapter. These can be overridden in translation % files. \def\thischapterAppendix{% \putwordAppendix{} \thischapternum: \thischaptername} \def\thischapterChapter{% \putwordChapter{} \thischapternum: \thischaptername} % % \def\chapmacro#1#2#3{% \expandafter\ifx\thisenv\titlepage\else \checkenv{}% chapters, etc., should not start inside an environment. \fi % Insert the first mark before the heading break (see notes for \domark). \let\prevchapterdefs=\currentchapterdefs \let\prevsectiondefs=\currentsectiondefs \gdef\currentsectiondefs{\gdef\thissectionname{}\gdef\thissectionnum{}% \gdef\thissection{}}% % \def\temptype{#2}% \ifx\temptype\Ynothingkeyword \gdef\currentchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}% \gdef\thischapter{\thischaptername}}% \else\ifx\temptype\Yomitfromtockeyword \gdef\currentchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}% \gdef\thischapter{}}% \else\ifx\temptype\Yappendixkeyword \toks0={#1}% \xdef\currentchapterdefs{% \gdef\noexpand\thischaptername{\the\toks0}% \gdef\noexpand\thischapternum{\appendixletter}% \let\noexpand\thischapter\noexpand\thischapterAppendix }% \else \toks0={#1}% \xdef\currentchapterdefs{% \gdef\noexpand\thischaptername{\the\toks0}% \gdef\noexpand\thischapternum{\the\chapno}% \let\noexpand\thischapter\noexpand\thischapterChapter }% \fi\fi\fi % % Output the mark. Pass it through \safewhatsit, to take care of % the preceding space. \safewhatsit\domark % % Insert the chapter heading break. \pchapsepmacro % % Now the second mark, after the heading break. No break points % between here and the heading. \let\prevchapterdefs=\currentchapterdefs \let\prevsectiondefs=\currentsectiondefs \domark % {% \chapfonts \rm \let\footnote=\errfootnoteheading % give better error message % % Have to define \currentsection before calling \donoderef, because the % xref code eventually uses it. On the other hand, it has to be called % after \pchapsepmacro, or the headline will change too soon. \gdef\currentsection{#1}% % % Only insert the separating space if we have a chapter/appendix % number, and don't print the unnumbered ``number''. \ifx\temptype\Ynothingkeyword \setbox0 = \hbox{}% \def\toctype{unnchap}% \else\ifx\temptype\Yomitfromtockeyword \setbox0 = \hbox{}% contents like unnumbered, but no toc entry \def\toctype{omit}% \else\ifx\temptype\Yappendixkeyword \setbox0 = \hbox{\putwordAppendix{} #3\enspace}% \def\toctype{app}% \else \setbox0 = \hbox{#3\enspace}% \def\toctype{numchap}% \fi\fi\fi % % Write the toc entry for this chapter. Must come before the % \donoderef, because we include the current node name in the toc % entry, and \donoderef resets it to empty. \writetocentry{\toctype}{#1}{#3}% % % For pdftex, we have to write out the node definition (aka, make % the pdfdest) after any page break, but before the actual text has % been typeset. If the destination for the pdf outline is after the % text, then jumping from the outline may wind up with the text not % being visible, for instance under high magnification. \donoderef{#2}% % % Typeset the actual heading. \nobreak % Avoid page breaks at the interline glue. \vbox{\raggedtitlesettings \hangindent=\wd0 \centerparametersmaybe \unhbox0 #1\par}% }% \nobreak\bigskip % no page break after a chapter title \nobreak } % @centerchap -- centered and unnumbered. \let\centerparametersmaybe = \relax \def\centerparameters{% \advance\rightskip by 3\rightskip \leftskip = \rightskip \parfillskip = 0pt } % Section titles. These macros combine the section number parts and % call the generic \sectionheading to do the printing. % \newskip\secheadingskip \def\secheadingbreak{\dobreak \secheadingskip{-1000}} % Subsection titles. \newskip\subsecheadingskip \def\subsecheadingbreak{\dobreak \subsecheadingskip{-500}} % Subsubsection titles. \def\subsubsecheadingskip{\subsecheadingskip} \def\subsubsecheadingbreak{\subsecheadingbreak} % Definition for @thissection. This can be overridden in translation % files. \def\thissectionDef{% \putwordSection{} \thissectionnum: \thissectionname} % % Print any size, any type, section title. % % #1 is the text of the title, % #2 is the section level (sec/subsec/subsubsec), % #3 is the section type (Ynumbered, Ynothing, Yappendix, Yomitfromtoc), % #4 is the section number. % \def\seckeyword{sec} % \def\sectionheading#1#2#3#4{% {% \def\sectionlevel{#2}% \def\temptype{#3}% % % It is ok for the @heading series commands to appear inside an % environment (it's been historically allowed, though the logic is % dubious), but not the others. \ifx\temptype\Yomitfromtockeyword\else \checkenv{}% non-@*heading should not be in an environment. \fi \let\footnote=\errfootnoteheading % % Switch to the right set of fonts. \csname #2fonts\endcsname \rm % % Insert first mark before the heading break (see notes for \domark). \let\prevsectiondefs=\currentsectiondefs \ifx\temptype\Ynothingkeyword \ifx\sectionlevel\seckeyword \gdef\currentsectiondefs{\gdef\thissectionname{#1}\gdef\thissectionnum{}% \gdef\thissection{\thissectionname}}% \fi \else\ifx\temptype\Yomitfromtockeyword % Don't redefine \thissection. \else\ifx\temptype\Yappendixkeyword \ifx\sectionlevel\seckeyword \toks0={#1}% \xdef\currentsectiondefs{% \gdef\noexpand\thissectionname{\the\toks0}% \gdef\noexpand\thissectionnum{#4}% \let\noexpand\thissection\noexpand\thissectionDef }% \fi \else \ifx\sectionlevel\seckeyword \toks0={#1}% \xdef\currentsectiondefs{% \gdef\noexpand\thissectionname{\the\toks0}% \gdef\noexpand\thissectionnum{#4}% \let\noexpand\thissection\noexpand\thissectionDef }% \fi \fi\fi\fi % % Go into vertical mode. Usually we'll already be there, but we % don't want the following whatsit to end up in a preceding paragraph % if the document didn't happen to have a blank line. \par % % Output the mark. Pass it through \safewhatsit, to take care of % the preceding space. \safewhatsit\domark % % Insert space above the heading. \csname #2headingbreak\endcsname % % Now the second mark, after the heading break. No break points % between here and the heading. \global\let\prevsectiondefs=\currentsectiondefs \domark % % Only insert the space after the number if we have a section number. \ifx\temptype\Ynothingkeyword \setbox0 = \hbox{}% \def\toctype{unn}% \gdef\currentsection{#1}% \else\ifx\temptype\Yomitfromtockeyword % for @headings -- no section number, don't include in toc, % and don't redefine \currentsection. \setbox0 = \hbox{}% \def\toctype{omit}% \let\sectionlevel=\empty \else\ifx\temptype\Yappendixkeyword \setbox0 = \hbox{#4\enspace}% \def\toctype{app}% \gdef\currentsection{#1}% \else \setbox0 = \hbox{#4\enspace}% \def\toctype{num}% \gdef\currentsection{#1}% \fi\fi\fi % % Write the toc entry (before \donoderef). See comments in \chapmacro. \writetocentry{\toctype\sectionlevel}{#1}{#4}% % % Write the node reference (= pdf destination for pdftex). % Again, see comments in \chapmacro. \donoderef{#3}% % % Interline glue will be inserted when the vbox is completed. % That glue will be a valid breakpoint for the page, since it'll be % preceded by a whatsit (usually from the \donoderef, or from the % \writetocentry if there was no node). We don't want to allow that % break, since then the whatsits could end up on page n while the % section is on page n+1, thus toc/etc. are wrong. Debian bug 276000. \nobreak % % Output the actual section heading. \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \ptexraggedright \hangindent=\wd0 % zero if no section number \unhbox0 #1}% }% % Add extra space after the heading -- half of whatever came above it. % Don't allow stretch, though. \kern .5 \csname #2headingskip\endcsname % % Do not let the kern be a potential breakpoint, as it would be if it % was followed by glue. \nobreak % % We'll almost certainly start a paragraph next, so don't let that % glue accumulate. (Not a breakpoint because it's preceded by a % discardable item.) However, when a paragraph is not started next % (\startdefun, \cartouche, \center, etc.), this needs to be wiped out % or the negative glue will cause weirdly wrong output, typically % obscuring the section heading with something else. \vskip-\parskip % % This is so the last item on the main vertical list is a known % \penalty > 10000, so \startdefun, etc., can recognize the situation % and do the needful. \penalty 10001 } \message{toc,} % Table of contents. \newwrite\tocfile % Write an entry to the toc file, opening it if necessary. % Called from @chapter, etc. % % Example usage: \writetocentry{sec}{Section Name}{\the\chapno.\the\secno} % We append the current node name (if any) and page number as additional % arguments for the \{chap,sec,...}entry macros which will eventually % read this. The node name is used in the pdf outlines as the % destination to jump to. % % We open the .toc file for writing here instead of at @setfilename (or % any other fixed time) so that @contents can be anywhere in the document. % But if #1 is `omit', then we don't do anything. This is used for the % table of contents chapter openings themselves. % \newif\iftocfileopened \def\omitkeyword{omit}% % \def\writetocentry#1#2#3{% \edef\writetoctype{#1}% \ifx\writetoctype\omitkeyword \else \iftocfileopened\else \immediate\openout\tocfile = \jobname.toc \global\tocfileopenedtrue \fi % \iflinks {\atdummies \edef\temp{% \write\tocfile{@#1entry{#2}{#3}{\lastnode}{\noexpand\folio}}}% \temp }% \fi \fi % % Tell \shipout to create a pdf destination on each page, if we're % writing pdf. These are used in the table of contents. We can't % just write one on every page because the title pages are numbered % 1 and 2 (the page numbers aren't printed), and so are the first % two pages of the document. Thus, we'd have two destinations named % `1', and two named `2'. \ifpdforxetex \global\pdfmakepagedesttrue \fi } % These characters do not print properly in the Computer Modern roman % fonts, so we must take special care. This is more or less redundant % with the Texinfo input format setup at the end of this file. % \def\activecatcodes{% \catcode`\"=\active \catcode`\$=\active \catcode`\<=\active \catcode`\>=\active \catcode`\\=\active \catcode`\^=\active \catcode`\_=\active \catcode`\|=\active \catcode`\~=\active } % Read the toc file, which is essentially Texinfo input. \def\readtocfile{% \setupdatafile \activecatcodes \input \tocreadfilename } % process toc file to find the maximum width of the section numbers for % each chapter \def\findsecnowidths{% \begingroup \setupdatafile \activecatcodes \secentryfonts % Redefinitions \def\numchapentry##1##2##3##4{% \def\curchapname{secnowidth-##2}% \curchapmax=0pt }% \let\appentry\numchapentry % \def\numsecentry##1##2##3##4{% \def\cursecname{secnowidth-##2}% \cursecmax=0pt % \setbox0=\hbox{##2}% \ifdim\wd0>\curchapmax \curchapmax=\wd0 \expandafter\xdef\csname\curchapname\endcsname{\the\wd0}% \fi }% \let\appsecentry\numsecentry % \def\numsubsecentry##1##2##3##4{% \def\curssecname{secnowidth-##2}% \curssecmax=0pt % \setbox0=\hbox{##2}% \ifdim\wd0>\cursecmax \cursecmax=\wd0 \expandafter\xdef\csname\cursecname\endcsname{\the\wd0}% \fi }% \let\appsubsecentry\numsubsecentry % \def\numsubsubsecentry##1##2##3##4{% \setbox0=\hbox{##2}% \ifdim\wd0>\curssecmax \curssecmax=\wd0 \expandafter\xdef\csname\curssecname\endcsname{\the\wd0}% \fi }% \let\appsubsubsecentry\numsubsubsecentry % % Discard any output by outputting to dummy vbox, in case the toc file % contains macros that we have not redefined above. \setbox\dummybox\vbox\bgroup \input \tocreadfilename\relax \egroup \endgroup } \newdimen\curchapmax \newdimen\cursecmax \newdimen\curssecmax % set #1 to the maximum section width for #2 \def\retrievesecnowidth#1#2{% \expandafter\let\expandafter\savedsecnowidth \csname secnowidth-#2\endcsname \ifx\savedsecnowidth\relax #1=0pt \else #1=\savedsecnowidth \fi } \newdimen\secnowidthchap \secnowidthchap=0pt \newdimen\secnowidthsec \secnowidthsec=0pt \newdimen\secnowidthssec \secnowidthssec=0pt \newskip\contentsrightmargin \contentsrightmargin=1in \newcount\savepageno \newcount\lastnegativepageno \lastnegativepageno = -1 % Prepare to read what we've written to \tocfile. % \def\startcontents#1{% % If @setchapternewpage on, and @headings double, the contents should % start on an odd page, unlike chapters. \contentsalignmacro \immediate\closeout\tocfile % % Don't need to put `Contents' or `Short Contents' in the headline. % It is abundantly clear what they are. \chapmacro{#1}{Yomitfromtoc}{}% % \savepageno = \pageno \begingroup % Set up to handle contents files properly. \raggedbottom % Worry more about breakpoints than the bottom. \entryrightmargin=\contentsrightmargin % Don't use the full line length. % % Roman numerals for page numbers. \ifnum \pageno>0 \global\pageno = \lastnegativepageno \fi \def\thistitle{}% no title in double-sided headings % Record where the Roman numerals started. \ifnum\romancount=0 \global\romancount=\pagecount \fi \linkentrytexttrue } % \raggedbottom in plain.tex hardcodes \topskip so override it \catcode`\@=11 \def\raggedbottom{\advance\topskip by 0pt plus60pt \r@ggedbottomtrue} \catcode`\@=\other % redefined for the two-volume lispref. We always output on % \jobname.toc even if this is redefined. % \def\tocreadfilename{\jobname.toc} % Normal (long) toc. % \def\contents{% \startcontents{\putwordTOC}% \openin 1 \tocreadfilename\space \ifeof 1 \else \findsecnowidths \readtocfile \fi \vfill \eject \contentsalignmacro % in case @setchapternewpage odd is in effect \ifeof 1 \else \pdfmakeoutlines \fi \closein 1 \endgroup \contentsendroman } % And just the chapters. \def\summarycontents{% \startcontents{\putwordShortTOC}% % \let\partentry = \shortpartentry \let\numchapentry = \shortchapentry \let\appentry = \shortchapentry \let\unnchapentry = \shortunnchapentry % We want a true roman here for the page numbers. \secfonts \let\rm=\shortcontrm \let\bf=\shortcontbf \let\sl=\shortcontsl \let\tt=\shortconttt \rm \hyphenpenalty = 10000 \advance\baselineskip by 1pt % Open it up a little. \extrasecnoskip=0.4pt \def\numsecentry##1##2##3##4{} \let\appsecentry = \numsecentry \let\unnsecentry = \numsecentry \let\numsubsecentry = \numsecentry \let\appsubsecentry = \numsecentry \let\unnsubsecentry = \numsecentry \let\numsubsubsecentry = \numsecentry \let\appsubsubsecentry = \numsecentry \let\unnsubsubsecentry = \numsecentry \openin 1 \tocreadfilename\space \ifeof 1 \else \readtocfile \fi \closein 1 \vfill \eject \contentsalignmacro % in case @setchapternewpage odd is in effect \endgroup \contentsendroman } \let\shortcontents = \summarycontents % Get ready to use Arabic numerals again \def\contentsendroman{% \lastnegativepageno = \pageno \global\pageno=1 \contentsendcount = \pagecount } % Typeset the label for a chapter or appendix for the short contents. % The arg is, e.g., `A' for an appendix, or `3' for a chapter. % \def\shortchaplabel#1{% % This space should be enough, since a single number is .5em, and the % widest letter (M) is 1em, at least in the Computer Modern fonts. % But use \hss just in case. % % We'd like to right-justify chapter numbers, but that looks strange % with appendix letters. And right-justifying numbers and % left-justifying letters looks strange when there is less than 10 % chapters. Have to read the whole toc once to know how many chapters % there are before deciding ... \hbox to 1em{#1\hss}% } % These macros generate individual entries in the table of contents, % and are read in from the *.toc file. % % The arguments are like: % \def\numchapentry#1#2#3#4 % #1 - the chapter or section name. % #2 - section number % #3 - level of section (e.g "chap", "sec") % #4 - page number % Parts, in the main contents. Replace the part number, which doesn't % exist, with an empty box. Let's hope all the numbers have the same width. % Also ignore the page number, which is conventionally not printed. \def\numeralbox{\setbox0=\hbox{8}\hbox to \wd0{\hfil}} \def\partentry#1#2#3#4{% % Add stretch and a bonus for breaking the page before the part heading. % This reduces the chance of the page being broken immediately after the % part heading, before a following chapter heading. \vskip 0pt plus 5\baselineskip \penalty-300 \vskip 0pt plus -5\baselineskip \dochapentry{#1}{\numeralbox}{}% } % % Parts, in the short toc. \def\shortpartentry#1#2#3#4{% \penalty-300 \vskip.5\baselineskip plus.15\baselineskip minus.1\baselineskip \shortchapentry{{\bf #1}}{\numeralbox}{}{}% } % Chapters, in the main contents. \def\numchapentry#1#2#3#4{% \retrievesecnowidth\secnowidthchap{#2}% \dochapentry{#1}{#2}{#4}% } % Chapters, in the short toc. \def\shortchapentry#1#2#3#4{% \tocentry{#1}{\shortchaplabel{#2}}{#4}% } % Appendices, in the main contents. % Need the word Appendix, and a fixed-size box. % \def\appendixbox#1{% % We use M since it's probably the widest letter. \setbox0 = \hbox{\putwordAppendix{} M}% \hbox to \wd0{\putwordAppendix{} #1\hss}} % \def\appentry#1#2#3#4{% \retrievesecnowidth\secnowidthchap{#2}% \dochapentry{\appendixbox{#2}\hskip.7em#1}{}{#4}% } % Unnumbered chapters. \def\unnchapentry#1#2#3#4{\dochapentry{#1}{}{#4}} \def\shortunnchapentry#1#2#3#4{\tocentry{#1}{}{#4}} % Sections. \def\numsecentry#1#2#3#4{\dosecentry{#1}{#2}{#4}} \def\numsecentry#1#2#3#4{% \retrievesecnowidth\secnowidthsec{#2}% \dosecentry{#1}{#2}{#4}% } \let\appsecentry=\numsecentry \def\unnsecentry#1#2#3#4{% \retrievesecnowidth\secnowidthsec{#2}% \dosecentry{#1}{}{#4}% } % Subsections. \def\numsubsecentry#1#2#3#4{% \retrievesecnowidth\secnowidthssec{#2}% \dosubsecentry{#1}{#2}{#4}% } \let\appsubsecentry=\numsubsecentry \def\unnsubsecentry#1#2#3#4{% \retrievesecnowidth\secnowidthssec{#2}% \dosubsecentry{#1}{}{#4}% } % And subsubsections. \def\numsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{#2}{#4}} \let\appsubsubsecentry=\numsubsubsecentry \def\unnsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{}{#4}} % This parameter controls the indentation of the various levels. % Same as \defaultparindent. \newdimen\tocindent \tocindent = 15pt % Now for the actual typesetting. In all these, #1 is the text, #2 is % a section number if present, and #3 is the page number. % % If the toc has to be broken over pages, we want it to be at chapters % if at all possible; hence the \penalty. \def\dochapentry#1#2#3{% \penalty-300 \vskip1\baselineskip plus.33\baselineskip minus.25\baselineskip \begingroup % Move the page numbers slightly to the right \advance\entryrightmargin by -0.05em \chapentryfonts \extrasecnoskip=0.4em % separate chapter number more \tocentry{#1}{#2}{#3}% \endgroup \nobreak\vskip .25\baselineskip plus.1\baselineskip } \def\dosecentry#1#2#3{\begingroup \secnowidth=\secnowidthchap \secentryfonts \leftskip=\tocindent \tocentry{#1}{#2}{#3}% \endgroup} \def\dosubsecentry#1#2#3{\begingroup \secnowidth=\secnowidthsec \subsecentryfonts \leftskip=2\tocindent \tocentry{#1}{#2}{#3}% \endgroup} \def\dosubsubsecentry#1#2#3{\begingroup \secnowidth=\secnowidthssec \subsubsecentryfonts \leftskip=3\tocindent \tocentry{#1}{#2}{#3}% \endgroup} % Used for the maximum width of a section number so we can align % section titles. \newdimen\secnowidth \secnowidth=0pt \newdimen\extrasecnoskip \extrasecnoskip=0pt % \tocentry{TITLE}{SEC NO}{PAGE} % \def\tocentry#1#2#3{% \def\secno{#2}% \ifx\empty\secno \entry{#1}{#3}% \else \ifdim 0pt=\secnowidth \setbox0=\hbox{#2\hskip\labelspace\hskip\extrasecnoskip}% \else \advance\secnowidth by \labelspace \advance\secnowidth by \extrasecnoskip \setbox0=\hbox to \secnowidth{% #2\hskip\labelspace\hskip\extrasecnoskip\hfill}% \fi \entrycontskip=\wd0 \entry{\box0 #1}{#3}% \fi } \newdimen\labelspace \labelspace=0.6em \def\chapentryfonts{\secfonts \rm} \def\secentryfonts{\textfonts} \def\subsecentryfonts{\textfonts} \def\subsubsecentryfonts{\textfonts} \message{environments,} % @foo ... @end foo. % @tex ... @end tex escapes into raw TeX temporarily. % One exception: @ is still an escape character, so that @end tex works. % But \@ or @@ will get a plain @ character. \envdef\tex{% \setregularquotes \catcode `\\=0 \catcode `\{=1 \catcode `\}=2 \catcode `\$=3 \catcode `\&=4 \catcode `\#=6 \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie \catcode `\%=14 \catcode `\+=\other \catcode `\"=\other \catcode `\|=\other \catcode `\<=\other \catcode `\>=\other \catcode `\`=\other \catcode `\'=\other % % ' is active in math mode (mathcode"8000). So reset it, and all our % other math active characters (just in case), to plain's definitions. \mathactive % % Inverse of the list at the beginning of the file. \let\b=\ptexb \let\bullet=\ptexbullet \let\c=\ptexc \let\,=\ptexcomma \let\.=\ptexdot \let\dots=\ptexdots \let\equiv=\ptexequiv \let\!=\ptexexclam \let\i=\ptexi \let\indent=\ptexindent \let\noindent=\ptexnoindent \let\{=\ptexlbrace \let\+=\tabalign \let\}=\ptexrbrace \let\/=\ptexslash \let\sp=\ptexsp \let\*=\ptexstar %\let\sup=\ptexsup % do not redefine, we want @sup to work in math mode \let\t=\ptext \expandafter \let\csname top\endcsname=\ptextop % we've made it outer \let\frenchspacing=\plainfrenchspacing % \def\endldots{\mathinner{\ldots\ldots\ldots\ldots}}% \def\enddots{\relax\ifmmode\endldots\else$\mathsurround=0pt \endldots\,$\fi}% \def\@{@}% } % There is no need to define \Etex. % Define @lisp ... @end lisp. % @lisp environment forms a group so it can rebind things, % including the definition of @end lisp (which normally is erroneous). % Amount to narrow the margins by for @lisp. \newskip\lispnarrowing \lispnarrowing=0.4in % This is the definition that ^^M gets inside @lisp, @example, and other % such environments. \null is better than a space, since it doesn't % have any width. \def\lisppar{\null\endgraf} % This space is always present above and below environments. \newskip\envskipamount \envskipamount = 0pt % Make spacing and below environment symmetrical. We use \parskip here % to help in doing that, since in @example-like environments \parskip % is reset to zero; thus the \afterenvbreak inserts no space -- but the % start of the next paragraph will insert \parskip. % \def\aboveenvbreak{{% % =10000 instead of <10000 because of a special case in \itemzzz and % \sectionheading, q.v. \ifnum \lastpenalty=10000 \else \advance\envskipamount by \parskip \endgraf \ifdim\lastskip<\envskipamount \removelastskip \ifnum\lastpenalty<10000 % Penalize breaking before the environment, because preceding text % often leads into it. \penalty100 \fi \vskip\envskipamount \fi \fi }} \def\afterenvbreak{{% % =10000 instead of <10000 because of a special case in \itemzzz and % \sectionheading, q.v. \ifnum \lastpenalty=10000 \else \advance\envskipamount by \parskip \endgraf \ifdim\lastskip<\envskipamount \removelastskip % it's not a good place to break if the last penalty was \nobreak % or better ... \ifnum\lastpenalty<10000 \penalty-50 \fi \vskip\envskipamount \fi \fi }} % \nonarrowing is a flag. If "set", @lisp etc don't narrow margins; it will % also clear it, so that its embedded environments do the narrowing again. \let\nonarrowing=\relax % @cartouche ... @end cartouche: draw rectangle w/rounded corners around % environment contents. % \def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth \def\ctr{{\hskip 6pt\circle\char'010}} \def\cbl{{\circle\char'012\hskip -6pt}} \def\cbr{{\hskip 6pt\circle\char'011}} \def\carttop{\hbox to \cartouter{\hskip\lskip \ctl\leaders\hrule height\circthick\hfil\ctr \hskip\rskip}} \def\cartbot{\hbox to \cartouter{\hskip\lskip \cbl\leaders\hrule height\circthick\hfil\cbr \hskip\rskip}} % \newskip\lskip\newskip\rskip % only require the font if @cartouche is actually used \def\cartouchefontdefs{% \font\circle=lcircle10\relax \circthick=\fontdimen8\circle } \newdimen\circthick \newdimen\cartouter\newdimen\cartinner \newskip\normbskip\newskip\normpskip\newskip\normlskip \envparseargdef\cartouche{% \cartouchefontdefs \ifhmode\par\fi % can't be in the midst of a paragraph. \startsavinginserts \lskip=\leftskip \rskip=\rightskip \leftskip=0pt\rightskip=0pt % we want these *outside*. % % Set paragraph width for text inside cartouche. There are % left and right margins of 3pt each plus two vrules 0.4pt each. \cartinner=\hsize \advance\cartinner by-\lskip \advance\cartinner by-\rskip \advance\cartinner by -6.8pt % % For drawing top and bottom of cartouche. Each corner char % adds 6pt and we take off the width of a rule to line up with the % right boundary perfectly. \cartouter=\hsize \advance\cartouter by 11.6pt % \normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip % % If this cartouche directly follows a sectioning command, we need the % \parskip glue (backspaced over by default) or the cartouche can % collide with the section heading. \ifnum\lastpenalty>10000 \vskip\parskip \penalty\lastpenalty \fi % \setbox\groupbox=\vtop\bgroup \baselineskip=0pt\parskip=0pt\lineskip=0pt \carttop \hbox\bgroup \hskip\lskip \vrule\kern3pt \vbox\bgroup \hsize=\cartinner \baselineskip=\normbskip \lineskip=\normlskip \parskip=\normpskip \def\arg{#1}% \ifx\arg\empty\else \centerV{\hfil \bf #1 \hfil}% \fi \kern3pt \vskip -\parskip } \def\Ecartouche{% \ifhmode\par\fi \kern3pt \egroup \kern3pt\vrule \hskip\rskip \egroup \cartbot \egroup \addgroupbox \checkinserts } % This macro is called at the beginning of all the @example variants, % inside a group. \newdimen\nonfillparindent \def\nonfillstart{% \aboveenvbreak \ifdim\hfuzz < 12pt \hfuzz = 12pt \fi % Don't be fussy \sepspaces % Make spaces be word-separators rather than space tokens. \let\par = \lisppar % don't ignore blank lines \obeylines % each line of input is a line of output \parskip = 0pt % Turn off paragraph indentation but redefine \indent to emulate % the normal \indent. \nonfillparindent=\parindent \parindent = 0pt \let\indent\nonfillindent % \emergencystretch = 0pt % don't try to avoid overfull boxes \ifx\nonarrowing\relax \advance \leftskip by \lispnarrowing \exdentamount=\lispnarrowing \else \let\nonarrowing = \relax \fi \let\exdent=\nofillexdent } \begingroup \obeyspaces % We want to swallow spaces (but not other tokens) after the fake % @indent in our nonfill-environments, where spaces are normally % active and set to @tie, resulting in them not being ignored after % @indent. \gdef\nonfillindent{\futurelet\temp\nonfillindentcheck}% \gdef\nonfillindentcheck{% \ifx\temp % \expandafter\nonfillindentgobble% \else% \leavevmode\nonfillindentbox% \fi% }% \endgroup \def\nonfillindentgobble#1{\nonfillindent} \def\nonfillindentbox{\hbox to \nonfillparindent{\hss}} % If you want all examples etc. small: @set dispenvsize small. % If you want even small examples the full size: @set dispenvsize nosmall. % This affects the following displayed environments: % @example, @display, @format, @lisp, @verbatim % \def\smallword{small} \def\nosmallword{nosmall} \let\SETdispenvsize\relax \def\setnormaldispenv{% \ifx\SETdispenvsize\smallword % end paragraph for sake of leading, in case document has no blank % line. This is redundant with what happens in \aboveenvbreak, but % we need to do it before changing the fonts, and it's inconvenient % to change the fonts afterward. \ifnum \lastpenalty=10000 \else \endgraf \fi \smallexamplefonts \rm \fi } \def\setsmalldispenv{% \ifx\SETdispenvsize\nosmallword \else \ifnum \lastpenalty=10000 \else \endgraf \fi \smallexamplefonts \rm \fi } % We often define two environments, @foo and @smallfoo. % Let's do it in one command. #1 is the env name, #2 the definition. \def\makedispenvdef#1#2{% \expandafter\envdef\csname#1\endcsname {\setnormaldispenv #2}% \expandafter\envdef\csname small#1\endcsname {\setsmalldispenv #2}% \expandafter\let\csname E#1\endcsname \afterenvbreak \expandafter\let\csname Esmall#1\endcsname \afterenvbreak } % Define two environment synonyms (#1 and #2) for an environment. \def\maketwodispenvdef#1#2#3{% \makedispenvdef{#1}{#3}% \makedispenvdef{#2}{#3}% } % % @lisp: indented, narrowed, typewriter font; % @example: same as @lisp. % % @smallexample and @smalllisp: use smaller fonts. % Originally contributed by Pavel@xerox. % \maketwodispenvdef{lisp}{example}{% \nonfillstart \tt\setcodequotes \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special. \parsearg\gobble } % @display/@smalldisplay: same as @lisp except keep current font. % \makedispenvdef{display}{% \nonfillstart \gobble } % @format/@smallformat: same as @display except don't narrow margins. % \makedispenvdef{format}{% \let\nonarrowing = t% \nonfillstart \gobble } % @flushleft: same as @format, but doesn't obey \SETdispenvsize. \envdef\flushleft{% \let\nonarrowing = t% \nonfillstart \gobble } \let\Eflushleft = \afterenvbreak % @flushright. % \envdef\flushright{% \let\nonarrowing = t% \nonfillstart \advance\leftskip by 0pt plus 1fill\relax \gobble } \let\Eflushright = \afterenvbreak % @raggedright does more-or-less normal line breaking but no right % justification. From plain.tex. \envdef\raggedright{% \rightskip0pt plus2.4em \spaceskip.3333em \xspaceskip.5em\relax } \let\Eraggedright\par % @quotation does normal linebreaking (hence we can't use \nonfillstart) % and narrows the margins. We keep \parskip nonzero in general, since % we're doing normal filling. So, when using \aboveenvbreak and % \afterenvbreak, temporarily make \parskip 0. % \makedispenvdef{quotation}{\quotationstart} % \def\quotationstart{% \indentedblockstart % same as \indentedblock, but increase right margin too. \ifx\nonarrowing\relax \advance\rightskip by \lispnarrowing \fi \parsearg\quotationlabel } % We have retained a nonzero parskip for the environment, since we're % doing normal filling. % \def\Equotation{% \par \ifx\quotationauthor\thisisundefined\else % indent a bit. \leftline{\kern 2\leftskip \sl ---\quotationauthor}% \fi {\parskip=0pt \afterenvbreak}% } \def\Esmallquotation{\Equotation} % If we're given an argument, typeset it in bold with a colon after. \def\quotationlabel#1{% \def\temp{#1}% \ifx\temp\empty \else {\bf #1: }% \fi } % @indentedblock is like @quotation, but indents only on the left and % has no optional argument. % \makedispenvdef{indentedblock}{\indentedblockstart} % \def\indentedblockstart{% {\parskip=0pt \aboveenvbreak}% because \aboveenvbreak inserts \parskip \parindent=0pt % % @cartouche defines \nonarrowing to inhibit narrowing at next level down. \ifx\nonarrowing\relax \advance\leftskip by \lispnarrowing \exdentamount = \lispnarrowing \else \let\nonarrowing = \relax \fi } % Keep a nonzero parskip for the environment, since we're doing normal filling. % \def\Eindentedblock{% \par {\parskip=0pt \afterenvbreak}% } \def\Esmallindentedblock{\Eindentedblock} % LaTeX-like @verbatim...@end verbatim and @verb{...} % If we want to allow any as delimiter, % we need the curly braces so that makeinfo sees the @verb command, eg: % `@verbx...x' would look like the '@verbx' command. --janneke@gnu.org % % [Knuth]: Donald Ervin Knuth, 1996. The TeXbook. % % [Knuth] p.344; only we need to do the other characters Texinfo sets % active too. Otherwise, they get lost as the first character on a % verbatim line. \def\dospecials{% \do\ \do\\\do\{\do\}\do\$\do\&% \do\#\do\^\do\^^K\do\_\do\^^A\do\%\do\~% \do\<\do\>\do\|\do\@\do+\do\"% % Don't do the quotes -- if we do, @set txicodequoteundirected and % @set txicodequotebacktick will not have effect on @verb and % @verbatim, and ?` and !` ligatures won't get disabled. %\do\`\do\'% } % % [Knuth] p. 380 \def\uncatcodespecials{% \def\do##1{\catcode`##1=\other}\dospecials} % % Setup for the @verb command. % % Eight spaces for a tab \begingroup \catcode`\^^I=\active \gdef\tabeightspaces{\catcode`\^^I=\active\def^^I{\ \ \ \ \ \ \ \ }} \endgroup % \def\setupverb{% \tt \def\par{\leavevmode\endgraf}% \parindent = 0pt \setcodequotes \tabeightspaces % Respect line breaks, % print special symbols as themselves, and % make each space count % must do in this order: \obeylines \uncatcodespecials \sepspaces } % Setup for the @verbatim environment % % Real tab expansion. \newdimen\tabw \setbox0=\hbox{\tt\space} \tabw=8\wd0 % tab amount % % We typeset each line of the verbatim in an \hbox, so we can handle % tabs. \newbox\verbbox \def\starttabbox{\setbox\verbbox=\hbox\bgroup} % \begingroup \catcode`\^^I=\active \gdef\tabexpand{% \catcode`\^^I=\active \def^^I{\leavevmode\egroup \dimen\verbbox=\wd\verbbox % the width so far, or since the previous tab \divide\dimen\verbbox by\tabw \multiply\dimen\verbbox by\tabw % compute previous multiple of \tabw \advance\dimen\verbbox by\tabw % advance to next multiple of \tabw \wd\verbbox=\dimen\verbbox \leavevmode\box\verbbox \starttabbox }% } \endgroup % start the verbatim environment. \def\setupverbatim{% \let\nonarrowing = t% \nonfillstart \tt % easiest (and conventionally used) font for verbatim \def\par{\egroup\leavevmode\box\verbbox\endgraf\starttabbox}% \tabexpand \setcodequotes % Respect line breaks, % print special symbols as themselves, and % make each space count. % Must do in this order: \obeylines \uncatcodespecials \sepspaces } % Do the @verb magic: verbatim text is quoted by unique % delimiter characters. Before first delimiter expect a % right brace, after last delimiter expect closing brace: % % \def\doverb'{'#1'}'{#1} % % [Knuth] p. 382; only eat outer {} \begingroup \catcode`[=1\catcode`]=2\catcode`\{=\other\catcode`\}=\other \gdef\doverb{#1[\def\next##1#1}[##1\endgroup]\next] \endgroup % \def\verb{\begingroup\setupverb\doverb} % % % Do the @verbatim magic: define the macro \doverbatim so that % the (first) argument ends when '@end verbatim' is reached, ie: % % \def\doverbatim#1@end verbatim{#1} % % For Texinfo it's a lot easier than for LaTeX, % because texinfo's \verbatim doesn't stop at '\end{verbatim}': % we need not redefine '\', '{' and '}'. % % Inspired by LaTeX's verbatim command set [latex.ltx] % \begingroup \catcode`\ =\active \obeylines % % ignore everything up to the first ^^M, that's the newline at the end % of the @verbatim input line itself. Otherwise we get an extra blank % line in the output. \xdef\doverbatim#1^^M#2@end verbatim{% \starttabbox#2\egroup\noexpand\end\gobble verbatim}% % We really want {...\end verbatim} in the body of the macro, but % without the active space; thus we have to use \xdef and \gobble. % The \egroup ends the \verbbox started at the end of the last line in % the block. \endgroup % \envdef\verbatim{% \setnormaldispenv\setupverbatim\doverbatim } \let\Everbatim = \afterenvbreak % @verbatiminclude FILE - insert text of file in verbatim environment. % \def\verbatiminclude{\parseargusing\filenamecatcodes\doverbatiminclude} % \def\doverbatiminclude#1{% {% \makevalueexpandable \setupverbatim {% \indexnofonts % Allow `@@' and other weird things in file names. \wlog{texinfo.tex: doing @verbatiminclude of #1^^J}% \edef\tmp{\noexpand\input #1 } \expandafter }\expandafter\starttabbox\tmp\egroup \afterenvbreak }% } % @copying ... @end copying. % Save the text away for @insertcopying later. % % We save the uninterpreted tokens, rather than creating a box. % Saving the text in a box would be much easier, but then all the % typesetting commands (@smallbook, font changes, etc.) have to be done % beforehand -- and a) we want @copying to be done first in the source % file; b) letting users define the frontmatter in as flexible order as % possible is desirable. % \def\copying{\checkenv{}\begingroup\macrobodyctxt\docopying} {\catcode`\ =\other \gdef\docopying#1@end copying{\endgroup\def\copyingtext{#1}} } \def\insertcopying{% \begingroup \parindent = 0pt % paragraph indentation looks wrong on title page \scanexp\copyingtext \endgroup } \message{defuns,} % @defun etc. \newskip\defbodyindent \defbodyindent=.4in \newskip\defargsindent \defargsindent=50pt \newskip\deflastargmargin \deflastargmargin=18pt \newcount\defunpenalty % Start the processing of @deffn: \def\startdefun{% \ifnum\lastpenalty<10000 \medbreak \defunpenalty=10003 % Will keep this @deffn together with the % following @def command, see below. \else % If there are two @def commands in a row, we'll have a \nobreak, % which is there to keep the function description together with its % header. But if there's nothing but headers, we need to allow a % break somewhere. Check specifically for penalty 10002, inserted % by \printdefunline, instead of 10000, since the sectioning % commands also insert a nobreak penalty, and we don't want to allow % a break between a section heading and a defun. % % As a further refinement, we avoid "club" headers by signalling % with penalty of 10003 after the very first @deffn in the % sequence (see above), and penalty of 10002 after any following % @def command. \ifnum\lastpenalty=10002 \penalty2000 \else \defunpenalty=10002 \fi % % Similarly, after a section heading, do not allow a break. % But do insert the glue. \medskip % preceded by discardable penalty, so not a breakpoint \fi % \parindent=0in \advance\leftskip by \defbodyindent \exdentamount=\defbodyindent } % Called as \printdefunline \deffooheader{text} % \def\printdefunline#1#2{% \begingroup \plainfrenchspacing % call \deffooheader: #1#2 \endheader % common ending: \interlinepenalty = 10000 \advance\rightskip by 0pt plus 1fil\relax \endgraf \nobreak\vskip -\parskip \penalty\defunpenalty % signal to \startdefun and \deffoox % Some of the @defun-type tags do not enable magic parentheses, % rendering the following check redundant. But we don't optimize. \checkparencounts \endgroup } \def\Edefun{\endgraf\medbreak} % @defblock, @defline do not automatically create index entries \envdef\defblock{% \startdefun } \let\Edefblock\Edefun \def\defline{% \doingtypefnfalse \parseargusing\activeparens{\printdefunline\deflineheader}% } \def\deflineheader#1 #2 #3\endheader{% \printdefname{#1}{}{#2}\magicamp\defunargs{#3\unskip}% } \def\deftypeline{% \doingtypefntrue \parseargusing\activeparens{\printdefunline\deftypelineheader}% } \def\deftypelineheader#1 #2 #3 #4\endheader{% \printdefname{#1}{#2}{#3}\magicamp\defunargs{#4\unskip}% } % \makedefun{deffoo} (\deffooheader parameters) { (\deffooheader expansion) } % % Define \deffoo, \deffoox \Edeffoo and \deffooheader. \def\makedefun#1{% \expandafter\let\csname E#1\endcsname = \Edefun \edef\temp{\noexpand\domakedefun \makecsname{#1}\makecsname{#1x}\makecsname{#1header}}% \temp } \def\domakedefun#1#2#3{% \envdef#1{% \startdefun \doingtypefnfalse % distinguish typed functions from all else \parseargusing\activeparens{\printdefunline#3}% }% \def#2{% % First, check whether we are in the right environment: \checkenv#1% % % As in \startdefun, allow line break if we have multiple x headers % in a row. It's not a great place, though. \ifnum\lastpenalty=10002 \penalty3000 \else \defunpenalty=10002 \fi % \doingtypefnfalse % distinguish typed functions from all else \parseargusing\activeparens{\printdefunline#3}% }% \def#3% definition of \deffooheader follows } \newif\ifdoingtypefn % doing typed function? \newif\ifrettypeownline % typeset return type on its own line? % @deftypefnnewline on|off says whether the return type of typed functions % are printed on their own line. This affects @deftypefn, @deftypefun, % @deftypeop, and @deftypemethod. % \parseargdef\deftypefnnewline{% \def\temp{#1}% \ifx\temp\onword \expandafter\let\csname SETtxideftypefnnl\endcsname = \empty \else\ifx\temp\offword \expandafter\let\csname SETtxideftypefnnl\endcsname = \relax \else \errhelp = \EMsimple \errmessage{Unknown @txideftypefnnl value `\temp', must be on|off}% \fi\fi } % Untyped functions: % @deffn category name args \makedefun{deffn}#1 #2 #3\endheader{% \doind{fn}{\code{#2}}% \printdefname{#1}{}{#2}\magicamp\defunargs{#3\unskip}% } % @defop category class name args \makedefun{defop}#1 {\defopheaderx{#1\ \putwordon}} \def\defopheaderx#1#2 #3 #4\endheader{% \doind{fn}{\code{#3}\space\putwordon\ \code{#2}}% \printdefname{#1\ \code{#2}}{}{#3}\magicamp\defunargs{#4\unskip}% } % Typed functions: % @deftypefn category type name args \makedefun{deftypefn}#1 #2 #3 #4\endheader{% \doind{fn}{\code{#3}}% \doingtypefntrue \printdefname{#1}{#2}{#3}\defunargs{#4\unskip}% } % @deftypeop category class type name args \makedefun{deftypeop}#1 {\deftypeopheaderx{#1\ \putwordon}} \def\deftypeopheaderx#1#2 #3 #4 #5\endheader{% \doind{fn}{\code{#4}\space\putwordon\ \code{#1\ \code{#2}}}% \doingtypefntrue \printdefname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}% } % Typed variables: % @deftypevr category type var args \makedefun{deftypevr}#1 #2 #3 #4\endheader{% \doind{vr}{\code{#3}}% \printdefname{#1}{#2}{#3}\defunargs{#4\unskip}% } % @deftypecv category class type var args \makedefun{deftypecv}#1 {\deftypecvheaderx{#1\ \putwordof}} \def\deftypecvheaderx#1#2 #3 #4 #5\endheader{% \doind{vr}{\code{#4}\space\putwordof\ \code{#2}}% \printdefname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}% } % Untyped variables: % @defvr category var args \makedefun{defvr}#1 {\deftypevrheader{#1} {} } % @defcv category class var args \makedefun{defcv}#1 {\defcvheaderx{#1\ \putwordof}} \def\defcvheaderx#1#2 {\deftypecvheaderx{#1}#2 {} } % Types: % @deftp category name args \makedefun{deftp}#1 #2 #3\endheader{% \doind{tp}{\code{#2}}% \printdefname{#1}{}{#2}\defunargs{#3\unskip}% } % Remaining @defun-like shortcuts: \makedefun{defun}{\deffnheader{\putwordDeffunc} } \makedefun{defmac}{\deffnheader{\putwordDefmac} } \makedefun{defspec}{\deffnheader{\putwordDefspec} } \makedefun{deftypefun}{\deftypefnheader{\putwordDeffunc} } \makedefun{defvar}{\defvrheader{\putwordDefvar} } \makedefun{defopt}{\defvrheader{\putwordDefopt} } \makedefun{deftypevar}{\deftypevrheader{\putwordDefvar} } \makedefun{defmethod}{\defopheaderx\putwordMethodon} \makedefun{deftypemethod}{\deftypeopheaderx\putwordMethodon} \makedefun{defivar}{\defcvheaderx\putwordInstanceVariableof} \makedefun{deftypeivar}{\deftypecvheaderx\putwordInstanceVariableof} % \printdefname, which formats the name of the @def (not the args). % #1 is the category, such as "Function". % #2 is the return type, if any. % #3 is the function name. % % We are followed by (but not passed) the arguments, if any. % \def\printdefname#1#2#3{% \par % Get the values of \leftskip and \rightskip as they were outside the @def... \advance\leftskip by -\defbodyindent % % Determine if we are typesetting the return type of a typed function % on a line by itself. \rettypeownlinefalse \ifdoingtypefn % doing a typed function specifically? % then check user option for putting return type on its own line: \ifflagclear{txideftypefnnl}{}{\rettypeownlinetrue}% \fi % % How we'll format the category name. Putting it in brackets helps % distinguish it from the body text that may end up on the next line % just below it. \def\temp{#1}% \setbox0=\hbox{\kern\deflastargmargin \ifx\temp\empty\else [\rm\temp]\fi} % % Figure out line sizes for the paragraph shape. We'll always have at % least two. \tempnum = 2 % % The first line needs space for \box0; but if \rightskip is nonzero, % we need only space for the part of \box0 which exceeds it: \dimen0=\hsize \advance\dimen0 by -\wd0 \advance\dimen0 by \rightskip % % If doing a return type on its own line, we'll have another line. \ifrettypeownline \advance\tempnum by 1 \def\maybeshapeline{0in \hsize}% \else \def\maybeshapeline{}% \fi % % The continuations: \dimen2=\hsize \advance\dimen2 by -\defargsindent % % The final paragraph shape: \parshape \tempnum 0in \dimen0 \maybeshapeline \defargsindent \dimen2 % % Put the category name at the right margin. \noindent \hbox to 0pt{% \hfil\box0 \kern-\hsize % \hsize has to be shortened this way: \kern\leftskip % Intentionally do not respect \rightskip, since we need the space. }% % % Allow all lines to be underfull without complaint: \tolerance=10000 \hbadness=10000 \exdentamount=\defbodyindent {% \def\^^M{}% for line continuation % % defun fonts. We use typewriter by default (used to be bold) because: % . we're printing identifiers, they should be in tt in principle. % . in languages with many accents, such as Czech or French, it's % common to leave accents off identifiers. The result looks ok in % tt, but exceedingly strange in rm. % . we don't want -- and --- to be treated as ligatures. % . this still does not fix the ?` and !` ligatures, but so far no % one has made identifiers using them :). \df \tt \def\temp{#2}% text of the return type \ifx\temp\empty\else \tclose{\temp}% typeset the return type \ifrettypeownline % put return type on its own line; prohibit line break following: \hfil\vadjust{\nobreak}\break \else \space % type on same line, so just followed by a space \fi \fi % no return type #3% output function name }% \ifflagclear{txidefnamenospace}{% {\rm\enskip}% hskip 0.5 em of \rmfont }{}% % \boldbrax % arguments will be output next, if any. } % Print arguments. Use slanted for @def*, typewriter for @deftype*. \def\defunargs#1{% \bgroup \def\^^M{}% for line continuation \df \ifdoingtypefn \tt \else \sl \fi \ifflagclear{txicodevaristt}{}% {\def\var##1{{\setregularquotes \ttsl ##1}}}% #1% \egroup } % We want ()&[] to print specially on the defun line. % \def\activeparens{% \catcode`\(=\active \catcode`\)=\active \catcode`\[=\active \catcode`\]=\active \catcode`\&=\active } % Make control sequences which act like normal parenthesis chars. \let\lparen = ( \let\rparen = ) % Be sure that we always have a definition for `(', etc. For example, % if the fn name has parens in it, \boldbrax will not be in effect yet, % so TeX would otherwise complain about undefined control sequence. { \activeparens \gdef\defcharsdefault{% \let(=\lparen \let)=\rparen \let[=\lbrack \let]=\rbrack \let& = \&% } \globaldefs=1 \defcharsdefault \gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb} \gdef\magicamp{\let&=\amprm} } \let\ampchar\& \newcount\parencount % If we encounter &foo, then turn on ()-hacking afterwards \newif\ifampseen \def\amprm#1 {\ampseentrue{\rm\ }} \def\parenfont{% \ifampseen % At the first level, print parens in roman, % otherwise use the default font. \ifnum \parencount=1 \rm \fi \else % The \sf parens (in \boldbrax) actually are a little bolder than % the contained text. This is especially needed for [ and ] . \sf \fi } \def\infirstlevel#1{% \ifampseen \ifnum\parencount=1 #1% \fi \fi } \def\bfafterword#1 {#1 \bf} \def\opnr{% \global\advance\parencount by 1 {\parenfont(}% \infirstlevel \bfafterword } \def\clnr{% {\parenfont)}% \infirstlevel \sl \global\advance\parencount by -1 } \newcount\brackcount \def\lbrb{% \global\advance\brackcount by 1 {\bf[}% } \def\rbrb{% {\bf]}% \global\advance\brackcount by -1 } \def\checkparencounts{% \ifnum\parencount=0 \else \badparencount \fi \ifnum\brackcount=0 \else \badbrackcount \fi } % these should not use \errmessage; the glibc manual, at least, actually % has such constructs (when documenting function pointers). \def\badparencount{% \message{Warning: unbalanced parentheses in @def...}% \global\parencount=0 } \def\badbrackcount{% \message{Warning: unbalanced square brackets in @def...}% \global\brackcount=0 } \message{macros,} % @macro. % To do this right we need a feature of e-TeX, \scantokens, % which we arrange to emulate with a temporary file in ordinary TeX. \ifx\eTeXversion\thisisundefined \newwrite\macscribble \def\scantokens#1{% \toks0={#1}% \immediate\openout\macscribble=\jobname.tmp \immediate\write\macscribble{\the\toks0}% \immediate\closeout\macscribble \input \jobname.tmp } \fi \let\E=\expandafter % Used at the time of macro expansion. % Argument is macro body with arguments substituted \def\scanmacro#1{% \newlinechar`\^^M % expand the expansion of \eatleadingcr twice to maybe remove a leading % newline (and \else and \fi tokens), then call \eatspaces on the result. \def\xeatspaces##1{% \E\E\E\E\E\E\E\eatspaces\E\E\E\E\E\E\E{\eatleadingcr##1% }}% \def\xempty##1{}% % % Process the macro body under the current catcode regime. \scantokens{#1@comment}% % % The \comment is to remove the \newlinechar added by \scantokens, and % can be noticed by \parsearg. Note \c isn't used because this means cedilla % in math mode. } % Used for copying and captions \def\scanexp#1{% \expandafter\scanmacro\expandafter{#1}% } \newcount\paramno % Count of parameters \newtoks\macname % Macro name \newif\ifrecursive % Is it recursive? % List of all defined macros in the form % \commondummyword\macro1\commondummyword\macro2... % Currently is also contains all @aliases; the list can be split % if there is a need. \def\macrolist{} % Add the macro to \macrolist \def\addtomacrolist#1{\expandafter \addtomacrolistxxx \csname#1\endcsname} \def\addtomacrolistxxx#1{% \toks0 = \expandafter{\macrolist\commondummyword#1}% \xdef\macrolist{\the\toks0}% } % Utility routines. % This does \let #1 = #2, with \csnames; that is, % \let \csname#1\endcsname = \csname#2\endcsname % (except of course we have to play expansion games). % \def\cslet#1#2{% \expandafter\let \csname#1\expandafter\endcsname \csname#2\endcsname } % Trim leading and trailing spaces off a string. % Concepts from aro-bend problem 15 (see CTAN). {\catcode`\@=11 \gdef\eatspaces #1{\expandafter\trim@\expandafter{#1 }} \gdef\trim@ #1{\trim@@ @#1 @ #1 @ @@} \gdef\trim@@ #1@ #2@ #3@@{\trim@@@\empty #2 @} \def\unbrace#1{#1} \unbrace{\gdef\trim@@@ #1 } #2@{#1} } {\catcode`\^^M=\other% \gdef\eatleadingcr#1{\if\noexpand#1\noexpand^^M\else\E#1\fi}}% % Warning: this won't work for a delimited argument % or for an empty argument % Trim a single trailing ^^M off a string. {\catcode`\^^M=\other \catcode`\Q=3% \gdef\eatcr #1{\eatcra #1Q^^MQ}% \gdef\eatcra#1^^MQ{\eatcrb#1Q}% \gdef\eatcrb#1Q#2Q{#1}% } % Macro bodies are absorbed as an argument in a context where % all characters are catcode 10, 11 or 12, except \ which is active % (as in normal texinfo). It is necessary to change the definition of \ % to recognize macro arguments; this is the job of \mbodybackslash. % % Non-ASCII encodings make 8-bit characters active, so un-activate % them to avoid their expansion. Must do this non-globally, to % confine the change to the current group. % % It's necessary to have hard CRs when the macro is executed. This is % done by making ^^M (\endlinechar) catcode 12 when reading the macro % body, and then making it the \newlinechar in \scanmacro. % \def\scanctxt{% used as subroutine \catcode`\"=\other \catcode`\+=\other \catcode`\<=\other \catcode`\>=\other \catcode`\^=\other \catcode`\_=\other \catcode`\|=\other \catcode`\~=\other \catcode`\@=\other \catcode`\^^M=\other \catcode`\\=\active \passthroughcharstrue } \def\macrobodyctxt{% used for @macro definitions and @copying \scanctxt \catcode`\ =\other \catcode`\{=\other \catcode`\}=\other } % Used when scanning braced macro arguments. Note, however, that catcode % changes here are ineffectual if the macro invocation was nested inside % an argument to another Texinfo command. \def\macroargctxt{% \scanctxt \catcode`\ =\active } \def\macrolineargctxt{% used for whole-line arguments without braces \scanctxt \catcode`\{=\other \catcode`\}=\other } % \mbodybackslash is the definition of \ in @macro bodies. % It maps \foo\ => \csname macarg.foo\endcsname => #N % where N is the macro parameter number. % We define \csname macarg.\endcsname to be \realbackslash, so % \\ in macro replacement text gets you a backslash. % {\catcode`@=0 @catcode`@\=@active @gdef@usembodybackslash{@let\=@mbodybackslash} @gdef@mbodybackslash#1\{@csname macarg.#1@endcsname} } \expandafter\def\csname macarg.\endcsname{\realbackslash} \def\margbackslash#1{\char`\#1 } \def\macro{\recursivefalse\parsearg\macroxxx} \def\rmacro{\recursivetrue\parsearg\macroxxx} \def\macroxxx#1{% \getargs{#1}% now \macname is the macname and \argl the arglist \ifx\argl\empty % no arguments \paramno=0\relax \else \expandafter\parsemargdef \argl;% \if\paramno>256\relax \ifx\eTeXversion\thisisundefined \errhelp = \EMsimple \errmessage{You need eTeX to compile a file with macros with more than 256 arguments} \fi \fi \fi \if1\csname ismacro.\the\macname\endcsname \message{Warning: redefining \the\macname}% \else \expandafter\ifx\csname \the\macname\endcsname \relax \else \errmessage{Macro name \the\macname\space already defined}\fi \global\cslet{macsave.\the\macname}{\the\macname}% \global\expandafter\let\csname ismacro.\the\macname\endcsname=1% \addtomacrolist{\the\macname}% \fi \begingroup \macrobodyctxt \usembodybackslash \ifrecursive \expandafter\parsermacbody \else \expandafter\parsemacbody \fi} \parseargdef\unmacro{% \if1\csname ismacro.#1\endcsname \global\cslet{#1}{macsave.#1}% \global\expandafter\let \csname ismacro.#1\endcsname=0% % Remove the macro name from \macrolist: \begingroup \expandafter\let\csname#1\endcsname \relax \let\commondummyword\unmacrodo \xdef\macrolist{\macrolist}% \endgroup \fi } % Called by \do from \dounmacro on each macro. The idea is to omit any % macro definitions that have been changed to \relax. % \def\unmacrodo#1{% \ifx #1\relax % remove this \else \noexpand\commondummyword \noexpand#1% \fi } % \getargs -- Parse the arguments to a @macro line. Set \macname to % the name of the macro, and \argl to the braced argument list. \def\getargs#1{\getargsxxx#1{}} \def\getargsxxx#1#{\getmacname #1 \relax\getmacargs} \def\getmacname#1 #2\relax{\macname={#1}} \def\getmacargs#1{\def\argl{#1}} % This made use of the feature that if the last token of a % is #, then the preceding argument is delimited by % an opening brace, and that opening brace is not consumed. % Parse the optional {params} list to @macro or @rmacro. % Set \paramno to the number of arguments, % and \paramlist to a parameter text for the macro (e.g. #1,#2,#3 for a % three-param macro.) Define \macarg.BLAH for each BLAH in the params % list to some hook where the argument is to be expanded. If there are % less than 10 arguments that hook is to be replaced by ##N where N % is the position in that list, that is to say the macro arguments are to be % defined `a la TeX in the macro body. % % That gets used by \mbodybackslash (above). % % If there are 10 or more arguments, a different technique is used: see % \parsemmanyargdef. % \def\parsemargdef#1;{% \paramno=0\def\paramlist{}% \let\hash\relax % \hash is redefined to `#' later to get it into definitions \let\xeatspaces\relax \let\xempty\relax \parsemargdefxxx#1,;,% \ifnum\paramno<10\relax\else \paramno0\relax \parsemmanyargdef@@#1,;,% 10 or more arguments \fi } \def\parsemargdefxxx#1,{% \if#1;\let\next=\relax \else \let\next=\parsemargdefxxx \advance\paramno by 1 \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname {\xeatspaces{\hash\the\paramno\noexpand\xempty{}}}% \edef\paramlist{\paramlist\hash\the\paramno,}% \fi\next} % the \xempty{} is to give \eatleadingcr an argument in the case of an % empty macro argument. % \parsemacbody, \parsermacbody % % Read recursive and nonrecursive macro bodies. (They're different since % rec and nonrec macros end differently.) % % We are in \macrobodyctxt, and the \xdef causes backslashes in the macro % body to be transformed. % Set \macrobody to the body of the macro, and call \macrodef. % {\catcode`\ =\other\long\gdef\parsemacbody#1@end macro{% \xdef\macrobody{\eatcr{#1}}\endgroup\macrodef}}% {\catcode`\ =\other\long\gdef\parsermacbody#1@end rmacro{% \xdef\macrobody{\eatcr{#1}}\endgroup\macrodef}}% % Make @ a letter, so that we can make private-to-Texinfo macro names. \edef\texiatcatcode{\the\catcode`\@} \catcode `@=11\relax %%%%%%%%%%%%%% Code for > 10 arguments only %%%%%%%%%%%%%%%%%% % If there are 10 or more arguments, a different technique is used, where the % hook remains in the body, and when macro is to be expanded the body is % processed again to replace the arguments. % % In that case, the hook is \the\toks N-1, and we simply set \toks N-1 to the % argument N value and then \edef the body (nothing else will expand because of % the catcode regime under which the body was input). % % If you compile with TeX (not eTeX), and you have macros with 10 or more % arguments, no macro can have more than 256 arguments (else error). % % In case that there are 10 or more arguments we parse again the arguments % list to set new definitions for the \macarg.BLAH macros corresponding to % each BLAH argument. It was anyhow needed to parse already once this list % in order to count the arguments, and as macros with at most 9 arguments % are by far more frequent than macro with 10 or more arguments, defining % twice the \macarg.BLAH macros does not cost too much processing power. \def\parsemmanyargdef@@#1,{% \if#1;\let\next=\relax \else \let\next=\parsemmanyargdef@@ \edef\tempb{\eatspaces{#1}}% \expandafter\def\expandafter\tempa \expandafter{\csname macarg.\tempb\endcsname}% % Note that we need some extra \noexpand\noexpand, this is because we % don't want \the to be expanded in the \parsermacbody as it uses an % \xdef . \expandafter\edef\tempa {\noexpand\noexpand\noexpand\the\toks\the\paramno}% \advance\paramno by 1\relax \fi\next} \let\endargs@\relax \let\nil@\relax \def\nilm@{\nil@}% \long\def\nillm@{\nil@}% % This macro is expanded during the Texinfo macro expansion, not during its % definition. It gets all the arguments' values and assigns them to macros % macarg.ARGNAME % % #1 is the macro name % #2 is the list of argument names % #3 is the list of argument values \def\getargvals@#1#2#3{% \def\macargdeflist@{}% \def\saveparamlist@{#2}% Need to keep a copy for parameter expansion. \def\paramlist{#2,\nil@}% \def\macroname{#1}% \begingroup \macroargctxt \def\argvaluelist{#3,\nil@}% \def\@tempa{#3}% \ifx\@tempa\empty \setemptyargvalues@ \else \getargvals@@ \fi } \def\getargvals@@{% \ifx\paramlist\nilm@ % Some sanity check needed here that \argvaluelist is also empty. \ifx\argvaluelist\nillm@ \else \errhelp = \EMsimple \errmessage{Too many arguments in macro `\macroname'!}% \fi \let\next\macargexpandinbody@ \else \ifx\argvaluelist\nillm@ % No more arguments values passed to macro. Set remaining named-arg % macros to empty. \let\next\setemptyargvalues@ \else % pop current arg name into \@tempb \def\@tempa##1{\pop@{\@tempb}{\paramlist}##1\endargs@}% \expandafter\@tempa\expandafter{\paramlist}% % pop current argument value into \@tempc \def\@tempa##1{\longpop@{\@tempc}{\argvaluelist}##1\endargs@}% \expandafter\@tempa\expandafter{\argvaluelist}% % Here \@tempb is the current arg name and \@tempc is the current arg value. % First place the new argument macro definition into \@tempd \expandafter\macname\expandafter{\@tempc}% \expandafter\let\csname macarg.\@tempb\endcsname\relax \expandafter\def\expandafter\@tempe\expandafter{% \csname macarg.\@tempb\endcsname}% \edef\@tempd{\long\def\@tempe{\the\macname}}% \push@\@tempd\macargdeflist@ \let\next\getargvals@@ \fi \fi \next } \def\push@#1#2{% \expandafter\expandafter\expandafter\def \expandafter\expandafter\expandafter#2% \expandafter\expandafter\expandafter{% \expandafter#1#2}% } % Replace arguments by their values in the macro body, and place the result % in macro \@tempa. % \def\macvalstoargs@{% % To do this we use the property that token registers that are \the'ed % within an \edef expand only once. So we are going to place all argument % values into respective token registers. % % First we save the token context, and initialize argument numbering. \begingroup \paramno0\relax % Then, for each argument number #N, we place the corresponding argument % value into a new token list register \toks#N \expandafter\putargsintokens@\saveparamlist@,;,% % Then, we expand the body so that argument are replaced by their % values. The trick for values not to be expanded themselves is that they % are within tokens and that tokens expand only once in an \edef . \edef\@tempc{\csname mac.\macroname .body\endcsname}% % Now we restore the token stack pointer to free the token list registers % which we have used, but we make sure that expanded body is saved after % group. \expandafter \endgroup \expandafter\def\expandafter\@tempa\expandafter{\@tempc}% } % Define the named-macro outside of this group and then close this group. % \def\macargexpandinbody@{% \expandafter \endgroup \macargdeflist@ % First the replace in body the macro arguments by their values, the result % is in \@tempa . \macvalstoargs@ % Then we point at the \norecurse or \gobble (for recursive) macro value % with \@tempb . \expandafter\let\expandafter\@tempb\csname mac.\macroname .recurse\endcsname % Depending on whether it is recursive or not, we need some tailing % \egroup . \ifx\@tempb\gobble \let\@tempc\relax \else \let\@tempc\egroup \fi % And now we do the real job: \edef\@tempd{\noexpand\@tempb{\macroname}\noexpand\scanmacro{\@tempa}\@tempc}% \@tempd } \def\putargsintokens@#1,{% \if#1;\let\next\relax \else \let\next\putargsintokens@ % First we allocate the new token list register, and give it a temporary % alias \@tempb . \toksdef\@tempb\the\paramno % Then we place the argument value into that token list register. \expandafter\let\expandafter\@tempa\csname macarg.#1\endcsname \expandafter\@tempb\expandafter{\@tempa}% \advance\paramno by 1\relax \fi \next } % Trailing missing arguments are set to empty. % \def\setemptyargvalues@{% \ifx\paramlist\nilm@ \let\next\macargexpandinbody@ \else \expandafter\setemptyargvaluesparser@\paramlist\endargs@ \let\next\setemptyargvalues@ \fi \next } \def\setemptyargvaluesparser@#1,#2\endargs@{% \expandafter\def\expandafter\@tempa\expandafter{% \expandafter\def\csname macarg.#1\endcsname{}}% \push@\@tempa\macargdeflist@ \def\paramlist{#2}% } % #1 is the element target macro % #2 is the list macro % #3,#4\endargs@ is the list value \def\pop@#1#2#3,#4\endargs@{% \def#1{#3}% \def#2{#4}% } \long\def\longpop@#1#2#3,#4\endargs@{% \long\def#1{#3}% \long\def#2{#4}% } %%%%%%%%%%%%%% End of code for > 10 arguments %%%%%%%%%%%%%%%%%% % This defines a Texinfo @macro or @rmacro, called by \parsemacbody. % \macrobody has the body of the macro in it, with placeholders for % its parameters, looking like "\xeatspaces{\hash 1}". % \paramno is the number of parameters % \paramlist is a TeX parameter text, e.g. "#1,#2,#3," % There are four cases: macros of zero, one, up to nine, and many arguments. % \xdef is used so that macro definitions will survive the file % they're defined in: @include reads the file inside a group. % \def\macrodef{% \let\hash=##% convert placeholders to macro parameter chars \ifnum\paramno=1 \long\def\xeatspaces##1{##1}% % We don't use \xeatspaces for single-argument macros, because we % want to keep ends of lines. This definition removes \xeatspaces % when \macrobody is expanded below. \else \def\xeatspaces{\string\xeatspaces}% % This expands \xeatspaces as a sequence of character tokens, which % stops \scantokens inserting an extra space after the control sequence. \fi \ifcase\paramno % 0 \expandafter\xdef\csname\the\macname\endcsname{% \begingroup \noexpand\spaceisspace \noexpand\endlineisspace \noexpand\expandafter % skip any whitespace after the macro name. \expandafter\noexpand\csname\the\macname @@@\endcsname}% \expandafter\xdef\csname\the\macname @@@\endcsname{% \endgroup \noexpand\scanmacro{\macrobody}}% \or % 1 \expandafter\xdef\csname\the\macname\endcsname{% \begingroup \noexpand\braceorline \expandafter\noexpand\csname\the\macname @@@\endcsname}% \expandafter\xdef\csname\the\macname @@@\endcsname##1{% \endgroup \noexpand\scanmacro{\macrobody}% }% \else % at most 9 \ifnum\paramno<10\relax % @MACNAME sets the context for reading the macro argument % @MACNAME@@ gets the argument, processes backslashes and appends a % comma. % @MACNAME@@@ removes braces surrounding the argument list. % @MACNAME@@@@ scans the macro body with arguments substituted. \expandafter\xdef\csname\the\macname\endcsname{% \begingroup \noexpand\expandafter % This \expandafter skip any spaces after the \noexpand\macroargctxt % macro before we change the catcode of space. \noexpand\expandafter \expandafter\noexpand\csname\the\macname @@\endcsname}% \expandafter\xdef\csname\the\macname @@\endcsname##1{% \noexpand\passargtomacro \expandafter\noexpand\csname\the\macname @@@\endcsname{##1,}}% \expandafter\xdef\csname\the\macname @@@\endcsname##1{% \expandafter\noexpand\csname\the\macname @@@@\endcsname ##1}% \expandafter\expandafter \expandafter\xdef \expandafter\expandafter \csname\the\macname @@@@\endcsname\paramlist{% \endgroup\noexpand\scanmacro{\macrobody}}% \else % 10 or more: \expandafter\xdef\csname\the\macname\endcsname{% \noexpand\getargvals@{\the\macname}{\argl}% }% \global\expandafter\let\csname mac.\the\macname .body\endcsname\macrobody \global\expandafter\let\csname mac.\the\macname .recurse\endcsname\gobble \fi \fi} \catcode `\@\texiatcatcode\relax % end private-to-Texinfo catcodes \def\norecurse#1{\bgroup\cslet{#1}{macsave.#1}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % {\catcode`\@=0 \catcode`\\=13 % We need to manipulate \ so use @ as escape @catcode`@_=11 % private names @catcode`@!=11 % used as argument separator % \passargtomacro#1#2 - % Call #1 with a list of tokens #2, with any doubled backslashes in #2 % compressed to one. % % This implementation works by expansion, and not execution (so we cannot use % \def or similar). This reduces the risk of this failing in contexts where % complete expansion is done with no execution (for example, in writing out to % an auxiliary file for an index entry). % % State is kept in the input stream: the argument passed to % @look_ahead, @gobble_and_check_finish and @add_segment is % % THE_MACRO ARG_RESULT ! {PENDING_BS} NEXT_TOKEN (... rest of input) % % where: % THE_MACRO - name of the macro we want to call % ARG_RESULT - argument list we build to pass to that macro % PENDING_BS - either a backslash or nothing % NEXT_TOKEN - used to look ahead in the input stream to see what's coming next @gdef@passargtomacro#1#2{% @add_segment #1!{}@relax#2\@_finish\% } @gdef@_finish{@_finishx} @global@let@_finishx@relax % #1 - THE_MACRO ARG_RESULT % #2 - PENDING_BS % #3 - NEXT_TOKEN % #4 used to look ahead % % If the next token is not a backslash, process the rest of the argument; % otherwise, remove the next token. @gdef@look_ahead#1!#2#3#4{% @ifx#4\% @expandafter@gobble_and_check_finish @else @expandafter@add_segment @fi#1!{#2}#4#4% } % #1 - THE_MACRO ARG_RESULT % #2 - PENDING_BS % #3 - NEXT_TOKEN % #4 should be a backslash, which is gobbled. % #5 looks ahead % % Double backslash found. Add a single backslash, and look ahead. @gdef@gobble_and_check_finish#1!#2#3#4#5{% @add_segment#1\!{}#5#5% } @gdef@is_fi{@fi} % #1 - THE_MACRO ARG_RESULT % #2 - PENDING_BS % #3 - NEXT_TOKEN % #4 is input stream until next backslash % % Input stream is either at the start of the argument, or just after a % backslash sequence, either a lone backslash, or a doubled backslash. % NEXT_TOKEN contains the first token in the input stream: if it is \finish, % finish; otherwise, append to ARG_RESULT the segment of the argument up until % the next backslash. PENDING_BACKSLASH contains a backslash to represent % a backslash just before the start of the input stream that has not been % added to ARG_RESULT. @gdef@add_segment#1!#2#3#4\{% @ifx#3@_finish @call_the_macro#1!% @else % append the pending backslash to the result, followed by the next segment @expandafter@is_fi@look_ahead#1#2#4!{\}@fi % this @fi is discarded by @look_ahead. % we can't get rid of it with \expandafter because we don't know how % long #4 is. } % #1 - THE_MACRO % #2 - ARG_RESULT % #3 discards the res of the conditional in @add_segment, and @is_fi ends the % conditional. @gdef@call_the_macro#1#2!#3@fi{@is_fi #1{#2}} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % \braceorline MAC is used for a one-argument macro MAC. It checks % whether the next non-whitespace character is a {. It sets the context % for reading the argument (slightly different in the two cases). Then, % to read the argument, in the whole-line case, it then calls the regular % \parsearg MAC; in the lbrace case, it calls \passargtomacro MAC. % \def\braceorline#1{\let\macnamexxx=#1\futurelet\nchar\braceorlinexxx} \def\braceorlinexxx{% \ifx\nchar\bgroup \macroargctxt \expandafter\passargtomacro \else \macrolineargctxt\expandafter\parsearg \fi \macnamexxx} % @linemacro \parseargdef\linemacro{% \getargs{#1}% now \macname is the macname and \argl the arglist \ifx\argl\empty \paramno=0 \let\hash\relax \def\paramlist{\hash 1\endlinemacro}% \else \expandafter\linegetparamlist\argl;% \fi \begingroup \macrobodyctxt \usembodybackslash \parselinemacrobody } % Build up \paramlist which will be used as the parameter text for the macro. % At the end it will be like "#1 #2 #3\endlinemacro". \def\linegetparamlist#1;{% \paramno=0\def\paramlist{}% \let\hash\relax \linegetparamlistxxx#1,;,% } \def\linegetparamlistxxx#1,{% \if#1;\let\next=\linegetparamlistxxxx \else \let\next=\linegetparamlistxxx \advance\paramno by 1 \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname {\hash\the\paramno}% \edef\paramlist{\paramlist\hash\the\paramno\space}% \fi\next} \def\linegetparamlistxxxx{% \expandafter\fixparamlist\paramlist\fixparamlist } % Replace final space token \def\fixparamlist#1 \fixparamlist{% \def\paramlist{#1\endlinemacro}% } % Read the body of the macro, replacing backslash-surrounded variables % {\catcode`\ =\other\long\gdef\parselinemacrobody#1@end linemacro{% \xdef\macrobody{#1}% \endgroup \linemacrodef }} % Make the definition \def\linemacrodef{% \let\hash=##% \expandafter\xdef\csname\the\macname\endcsname{% \bgroup \noexpand\parsearg \expandafter\noexpand\csname\the\macname @@\endcsname } \expandafter\xdef\csname\the\macname @@\endcsname##1{% \egroup \expandafter\noexpand \csname\the\macname @@@\endcsname##1\noexpand\endlinemacro } \expandafter\expandafter \expandafter\xdef \expandafter\expandafter\csname\the\macname @@@\endcsname\paramlist{% \newlinechar=13 % split \macrobody into lines \noexpand\scantokens{\macrobody}% } } % @alias. % We need some trickery to remove the optional spaces around the equal % sign. Make them active and then expand them all to nothing. % \def\alias{\parseargusing\obeyspaces\aliasxxx} \def\aliasxxx #1{\aliasyyy#1\relax} \def\aliasyyy #1=#2\relax{% {% \expandafter\let\obeyedspace=\empty \addtomacrolist{#1}% \xdef\next{\global\let\makecsname{#1}=\makecsname{#2}}% }% \next } \message{cross references,} \newwrite\auxfile \newif\ifhavexrefs % True if xref values are known. \newif\ifwarnedxrefs % True if we warned once that they aren't known. % @inforef is relatively simple. \def\inforef #1{\inforefzzz #1,,,,**} \def\inforefzzz #1,#2,#3,#4**{% \putwordSee{} \putwordInfo{} \putwordfile{} \file{\ignorespaces #3{}}, node \samp{\ignorespaces#1{}}} % @node's only job in TeX is to define \lastnode, which is used in % cross-references. The @node line might or might not have commas, and % might or might not have spaces before the first comma, like: % @node foo , bar , ... % We don't want such trailing spaces in the node name. % \parseargdef\node{\checkenv{}\donode #1 ,\finishnodeparse} % % also remove a trailing comma, in case of something like this: % @node Help-Cross, , , Cross-refs \def\donode#1 ,#2\finishnodeparse{\dodonode #1,\finishnodeparse} \def\dodonode#1,#2\finishnodeparse{\gdef\lastnode{#1}\omittopnode} % Used so that the @top node doesn't have to be wrapped in an @ifnottex % conditional. % \doignore goes to more effort to skip nested conditionals but we don't need % that here. \def\omittopnode{% \ifx\lastnode\wordTop \expandafter\ignorenode\fi } \def\wordTop{Top} % Until the next @node, @part or @bye command, divert output to a box that % is not output. \def\ignorenode{\setbox\dummybox\vbox\bgroup \def\part{\egroup\part}% \def\node{\egroup\node}% \ignorenodebye } {\let\bye\relax \gdef\ignorenodebye{\let\bye\ignorenodebyedef} \gdef\ignorenodebyedef{\egroup(`Top' node ignored)\bye}} % The redefinition of \bye here is because it is declared \outer \let\lastnode=\empty % Write a cross-reference definition for the current node. #1 is the % type (Ynumbered, Yappendix, Ynothing). % \def\donoderef#1{% \ifx\lastnode\empty\else \setref{\lastnode}{#1}% \global\let\lastnode=\empty \fi } % @nodedescription, @nodedescriptionblock - do nothing for TeX \parseargdef\nodedescription{} \def\nodedescriptionblock{\doignore{nodedescriptionblock}} % @anchor{NAME} -- define xref target at arbitrary point. % \newcount\savesfregister % \def\savesf{\relax \ifhmode \savesfregister=\spacefactor \fi} \def\restoresf{\relax \ifhmode \spacefactor=\savesfregister \fi} \def\anchor#1{\savesf \setref{#1}{Ynothing}\restoresf \ignorespaces} % \setref{NAME}{SNT} defines a cross-reference point NAME (a node or an % anchor), which consists of three parts: % 1) NAME-title - the current sectioning name taken from \currentsection, % or the anchor name. % 2) NAME-snt - section number and type, passed as the SNT arg, or % empty for anchors. % 3) NAME-pg - the page number. % % This is called from \donoderef, \anchor, and \dofloat. In the case of % floats, there is an additional part, which is not written here: % 4) NAME-lof - the text as it should appear in a @listoffloats. % \def\setref#1#2{% \pdfmkdest{#1}% \iflinks {% \requireauxfile \atdummies % preserve commands, but don't expand them % match definition in \xrdef, \refx, \xrefX. \def\value##1{##1}% \edef\writexrdef##1##2{% \write\auxfile{@xrdef{#1-% #1 of \setref, expanded by the \edef ##1}{##2}}% these are parameters of \writexrdef }% \toks0 = \expandafter{\currentsection}% \immediate \writexrdef{title}{\the\toks0 }% \immediate \writexrdef{snt}{\csname #2\endcsname}% \Ynumbered etc. \safewhatsit{\writexrdef{pg}{\folio}}% will be written later, at \shipout }% \fi } % @xrefautosectiontitle on|off says whether @section(ing) names are used % automatically in xrefs, if the third arg is not explicitly specified. % This was provided as a "secret" @set xref-automatic-section-title % variable, now it's official. % \parseargdef\xrefautomaticsectiontitle{% \def\temp{#1}% \ifx\temp\onword \expandafter\let\csname SETxref-automatic-section-title\endcsname = \empty \else\ifx\temp\offword \expandafter\let\csname SETxref-automatic-section-title\endcsname = \relax \else \errhelp = \EMsimple \errmessage{Unknown @xrefautomaticsectiontitle value `\temp', must be on|off}% \fi\fi } % % @xref, @pxref, and @ref generate cross-references. For \xrefX, #1 is % the node name, #2 the name of the Info cross-reference, #3 the printed % node name, #4 the name of the Info file, #5 the name of the printed % manual. All but the node name can be omitted. % \def\pxref{\putwordsee{} \xrefXX} \def\xref{\putwordSee{} \xrefXX} \def\ref{\xrefXX} \def\xrefXX#1{\def\xrefXXarg{#1}\futurelet\tokenafterxref\xrefXXX} \def\xrefXXX{\expandafter\xrefX\expandafter[\xrefXXarg,,,,,,,]} % \newbox\toprefbox \newbox\printedrefnamebox \newbox\infofilenamebox \newbox\printedmanualbox % \def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup \unsepspaces % \getprintedrefname{#1}{#3}{#5}% \def\infofilename{\ignorespaces #4}% \setbox\infofilenamebox = \hbox{\infofilename\unskip}% % \startxreflink{#1}{#4}% {% % Have to otherify everything special to allow the \csname to % include an _ in the xref name, etc. \indexnofonts \turnoffactive \def\value##1{##1}% \expandafter\global\expandafter\let\expandafter\Xthisreftitle \csname XR#1-title\endcsname }% % % Float references are printed completely differently: "Figure 1.2" % instead of "[somenode], p.3". \iffloat distinguishes them by % \Xthisreftitle being set to a magic string. \iffloat\Xthisreftitle % If the user specified the print name (third arg) to the ref, % print it instead of our usual "Figure 1.2". \ifdim\wd\printedrefnamebox = 0pt \refx{#1-snt}% \else \printedrefname \fi % % If the user also gave the printed manual name (fifth arg), append % "in MANUALNAME". \ifdim \wd\printedmanualbox > 0pt \space \putwordin{} \cite{\printedmanual}% \fi \else % node/anchor (non-float) references. % % If we use \unhbox to print the node names, TeX does not insert % empty discretionaries after hyphens, which means that it will not % find a line break at a hyphen in a node names. Since some manuals % are best written with fairly long node names, containing hyphens, % this is a loss. Therefore, we give the text of the node name % again, so it is as if TeX is seeing it for the first time. % \ifdim \wd\printedmanualbox > 0pt % Cross-manual reference with a printed manual name. % \crossmanualxref{\cite{\printedmanual\unskip}}% % \else\ifdim \wd\infofilenamebox > 0pt % Cross-manual reference with only an info filename (arg 4), no % printed manual name (arg 5). This is essentially the same as % the case above; we output the filename, since we have nothing else. % \crossmanualxref{\code{\infofilename\unskip}}% % \else % Reference within this manual. % % Only output a following space if the -snt ref is nonempty, as the ref % will be empty for @unnumbered and @anchor. \setbox2 = \hbox{\ignorespaces \refx{#1-snt}}% \ifdim \wd2 > 0pt \refx{#1-snt}\space\fi % % output the `[mynode]' via the macro below so it can be overridden. \xrefprintnodename\printedrefname % \ifflagclear{txiomitxrefpg}{% % We always want a comma ,% % output the `page 3'. \turnoffactive \putpageref{#1}% % Add a , if xref followed by a space \if\space\noexpand\tokenafterxref ,% \else\ifx\ \tokenafterxref ,% @TAB \else\ifx\*\tokenafterxref ,% @* \else\ifx\ \tokenafterxref ,% @SPACE \else\ifx\ \tokenafterxref ,% @NL \else\ifx\tie\tokenafterxref ,% @tie \fi\fi\fi\fi\fi\fi }{}% \fi\fi \fi \endlink \endgroup} % \getprintedrefname{NODE}{LABEL}{MANUAL} % - set \printedrefname and \printedmanual % \def\getprintedrefname#1#2#3{% % Get args without leading/trailing spaces. \def\printedrefname{\ignorespaces #2}% \setbox\printedrefnamebox = \hbox{\printedrefname\unskip}% % \def\printedmanual{\ignorespaces #3}% \setbox\printedmanualbox = \hbox{\printedmanual\unskip}% % % If the printed reference name (arg #2) was not explicitly given in % the @xref, figure out what we want to use. \ifdim \wd\printedrefnamebox = 0pt % No printed node name was explicitly given. \expandafter\ifx\csname SETxref-automatic-section-title\endcsname \relax % Not auto section-title: use node name inside the square brackets. \def\printedrefname{\ignorespaces #1}% \else % Auto section-title: use chapter/section title inside % the square brackets if we have it. \ifdim \wd\printedmanualbox > 0pt % It is in another manual, so we don't have it; use node name. \def\printedrefname{\ignorespaces #1}% \else \ifhavexrefs % We (should) know the real title if we have the xref values. \def\printedrefname{\refx{#1-title}}% \else % Otherwise just copy the Info node name. \def\printedrefname{\ignorespaces #1}% \fi% \fi \fi \fi } % \startxreflink{NODE}{FILE} - start link in pdf output. \def\startxreflink#1#2{% \ifpdforxetex % For pdfTeX and LuaTeX {\indexnofonts \makevalueexpandable \turnoffactive % This expands tokens, so do it after making catcode changes, so _ % etc. don't get their TeX definitions. This ignores all spaces in % #2, including (wrongly) those in the middle of the filename. \getfilename{#2}% % % This (wrongly) does not take account of leading or trailing % spaces in #1, which should be ignored. \setpdfdestname{#1}% % \ifx\pdfdestname\empty \def\pdfdestname{Top}% no empty targets \fi % \leavevmode \ifpdf \startlink attr{/Border [0 0 0]}% \ifnum\filenamelength>0 goto file{\the\filename.pdf} name{\pdfdestname}% \else goto name{\pdfmkpgn{\pdfdestname}}% \fi \else % XeTeX \ifnum\filenamelength>0 % With default settings, % XeTeX (xdvipdfmx) replaces link destination names with integers. % In this case, the replaced destination names of % remote PDFs are no longer known. In order to avoid a replacement, % you can use xdvipdfmx's command line option `-C 0x0010'. % If you use XeTeX 0.99996+ (TeX Live 2016+), % this command line option is no longer necessary % because we can use the `dvipdfmx:config' special. \special{pdf:bann << /Border [0 0 0] /Type /Annot /Subtype /Link /A << /S /GoToR /F (\the\filename.pdf) /D (\pdfdestname) >> >>}% \else \special{pdf:bann << /Border [0 0 0] /Type /Annot /Subtype /Link /A << /S /GoTo /D (\pdfdestname) >> >>}% \fi \fi }% \setcolor{\linkcolor}% \fi } % can be overridden in translation files \def\putpageref#1{% \space\putwordpage\tie\refx{#1-pg}} % Output a cross-manual xref to #1. Used just above (twice). % % Only include the text "Section ``foo'' in" if the foo is neither % missing or Top. Thus, @xref{,,,foo,The Foo Manual} outputs simply % "see The Foo Manual", the idea being to refer to the whole manual. % % But, this being TeX, we can't easily compare our node name against the % string "Top" while ignoring the possible spaces before and after in % the input. By adding the arbitrary 7sp below, we make it much less % likely that a real node name would have the same width as "Top" (e.g., % in a monospaced font). Hopefully it will never happen in practice. % % For the same basic reason, we retypeset the "Top" at every % reference, since the current font is indeterminate. % \def\crossmanualxref#1{% \setbox\toprefbox = \hbox{Top\kern7sp}% \setbox2 = \hbox{\ignorespaces \printedrefname \unskip \kern7sp}% \ifdim \wd2 > 7sp % nonempty? \ifdim \wd2 = \wd\toprefbox \else % same as Top? \putwordSection{} ``\printedrefname'' \putwordin{}\space \fi \fi #1% } % This macro is called from \xrefX for the `[nodename]' part of xref % output. It's a separate macro only so it can be changed more easily, % since square brackets don't work well in some documents. Particularly % one that Bob is working on :). % \def\xrefprintnodename#1{[#1]} % @link{NODENAME, LABEL, MANUAL} - create a "plain" link, with no % page number. Not useful if printed on paper. % \def\link#1{\linkX[#1,,,]} \def\linkX[#1,#2,#3,#4]{% \begingroup \unsepspaces \getprintedrefname{#1}{#2}{#3}% \startxreflink{#1}{#3}% \printedrefname \endlink \endgroup } % Things referred to by \setref. % \def\Ynothing{} \def\Yomitfromtoc{} \def\Ynumbered{% \ifnum\secno=0 \putwordChapter@tie \the\chapno \else \ifnum\subsecno=0 \putwordSection@tie \the\chapno.\the\secno \else \ifnum\subsubsecno=0 \putwordSection@tie \the\chapno.\the\secno.\the\subsecno \else \putwordSection@tie \the\chapno.\the\secno.\the\subsecno.\the\subsubsecno \fi\fi\fi } \def\Yappendix{% \ifnum\secno=0 \putwordAppendix@tie @char\the\appendixno{}% \else \ifnum\subsecno=0 \putwordSection@tie @char\the\appendixno.\the\secno \else \ifnum\subsubsecno=0 \putwordSection@tie @char\the\appendixno.\the\secno.\the\subsecno \else \putwordSection@tie @char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno \fi\fi\fi } % \refx{NAME} - reference a cross-reference string named NAME. \def\refx#1{% \requireauxfile {% \indexnofonts \turnoffactive \def\value##1{##1}% \expandafter\global\expandafter\let\expandafter\thisrefX \csname XR#1\endcsname }% \ifx\thisrefX\relax % If not defined, say something at least. \angleleft un\-de\-fined\angleright \iflinks \ifhavexrefs {\toks0 = {#1}% avoid expansion of possibly-complex value \message{\linenumber Undefined cross reference `\the\toks0'.}}% \else \ifwarnedxrefs\else \global\warnedxrefstrue \message{Cross reference values unknown; you must run TeX again.}% \fi \fi \fi \else % It's defined, so just use it. \thisrefX \fi } % This is the macro invoked by entries in the aux file. Define a control % sequence for a cross-reference target (we prepend XR to the control sequence % name to avoid collisions). The value is the page number. If this is a float % type, we have more work to do. % \def\xrdef#1#2{% {% Expand the node or anchor name to remove control sequences. % \turnoffactive stops 8-bit characters being changed to commands % like @'e. \refx does the same to retrieve the value in the definition. \indexnofonts \turnoffactive \def\value##1{##1}% \xdef\safexrefname{#1}% }% % \bgroup \expandafter\gdef\csname XR\safexrefname\endcsname{#2}% \egroup % We put the \gdef inside a group to avoid the definitions building up on % TeX's save stack, which can cause it to run out of space for aux files with % thousands of lines. \gdef doesn't use the save stack, but \csname does % when it defines an unknown control sequence as \relax. % % Was that xref control sequence that we just defined for a float? \expandafter\iffloat\csname XR\safexrefname\endcsname % it was a float, and we have the (safe) float type in \iffloattype. \expandafter\let\expandafter\floatlist \csname floatlist\iffloattype\endcsname % % Is this the first time we've seen this float type? \expandafter\ifx\floatlist\relax \toks0 = {\do}% yes, so just \do \else % had it before, so preserve previous elements in list. \toks0 = \expandafter{\floatlist\do}% \fi % % Remember this xref in the control sequence \floatlistFLOATTYPE, % for later use in \listoffloats. \expandafter\xdef\csname floatlist\iffloattype\endcsname{\the\toks0 {\safexrefname}}% \fi } % If working on a large document in chapters, it is convenient to % be able to disable indexing, cross-referencing, and contents, for test runs. % This is done with @novalidate at the beginning of the file. % \newif\iflinks \linkstrue % by default we want the aux files. \let\novalidate = \linksfalse % Used when writing to the aux file, or when using data from it. \def\requireauxfile{% \iflinks \tryauxfile % Open the new aux file. TeX will close it automatically at exit. \immediate\openout\auxfile=\jobname.aux \fi \global\let\requireauxfile=\relax % Only do this once. } % Read the last existing aux file, if any. No error if none exists. % \def\tryauxfile{% \openin 1 \jobname.aux \ifeof 1 \else \readdatafile{aux}% \global\havexrefstrue \fi \closein 1 } \def\setupdatafile{% \catcode`\^^@=\other \catcode`\^^A=\other \catcode`\^^B=\other \catcode`\^^C=\other \catcode`\^^D=\other \catcode`\^^E=\other \catcode`\^^F=\other \catcode`\^^G=\other \catcode`\^^H=\other \catcode`\^^K=\other \catcode`\^^L=\other \catcode`\^^N=\other \catcode`\^^P=\other \catcode`\^^Q=\other \catcode`\^^R=\other \catcode`\^^S=\other \catcode`\^^T=\other \catcode`\^^U=\other \catcode`\^^V=\other \catcode`\^^W=\other \catcode`\^^X=\other \catcode`\^^Z=\other \catcode`\^^[=\other \catcode`\^^\=\other \catcode`\^^]=\other \catcode`\^^^=\other \catcode`\^^_=\other \catcode`\^=\other % % Special characters. Should be turned off anyway, but... \catcode`\~=\other \catcode`\[=\other \catcode`\]=\other \catcode`\"=\other \catcode`\_=\active \catcode`\|=\active \catcode`\<=\active \catcode`\>=\active \catcode`\$=\other \catcode`\#=\other \catcode`\&=\other \catcode`\%=\other \catcode`+=\other % avoid \+ for paranoia even though we've turned it off % \catcode`\\=\active % % @ is our escape character in .aux files, and we need braces. \catcode`\{=1 \catcode`\}=2 \catcode`\@=0 } \def\readdatafile#1{% \begingroup \setupdatafile \input\jobname.#1 \endgroup} \message{insertions,} % including footnotes. \newcount \footnoteno % The trailing space in the following definition for supereject is % vital for proper filling; pages come out unaligned when you do a % pagealignmacro call if that space before the closing brace is % removed. (Generally, numeric constants should always be followed by a % space to prevent strange expansion errors.) \def\supereject{\par\penalty -20000\footnoteno =0 } % @footnotestyle is meaningful for Info output only. \let\footnotestyle=\comment {\catcode `\@=11 % % Auto-number footnotes. Otherwise like plain. \gdef\footnote{% \global\advance\footnoteno by \@ne \edef\thisfootno{$^{\the\footnoteno}$}% % % In case the footnote comes at the end of a sentence, preserve the % extra spacing after we do the footnote number. \let\@sf\empty \ifhmode\edef\@sf{\spacefactor\the\spacefactor}\ptexslash\fi % % Remove inadvertent blank space before typesetting the footnote number. \unskip \thisfootno\@sf \dofootnote }% % Don't bother with the trickery in plain.tex to not require the % footnote text as a parameter. Our footnotes don't need to be so general. % % Oh yes, they do; otherwise, @ifset (and anything else that uses % \parseargline) fails inside footnotes because the tokens are fixed when % the footnote is read. --karl, 16nov96. % \gdef\dofootnote{% \insert\footins\bgroup % % Nested footnotes are not supported in TeX, that would take a lot % more work. (\startsavinginserts does not suffice.) \let\footnote=\errfootnotenest % % We want to typeset this text as a normal paragraph, even if the % footnote reference occurs in (for example) a display environment. % So reset some parameters. \hsize=\txipagewidth \interlinepenalty\interfootnotelinepenalty \splittopskip\ht\strutbox % top baseline for broken footnotes \splitmaxdepth\dp\strutbox \floatingpenalty\@MM \leftskip\z@skip \rightskip\z@skip \spaceskip\z@skip \xspaceskip\z@skip \parindent\defaultparindent % \smallfonts \rm % % Because we use hanging indentation in footnotes, a @noindent appears % to exdent this text, so make it be a no-op. makeinfo does not use % hanging indentation so @noindent can still be needed within footnote % text after an @example or the like (not that this is good style). \let\noindent = \relax % % Hang the footnote text off the number. Use \everypar in case the % footnote extends for more than one paragraph. \everypar = {\hang}% \textindent{\thisfootno}% % % Don't crash into the line above the footnote text. Since this % expands into a box, it must come within the paragraph, lest it % provide a place where TeX can split the footnote. \footstrut % % Invoke rest of plain TeX footnote routine. \futurelet\next\fo@t } }%end \catcode `\@=11 \def\errfootnotenest{% \errhelp=\EMsimple \errmessage{Nested footnotes not supported in texinfo.tex, even though they work in makeinfo; sorry} } \def\errfootnoteheading{% \errhelp=\EMsimple \errmessage{Footnotes in chapters, sections, etc., are not supported} } % In case a @footnote appears in a vbox, save the footnote text and create % the real \insert just after the vbox finished. Otherwise, the insertion % would be lost. % Similarly, if a @footnote appears inside an alignment, save the footnote % text to a box and make the \insert when a row of the table is finished. % And the same can be done for other insert classes. --kasal, 16nov03. % % Replace the \insert primitive by a cheating macro. % Deeper inside, just make sure that the saved insertions are not spilled % out prematurely. % \def\startsavinginserts{% \ifx \insert\ptexinsert \let\insert\saveinsert \else \let\checkinserts\relax \fi } % This \insert replacement works for both \insert\footins{foo} and % \insert\footins\bgroup foo\egroup, but it doesn't work for \insert27{foo}. % \def\saveinsert#1{% \edef\next{\noexpand\savetobox \makeSAVEname#1}% \afterassignment\next % swallow the left brace \let\temp = } \def\makeSAVEname#1{\makecsname{SAVE\expandafter\gobble\string#1}} \def\savetobox#1{\global\setbox#1 = \vbox\bgroup \unvbox#1} \def\checksaveins#1{\ifvoid#1\else \placesaveins#1\fi} \def\placesaveins#1{% \ptexinsert \csname\expandafter\gobblesave\string#1\endcsname {\box#1}% } % eat @SAVE -- beware, all of them have catcode \other: { \def\dospecials{\do S\do A\do V\do E} \uncatcodespecials % ;-) \gdef\gobblesave @SAVE{} } % initialization: \def\newsaveins #1{% \edef\next{\noexpand\newsaveinsX \makeSAVEname#1}% \next } \def\newsaveinsX #1{% \csname newbox\endcsname #1% \expandafter\def\expandafter\checkinserts\expandafter{\checkinserts \checksaveins #1}% } % initialize: \let\checkinserts\empty \newsaveins\footins \newsaveins\margin % @image. We use the macros from epsf.tex to support this. % If epsf.tex is not installed and @image is used, we complain. % % Check for and read epsf.tex up front. If we read it only at @image % time, we might be inside a group, and then its definitions would get % undone and the next image would fail. \openin 1 = epsf.tex \ifeof 1 \else % Do not bother showing banner with epsf.tex v2.7k (available in % doc/epsf.tex and on ctan). \def\epsfannounce{\toks0 = }% \input epsf.tex \fi \closein 1 % % We will only complain once about lack of epsf.tex. \newif\ifwarnednoepsf \newhelp\noepsfhelp{epsf.tex must be installed for images to work. It is also included in the Texinfo distribution, or you can get it from https://ctan.org/texarchive/macros/texinfo/texinfo/doc/epsf.tex.} % \def\image#1{% \ifx\epsfbox\thisisundefined \ifwarnednoepsf \else \errhelp = \noepsfhelp \errmessage{epsf.tex not found, images will be ignored}% \global\warnednoepsftrue \fi \else \imagexxx #1,,,,,\finish \fi } % Approximate height of a line in the standard text font. \newdimen\capheight \setbox0=\vbox{\tenrm H} \capheight=\ht0 % % Arguments to @image: % #1 is (mandatory) image filename; we tack on .eps extension. % #2 is (optional) width, #3 is (optional) height. % #4 is (ignored optional) html alt text. % #5 is (ignored optional) extension. % #6 is just the usual extra ignored arg for parsing stuff. \newif\ifimagevmode \def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup \catcode`\^^M = 5 % in case we're inside an example \normalturnoffactive % allow _ et al. in names \makevalueexpandable \ifvmode \imagevmodetrue \medskip % Usually we'll have text after the image which will insert % \parskip glue, so insert it here too to equalize the space % above and below. \vskip\parskip % % Place image in a \vtop for a top page margin that is (close to) correct, % as \topskip glue is relative to the first baseline. \vtop\bgroup \kern -\capheight \vskip-\parskip \fi % \ifx\centersub\centerV % For @center @image, enter vertical mode and add vertical space % Enter an extra \parskip because @center doesn't add space itself. \vbox\bgroup\vskip\parskip\medskip\vskip\parskip \else % Enter horizontal mode so that indentation from an enclosing % environment such as @quotation is respected. % However, if we're at the top level, we don't want the % normal paragraph indentation. \imageindent \fi % % Output the image. \ifpdf % For pdfTeX and LuaTeX <= 0.80 \dopdfimage{#1}{#2}{#3}% \else \ifx\XeTeXrevision\thisisundefined % For epsf.tex % \epsfbox itself resets \epsf?size at each figure. \setbox0 = \hbox{\ignorespaces #2}% \ifdim\wd0 > 0pt \epsfxsize=#2\relax \fi \setbox0 = \hbox{\ignorespaces #3}% \ifdim\wd0 > 0pt \epsfysize=#3\relax \fi \epsfbox{#1.eps}% \else % For XeTeX \doxeteximage{#1}{#2}{#3}% \fi \fi % \ifimagevmode \egroup \medskip % space after a standalone image \fi \ifx\centersub\centerV % @center @image \medskip \egroup % close \vbox \fi \endgroup} % @float FLOATTYPE,LABEL,LOC ... @end float for displayed figures, tables, % etc. We don't actually implement floating yet, we always include the % float "here". But it seemed the best name for the future. % \envparseargdef\float{\eatcommaspace\eatcommaspace\dofloat#1, , ,\finish} % There may be a space before second and/or third parameter; delete it. \def\eatcommaspace#1, {#1,} % #1 is the optional FLOATTYPE, the text label for this float, typically % "Figure", "Table", "Example", etc. Can't contain commas. If omitted, % this float will not be numbered and cannot be referred to. % % #2 is the optional xref label. Also must be present for the float to % be referable. % % #3 is the optional positioning argument; for now, it is ignored. It % will somehow specify the positions allowed to float to (here, top, bottom). % % We keep a separate counter for each FLOATTYPE, which we reset at each % chapter-level command. \let\resetallfloatnos=\empty % \def\dofloat#1,#2,#3,#4\finish{% \let\thiscaption=\empty \let\thisshortcaption=\empty % % don't lose footnotes inside @float. % % BEWARE: when the floats start float, we have to issue warning whenever an % insert appears inside a float which could possibly float. --kasal, 26may04 % \startsavinginserts % % We can't be used inside a paragraph. \par % \vtop\bgroup \def\floattype{#1}% \def\floatlabel{#2}% \def\floatloc{#3}% we do nothing with this yet. % \ifx\floattype\empty \let\safefloattype=\empty \else {% % the floattype might have accents or other special characters, % but we need to use it in a control sequence name. \indexnofonts \turnoffactive \xdef\safefloattype{\floattype}% }% \fi % % If label is given but no type, we handle that as the empty type. \ifx\floatlabel\empty \else % We want each FLOATTYPE to be numbered separately (Figure 1, % Table 1, Figure 2, ...). (And if no label, no number.) % \expandafter\getfloatno\csname\safefloattype floatno\endcsname \global\advance\floatno by 1 % {% % This magic value for \currentsection is output by \setref as the % XREFLABEL-title value. \xrefX uses it to distinguish float % labels (which have a completely different output format) from % node and anchor labels. And \xrdef uses it to construct the % lists of floats. % \edef\currentsection{\floatmagic=\safefloattype}% \setref{\floatlabel}{Yfloat}% }% \fi % % start with \parskip glue, I guess. \vskip\parskip % % Don't suppress indentation if a float happens to start a section. \restorefirstparagraphindent } % we have these possibilities: % @float Foo,lbl & @caption{Cap}: Foo 1.1: Cap % @float Foo,lbl & no caption: Foo 1.1 % @float Foo & @caption{Cap}: Foo: Cap % @float Foo & no caption: Foo % @float ,lbl & Caption{Cap}: 1.1: Cap % @float ,lbl & no caption: 1.1 % @float & @caption{Cap}: Cap % @float & no caption: % \def\Efloat{% \let\floatident = \empty % % In all cases, if we have a float type, it comes first. \ifx\floattype\empty \else \def\floatident{\floattype}\fi % % If we have an xref label, the number comes next. \ifx\floatlabel\empty \else \ifx\floattype\empty \else % if also had float type, need tie first. \appendtomacro\floatident{\tie}% \fi % the number. \appendtomacro\floatident{\chaplevelprefix\the\floatno}% \fi % % Start the printed caption with what we've constructed in % \floatident, but keep it separate; we need \floatident again. \let\captionline = \floatident % \ifx\thiscaption\empty \else \ifx\floatident\empty \else \appendtomacro\captionline{: }% had ident, so need a colon between \fi % % caption text. \appendtomacro\captionline{\scanexp\thiscaption}% \fi % % If we have anything to print, print it, with space before. % Eventually this needs to become an \insert. \ifx\captionline\empty \else \vskip.5\parskip \captionline % % Space below caption. \vskip\parskip \fi % % If have an xref label, write the list of floats info. Do this % after the caption, to avoid chance of it being a breakpoint. \ifx\floatlabel\empty \else % Write the text that goes in the lof to the aux file as % \floatlabel-lof. Besides \floatident, we include the short % caption if specified, else the full caption if specified, else nothing. {% \requireauxfile \atdummies % \ifx\thisshortcaption\empty \def\gtemp{\thiscaption}% \else \def\gtemp{\thisshortcaption}% \fi \immediate\write\auxfile{@xrdef{\floatlabel-lof}{\floatident \ifx\gtemp\empty \else : \gtemp \fi}}% }% \fi \egroup % end of \vtop % \checkinserts } % Append the tokens #2 to the definition of macro #1, not expanding either. % \def\appendtomacro#1#2{% \expandafter\def\expandafter#1\expandafter{#1#2}% } % @caption, @shortcaption % \def\caption{\docaption\thiscaption} \def\shortcaption{\docaption\thisshortcaption} \def\docaption{\checkenv\float \bgroup\scanctxt\docaptionz} \def\docaptionz#1#2{\egroup \def#1{#2}} % The parameter is the control sequence identifying the counter we are % going to use. Create it if it doesn't exist and assign it to \floatno. \def\getfloatno#1{% \ifx#1\relax % Haven't seen this figure type before. \csname newcount\endcsname #1% % % Remember to reset this floatno at the next chap. \expandafter\gdef\expandafter\resetallfloatnos \expandafter{\resetallfloatnos #1=0 }% \fi \let\floatno#1% } % \setref calls this to get the XREFLABEL-snt value. We want an @xref % to the FLOATLABEL to expand to "Figure 3.1". We call \setref when we % first read the @float command. % \def\Yfloat{\floattype@tie \chaplevelprefix\the\floatno}% % Magic string used for the XREFLABEL-title value, so \xrefX can % distinguish floats from other xref types. \def\floatmagic{!!float!!} % #1 is the control sequence we are passed; we expand into a conditional % which is true if #1 represents a float ref. That is, the magic % \currentsection value which we \setref above. % \def\iffloat#1{\expandafter\doiffloat#1==\finish} % % #1 is (maybe) the \floatmagic string. If so, #2 will be the % (safe) float type for this float. We set \iffloattype to #2. % \def\doiffloat#1=#2=#3\finish{% \def\temp{#1}% \def\iffloattype{#2}% \ifx\temp\floatmagic } % @listoffloats FLOATTYPE - print a list of floats like a table of contents. % \parseargdef\listoffloats{% \def\floattype{#1}% floattype {% % the floattype might have accents or other special characters, % but we need to use it in a control sequence name. \indexnofonts \turnoffactive \xdef\safefloattype{\floattype}% }% % % \xrdef saves the floats as a \do-list in \floatlistSAFEFLOATTYPE. \expandafter\ifx\csname floatlist\safefloattype\endcsname \relax \ifhavexrefs % if the user said @listoffloats foo but never @float foo. \message{\linenumber No `\safefloattype' floats to list.}% \fi \else \begingroup \leftskip=\tocindent % indent these entries like a toc \let\do=\listoffloatsdo \csname floatlist\safefloattype\endcsname \endgroup \fi } % This is called on each entry in a list of floats. We're passed the % xref label, in the form LABEL-title, which is how we save it in the % aux file. We strip off the -title and look up \XRLABEL-lof, which % has the text we're supposed to typeset here. % % Figures without xref labels will not be included in the list (since % they won't appear in the aux file). % \def\listoffloatsdo#1{\listoffloatsdoentry#1\finish} \def\listoffloatsdoentry#1-title\finish{{% % Can't fully expand XR#1-lof because it can contain anything. Just % pass the control sequence. On the other hand, XR#1-pg is just the % page number, and we want to fully expand that so we can get a link % in pdf output. \toksA = \expandafter{\csname XR#1-lof\endcsname}% % % use the same \entry macro we use to generate the TOC and index. \edef\writeentry{\noexpand\entry{\the\toksA}{\csname XR#1-pg\endcsname}}% \writeentry }} \message{localization,} % For single-language documents, @documentlanguage is usually given very % early, just after @documentencoding. Single argument is the language % (de) or locale (de_DE) abbreviation. % { \catcode`\_ = \active \globaldefs=1 \parseargdef\documentlanguage{% \tex % read txi-??.tex file in plain TeX. % Read the file by the name they passed if it exists. \let_ = \normalunderscore % normal _ character for filename test \openin 1 txi-#1.tex \ifeof 1 \documentlanguagetrywithoutunderscore #1_\finish \else \globaldefs = 1 % everything in the txi-LL files needs to persist \input txi-#1.tex \fi \closein 1 \endgroup % end raw TeX } % % If they passed de_DE, and txi-de_DE.tex doesn't exist, % try txi-de.tex. % \gdef\documentlanguagetrywithoutunderscore#1_#2\finish{% \openin 1 txi-#1.tex \ifeof 1 \errhelp = \nolanghelp \errmessage{Cannot read language file txi-#1.tex}% \else \globaldefs = 1 % everything in the txi-LL files needs to persist \input txi-#1.tex \fi \closein 1 } }% end of special _ catcode % \newhelp\nolanghelp{The given language definition file cannot be found or is empty. Maybe you need to install it? Putting it in the current directory should work if nowhere else does.} % This macro is called from txi-??.tex files; the first argument is the % \language name to set (without the "\lang@" prefix), the second and % third args are \{left,right}hyphenmin. % % The language names to pass are determined when the format is built. % See the etex.log file created at that time, e.g., % /usr/local/texlive/2008/texmf-var/web2c/pdftex/etex.log. % % With TeX Live 2008, etex now includes hyphenation patterns for all % available languages. This means we can support hyphenation in % Texinfo, at least to some extent. (This still doesn't solve the % accented characters problem.) % \catcode`@=11 \def\txisetlanguage#1#2#3{% % do not set the language if the name is undefined in the current TeX. \expandafter\ifx\csname lang@#1\endcsname \relax \message{no patterns for #1}% \else \global\language = \csname lang@#1\endcsname \fi % but there is no harm in adjusting the hyphenmin values regardless. \global\lefthyphenmin = #2\relax \global\righthyphenmin = #3\relax } % XeTeX and LuaTeX can handle Unicode natively. % Their default I/O uses UTF-8 sequences instead of a byte-wise operation. % Other TeX engines' I/O (pdfTeX, etc.) is byte-wise. % \newif\iftxinativeunicodecapable \newif\iftxiusebytewiseio \ifx\XeTeXrevision\thisisundefined \ifx\luatexversion\thisisundefined \txinativeunicodecapablefalse \txiusebytewiseiotrue \else \txinativeunicodecapabletrue \txiusebytewiseiofalse \fi \else \txinativeunicodecapabletrue \txiusebytewiseiofalse \fi % Set I/O by bytes instead of UTF-8 sequence for XeTeX and LuaTex % for non-UTF-8 (byte-wise) encodings. % \def\setbytewiseio{% \ifx\XeTeXrevision\thisisundefined \else \XeTeXdefaultencoding "bytes" % For subsequent files to be read \XeTeXinputencoding "bytes" % For document root file % Unfortunately, there seems to be no corresponding XeTeX command for % output encoding. This is a problem for auxiliary index and TOC files. % The only solution would be perhaps to write out @U{...} sequences in % place of non-ASCII characters. \fi \ifx\luatexversion\thisisundefined \else \directlua{ local utf8_char, byte, gsub = unicode.utf8.char, string.byte, string.gsub local function convert_char (char) return utf8_char(byte(char)) end local function convert_line (line) return gsub(line, ".", convert_char) end callback.register("process_input_buffer", convert_line) local function convert_line_out (line) local line_out = "" for c in string.utfvalues(line) do line_out = line_out .. string.char(c) end return line_out end callback.register("process_output_buffer", convert_line_out) } \fi \txiusebytewiseiotrue } % Helpers for encodings. % Set the catcode of characters 128 through 255 to the specified number. % \def\setnonasciicharscatcode#1{% \count255=128 \loop\ifnum\count255<256 \global\catcode\count255=#1\relax \advance\count255 by 1 \repeat } \def\setnonasciicharscatcodenonglobal#1{% \count255=128 \loop\ifnum\count255<256 \catcode\count255=#1\relax \advance\count255 by 1 \repeat } % @documentencoding sets the definition of non-ASCII characters % according to the specified encoding. % \def\documentencoding{\parseargusing\filenamecatcodes\documentencodingzzz} \def\documentencodingzzz#1{% % % Encoding being declared for the document. \def\declaredencoding{\csname #1.enc\endcsname}% % % Supported encodings: names converted to tokens in order to be able % to compare them with \ifx. \def\ascii{\csname US-ASCII.enc\endcsname}% \def\latnine{\csname ISO-8859-15.enc\endcsname}% \def\latone{\csname ISO-8859-1.enc\endcsname}% \def\lattwo{\csname ISO-8859-2.enc\endcsname}% \def\utfeight{\csname UTF-8.enc\endcsname}% % \ifx \declaredencoding \ascii \asciichardefs % \else \ifx \declaredencoding \lattwo \iftxinativeunicodecapable \setbytewiseio \fi \setnonasciicharscatcode\active \lattwochardefs % \else \ifx \declaredencoding \latone \iftxinativeunicodecapable \setbytewiseio \fi \setnonasciicharscatcode\active \latonechardefs % \else \ifx \declaredencoding \latnine \iftxinativeunicodecapable \setbytewiseio \fi \setnonasciicharscatcode\active \latninechardefs % \else \ifx \declaredencoding \utfeight \iftxinativeunicodecapable % For native Unicode handling (XeTeX and LuaTeX) \nativeunicodechardefs \else % For treating UTF-8 as byte sequences (TeX, eTeX and pdfTeX). % Since we already invoke \utfeightchardefs at the top level, % making non-ascii chars active is sufficient. \setnonasciicharscatcode\active \fi % \else \message{Ignoring unknown document encoding: #1.}% % \fi % utfeight \fi % latnine \fi % latone \fi % lattwo \fi % ascii % \ifx\XeTeXrevision\thisisundefined \else \ifx \declaredencoding \utfeight \else \ifx \declaredencoding \ascii \else \message{Warning: XeTeX with non-UTF-8 encodings cannot handle % non-ASCII characters in auxiliary files.}% \fi \fi \fi } % A message to be logged when using a character that isn't available % the default font encoding (OT1). % \def\missingcharmsg#1{\message{Character missing, sorry: #1.}} % Take account of \c (plain) vs. \, (Texinfo) difference. \def\cedilla#1{\ifx\c\ptexc\c{#1}\else\,{#1}\fi} \def\gdefchar#1#2{% \gdef#1{% \ifpassthroughchars \string#1% \else #2% \fi }} \begingroup % Make non-ASCII characters active for defining the character definition % macros. \setnonasciicharscatcode\active % Latin1 (ISO-8859-1) character definitions. \gdef\latonechardefs{% \gdefchar^^a0{\tie} \gdefchar^^a1{\exclamdown} \gdefchar^^a2{{\tcfont \char162}} % cent \gdefchar^^a3{\pounds{}} \gdefchar^^a4{{\tcfont \char164}} % currency \gdefchar^^a5{{\tcfont \char165}} % yen \gdefchar^^a6{{\tcfont \char166}} % broken bar \gdefchar^^a7{\S} \gdefchar^^a8{\"{}} \gdefchar^^a9{\copyright{}} \gdefchar^^aa{\ordf} \gdefchar^^ab{\guillemetleft{}} \gdefchar^^ac{\ensuremath\lnot} \gdefchar^^ad{\-} \gdefchar^^ae{\registeredsymbol{}} \gdefchar^^af{\={}} % \gdefchar^^b0{\textdegree} \gdefchar^^b1{$\pm$} \gdefchar^^b2{$^2$} \gdefchar^^b3{$^3$} \gdefchar^^b4{\'{}} \gdefchar^^b5{$\mu$} \gdefchar^^b6{\P} \gdefchar^^b7{\ensuremath\cdot} \gdefchar^^b8{\cedilla\ } \gdefchar^^b9{$^1$} \gdefchar^^ba{\ordm} \gdefchar^^bb{\guillemetright{}} \gdefchar^^bc{$1\over4$} \gdefchar^^bd{$1\over2$} \gdefchar^^be{$3\over4$} \gdefchar^^bf{\questiondown} % \gdefchar^^c0{\`A} \gdefchar^^c1{\'A} \gdefchar^^c2{\^A} \gdefchar^^c3{\~A} \gdefchar^^c4{\"A} \gdefchar^^c5{\ringaccent A} \gdefchar^^c6{\AE} \gdefchar^^c7{\cedilla C} \gdefchar^^c8{\`E} \gdefchar^^c9{\'E} \gdefchar^^ca{\^E} \gdefchar^^cb{\"E} \gdefchar^^cc{\`I} \gdefchar^^cd{\'I} \gdefchar^^ce{\^I} \gdefchar^^cf{\"I} % \gdefchar^^d0{\DH} \gdefchar^^d1{\~N} \gdefchar^^d2{\`O} \gdefchar^^d3{\'O} \gdefchar^^d4{\^O} \gdefchar^^d5{\~O} \gdefchar^^d6{\"O} \gdefchar^^d7{$\times$} \gdefchar^^d8{\O} \gdefchar^^d9{\`U} \gdefchar^^da{\'U} \gdefchar^^db{\^U} \gdefchar^^dc{\"U} \gdefchar^^dd{\'Y} \gdefchar^^de{\TH} \gdefchar^^df{\ss} % \gdefchar^^e0{\`a} \gdefchar^^e1{\'a} \gdefchar^^e2{\^a} \gdefchar^^e3{\~a} \gdefchar^^e4{\"a} \gdefchar^^e5{\ringaccent a} \gdefchar^^e6{\ae} \gdefchar^^e7{\cedilla c} \gdefchar^^e8{\`e} \gdefchar^^e9{\'e} \gdefchar^^ea{\^e} \gdefchar^^eb{\"e} \gdefchar^^ec{\`{\dotless i}} \gdefchar^^ed{\'{\dotless i}} \gdefchar^^ee{\^{\dotless i}} \gdefchar^^ef{\"{\dotless i}} % \gdefchar^^f0{\dh} \gdefchar^^f1{\~n} \gdefchar^^f2{\`o} \gdefchar^^f3{\'o} \gdefchar^^f4{\^o} \gdefchar^^f5{\~o} \gdefchar^^f6{\"o} \gdefchar^^f7{$\div$} \gdefchar^^f8{\o} \gdefchar^^f9{\`u} \gdefchar^^fa{\'u} \gdefchar^^fb{\^u} \gdefchar^^fc{\"u} \gdefchar^^fd{\'y} \gdefchar^^fe{\th} \gdefchar^^ff{\"y} } % Latin9 (ISO-8859-15) encoding character definitions. \gdef\latninechardefs{% % Encoding is almost identical to Latin1. \latonechardefs % \gdefchar^^a4{\euro{}} \gdefchar^^a6{\v S} \gdefchar^^a8{\v s} \gdefchar^^b4{\v Z} \gdefchar^^b8{\v z} \gdefchar^^bc{\OE} \gdefchar^^bd{\oe} \gdefchar^^be{\"Y} } % Latin2 (ISO-8859-2) character definitions. \gdef\lattwochardefs{% \gdefchar^^a0{\tie} \gdefchar^^a1{\ogonek{A}} \gdefchar^^a2{\u{}} \gdefchar^^a3{\L} \gdefchar^^a4{\missingcharmsg{CURRENCY SIGN}} \gdefchar^^a5{\v L} \gdefchar^^a6{\'S} \gdefchar^^a7{\S} \gdefchar^^a8{\"{}} \gdefchar^^a9{\v S} \gdefchar^^aa{\cedilla S} \gdefchar^^ab{\v T} \gdefchar^^ac{\'Z} \gdefchar^^ad{\-} \gdefchar^^ae{\v Z} \gdefchar^^af{\dotaccent Z} % \gdefchar^^b0{\textdegree} \gdefchar^^b1{\ogonek{a}} \gdefchar^^b2{\ogonek{ }} \gdefchar^^b3{\l} \gdefchar^^b4{\'{}} \gdefchar^^b5{\v l} \gdefchar^^b6{\'s} \gdefchar^^b7{\v{}} \gdefchar^^b8{\cedilla\ } \gdefchar^^b9{\v s} \gdefchar^^ba{\cedilla s} \gdefchar^^bb{\v t} \gdefchar^^bc{\'z} \gdefchar^^bd{\H{}} \gdefchar^^be{\v z} \gdefchar^^bf{\dotaccent z} % \gdefchar^^c0{\'R} \gdefchar^^c1{\'A} \gdefchar^^c2{\^A} \gdefchar^^c3{\u A} \gdefchar^^c4{\"A} \gdefchar^^c5{\'L} \gdefchar^^c6{\'C} \gdefchar^^c7{\cedilla C} \gdefchar^^c8{\v C} \gdefchar^^c9{\'E} \gdefchar^^ca{\ogonek{E}} \gdefchar^^cb{\"E} \gdefchar^^cc{\v E} \gdefchar^^cd{\'I} \gdefchar^^ce{\^I} \gdefchar^^cf{\v D} % \gdefchar^^d0{\DH} \gdefchar^^d1{\'N} \gdefchar^^d2{\v N} \gdefchar^^d3{\'O} \gdefchar^^d4{\^O} \gdefchar^^d5{\H O} \gdefchar^^d6{\"O} \gdefchar^^d7{$\times$} \gdefchar^^d8{\v R} \gdefchar^^d9{\ringaccent U} \gdefchar^^da{\'U} \gdefchar^^db{\H U} \gdefchar^^dc{\"U} \gdefchar^^dd{\'Y} \gdefchar^^de{\cedilla T} \gdefchar^^df{\ss} % \gdefchar^^e0{\'r} \gdefchar^^e1{\'a} \gdefchar^^e2{\^a} \gdefchar^^e3{\u a} \gdefchar^^e4{\"a} \gdefchar^^e5{\'l} \gdefchar^^e6{\'c} \gdefchar^^e7{\cedilla c} \gdefchar^^e8{\v c} \gdefchar^^e9{\'e} \gdefchar^^ea{\ogonek{e}} \gdefchar^^eb{\"e} \gdefchar^^ec{\v e} \gdefchar^^ed{\'{\dotless{i}}} \gdefchar^^ee{\^{\dotless{i}}} \gdefchar^^ef{\v d} % \gdefchar^^f0{\dh} \gdefchar^^f1{\'n} \gdefchar^^f2{\v n} \gdefchar^^f3{\'o} \gdefchar^^f4{\^o} \gdefchar^^f5{\H o} \gdefchar^^f6{\"o} \gdefchar^^f7{$\div$} \gdefchar^^f8{\v r} \gdefchar^^f9{\ringaccent u} \gdefchar^^fa{\'u} \gdefchar^^fb{\H u} \gdefchar^^fc{\"u} \gdefchar^^fd{\'y} \gdefchar^^fe{\cedilla t} \gdefchar^^ff{\dotaccent{}} } \endgroup % active chars % UTF-8 character definitions. % % This code to support UTF-8 is based on LaTeX's utf8.def, with some % changes for Texinfo conventions. It is included here under the GPL by % permission from Frank Mittelbach and the LaTeX team. % \newcount\countUTFx \newcount\countUTFy \newcount\countUTFz \gdef\UTFviiiTwoOctets#1#2{\expandafter \UTFviiiDefined\csname u8:#1\string #2\endcsname} % \gdef\UTFviiiThreeOctets#1#2#3{\expandafter \UTFviiiDefined\csname u8:#1\string #2\string #3\endcsname} % \gdef\UTFviiiFourOctets#1#2#3#4{\expandafter \UTFviiiDefined\csname u8:#1\string #2\string #3\string #4\endcsname} \gdef\UTFviiiDefined#1{% \ifx #1\relax \message{\linenumber Unicode char \string #1 not defined for Texinfo}% \else \expandafter #1% \fi } % Give non-ASCII bytes the active definitions for processing UTF-8 sequences \begingroup \catcode`\~13 \catcode`\$12 \catcode`\"12 % Loop from \countUTFx to \countUTFy, performing \UTFviiiTmp % substituting ~ and $ with a character token of that value. \def\UTFviiiLoop{% \global\catcode\countUTFx\active \uccode`\~\countUTFx \uccode`\$\countUTFx \uppercase\expandafter{\UTFviiiTmp}% \advance\countUTFx by 1 \ifnum\countUTFx < \countUTFy \expandafter\UTFviiiLoop \fi} % For bytes other than the first in a UTF-8 sequence. Not expected to % be expanded except when writing to auxiliary files. \countUTFx = "80 \countUTFy = "C2 \def\UTFviiiTmp{% \gdef~{% \ifpassthroughchars $\fi}}% \UTFviiiLoop \countUTFx = "C2 \countUTFy = "E0 \def\UTFviiiTmp{% \gdef~{% \ifpassthroughchars $% \else\expandafter\UTFviiiTwoOctets\expandafter$\fi}}% \UTFviiiLoop \countUTFx = "E0 \countUTFy = "F0 \def\UTFviiiTmp{% \gdef~{% \ifpassthroughchars $% \else\expandafter\UTFviiiThreeOctets\expandafter$\fi}}% \UTFviiiLoop \countUTFx = "F0 \countUTFy = "F4 \def\UTFviiiTmp{% \gdef~{% \ifpassthroughchars $% \else\expandafter\UTFviiiFourOctets\expandafter$\fi }}% \UTFviiiLoop \endgroup \def\globallet{\global\let} % save some \expandafter's below % @U{xxxx} to produce U+xxxx, if we support it. \def\U#1{% \expandafter\ifx\csname uni:#1\endcsname \relax \iftxinativeunicodecapable % All Unicode characters can be used if native Unicode handling is % active. However, if the font does not have the glyph, % letters are missing. \begingroup \uccode`\.="#1\relax \uppercase{.} \endgroup \else \errhelp = \EMsimple \errmessage{Unicode character U+#1 not supported, sorry}% \fi \else \csname uni:#1\endcsname \fi } % These macros are used here to construct the name of a control % sequence to be defined. \def\UTFviiiTwoOctetsName#1#2{% \csname u8:#1\string #2\endcsname}% \def\UTFviiiThreeOctetsName#1#2#3{% \csname u8:#1\string #2\string #3\endcsname}% \def\UTFviiiFourOctetsName#1#2#3#4{% \csname u8:#1\string #2\string #3\string #4\endcsname}% % For UTF-8 byte sequences (TeX, e-TeX and pdfTeX), % provide a definition macro to replace a Unicode character; % this gets used by the @U command % \begingroup \catcode`\"=12 \catcode`\<=12 \catcode`\.=12 \catcode`\,=12 \catcode`\;=12 \catcode`\!=12 \catcode`\~=13 \gdef\DeclareUnicodeCharacterUTFviii#1#2{% \countUTFz = "#1\relax \begingroup \parseXMLCharref % Give \u8:... its definition. The sequence of seven \expandafter's % expands after the \gdef three times, e.g. % % 1. \UTFviiTwoOctetsName B1 B2 % 2. \csname u8:B1 \string B2 \endcsname % 3. \u8: B1 B2 (a single control sequence token) % \expandafter\expandafter \expandafter\expandafter \expandafter\expandafter \expandafter\gdef \UTFviiiTmp{#2}% % \expandafter\ifx\csname uni:#1\endcsname \relax \else \message{Internal error, already defined: #1}% \fi % % define an additional control sequence for this code point. \expandafter\globallet\csname uni:#1\endcsname \UTFviiiTmp \endgroup} % % Given the value in \countUTFz as a Unicode code point, set \UTFviiiTmp % to the corresponding UTF-8 sequence. \gdef\parseXMLCharref{% \ifnum\countUTFz < "20\relax \errhelp = \EMsimple \errmessage{Cannot define Unicode char value < 0020}% \else\ifnum\countUTFz < "800\relax \parseUTFviiiA,% \parseUTFviiiB C\UTFviiiTwoOctetsName.,% \else\ifnum\countUTFz < "10000\relax \parseUTFviiiA;% \parseUTFviiiA,% \parseUTFviiiB E\UTFviiiThreeOctetsName.{,;}% \else \parseUTFviiiA;% \parseUTFviiiA,% \parseUTFviiiA!% \parseUTFviiiB F\UTFviiiFourOctetsName.{!,;}% \fi\fi\fi } % Extract a byte from the end of the UTF-8 representation of \countUTFx. % It must be a non-initial byte in the sequence. % Change \uccode of #1 for it to be used in \parseUTFviiiB as one % of the bytes. \gdef\parseUTFviiiA#1{% \countUTFx = \countUTFz \divide\countUTFz by 64 \countUTFy = \countUTFz % Save to be the future value of \countUTFz. \multiply\countUTFz by 64 % \countUTFz is now \countUTFx with the last 5 bits cleared. Subtract % in order to get the last five bits. \advance\countUTFx by -\countUTFz % Convert this to the byte in the UTF-8 sequence. \advance\countUTFx by 128 \uccode `#1\countUTFx \countUTFz = \countUTFy} % Used to put a UTF-8 byte sequence into \UTFviiiTmp % #1 is the increment for \countUTFz to yield a the first byte of the UTF-8 % sequence. % #2 is one of the \UTFviii*OctetsName macros. % #3 is always a full stop (.) % #4 is a template for the other bytes in the sequence. The values for these % bytes is substituted in here with \uppercase using the \uccode's. \gdef\parseUTFviiiB#1#2#3#4{% \advance\countUTFz by "#10\relax \uccode `#3\countUTFz \uppercase{\gdef\UTFviiiTmp{#2#3#4}}} \endgroup % For native Unicode handling (XeTeX and LuaTeX), % provide a definition macro that sets a catcode to `other' non-globally % \def\DeclareUnicodeCharacterNativeOther#1#2{% \catcode"#1=\other } % https://en.wikipedia.org/wiki/Plane_(Unicode)#Basic_M % U+0000..U+007F = https://en.wikipedia.org/wiki/Basic_Latin_(Unicode_block) % U+0080..U+00FF = https://en.wikipedia.org/wiki/Latin-1_Supplement_(Unicode_block) % U+0100..U+017F = https://en.wikipedia.org/wiki/Latin_Extended-A % U+0180..U+024F = https://en.wikipedia.org/wiki/Latin_Extended-B % % Many of our renditions are less than wonderful, and all the missing % characters are available somewhere. Loading the necessary fonts % awaits user request. We can't truly support Unicode without % reimplementing everything that's been done in LaTeX for many years, % plus probably using luatex or xetex, and who knows what else. % We won't be doing that here in this simple file. But we can try to at % least make most of the characters not bomb out. % \def\unicodechardefs{% \DeclareUnicodeCharacter{0020}{ } % space \DeclareUnicodeCharacter{0021}{\char"21 }% % space to terminate number \DeclareUnicodeCharacter{0022}{\char"22 }% \DeclareUnicodeCharacter{0023}{\char"23 }% \DeclareUnicodeCharacter{0024}{\char"24 }% \DeclareUnicodeCharacter{0025}{\char"25 }% \DeclareUnicodeCharacter{0026}{\char"26 }% \DeclareUnicodeCharacter{0027}{\char"27 }% \DeclareUnicodeCharacter{0028}{\char"28 }% \DeclareUnicodeCharacter{0029}{\char"29 }% \DeclareUnicodeCharacter{002A}{\char"2A }% \DeclareUnicodeCharacter{002B}{\char"2B }% \DeclareUnicodeCharacter{002C}{\char"2C }% \DeclareUnicodeCharacter{002D}{\char"2D }% \DeclareUnicodeCharacter{002E}{\char"2E }% \DeclareUnicodeCharacter{002F}{\char"2F }% \DeclareUnicodeCharacter{0030}{0}% \DeclareUnicodeCharacter{0031}{1}% \DeclareUnicodeCharacter{0032}{2}% \DeclareUnicodeCharacter{0033}{3}% \DeclareUnicodeCharacter{0034}{4}% \DeclareUnicodeCharacter{0035}{5}% \DeclareUnicodeCharacter{0036}{6}% \DeclareUnicodeCharacter{0037}{7}% \DeclareUnicodeCharacter{0038}{8}% \DeclareUnicodeCharacter{0039}{9}% \DeclareUnicodeCharacter{003A}{\char"3A }% \DeclareUnicodeCharacter{003B}{\char"3B }% \DeclareUnicodeCharacter{003C}{\char"3C }% \DeclareUnicodeCharacter{003D}{\char"3D }% \DeclareUnicodeCharacter{003E}{\char"3E }% \DeclareUnicodeCharacter{003F}{\char"3F }% \DeclareUnicodeCharacter{0040}{\char"40 }% \DeclareUnicodeCharacter{0041}{A}% \DeclareUnicodeCharacter{0042}{B}% \DeclareUnicodeCharacter{0043}{C}% \DeclareUnicodeCharacter{0044}{D}% \DeclareUnicodeCharacter{0045}{E}% \DeclareUnicodeCharacter{0046}{F}% \DeclareUnicodeCharacter{0047}{G}% \DeclareUnicodeCharacter{0048}{H}% \DeclareUnicodeCharacter{0049}{I}% \DeclareUnicodeCharacter{004A}{J}% \DeclareUnicodeCharacter{004B}{K}% \DeclareUnicodeCharacter{004C}{L}% \DeclareUnicodeCharacter{004D}{M}% \DeclareUnicodeCharacter{004E}{N}% \DeclareUnicodeCharacter{004F}{O}% \DeclareUnicodeCharacter{0050}{P}% \DeclareUnicodeCharacter{0051}{Q}% \DeclareUnicodeCharacter{0052}{R}% \DeclareUnicodeCharacter{0053}{S}% \DeclareUnicodeCharacter{0054}{T}% \DeclareUnicodeCharacter{0055}{U}% \DeclareUnicodeCharacter{0056}{V}% \DeclareUnicodeCharacter{0057}{W}% \DeclareUnicodeCharacter{0058}{X}% \DeclareUnicodeCharacter{0059}{Y}% \DeclareUnicodeCharacter{005A}{Z}% \DeclareUnicodeCharacter{005B}{\char"5B }% \DeclareUnicodeCharacter{005C}{\char"5C }% \DeclareUnicodeCharacter{005D}{\char"5D }% \DeclareUnicodeCharacter{005E}{\char"5E }% \DeclareUnicodeCharacter{005F}{\char"5F }% \DeclareUnicodeCharacter{0060}{\char"60 }% \DeclareUnicodeCharacter{0061}{a}% \DeclareUnicodeCharacter{0062}{b}% \DeclareUnicodeCharacter{0063}{c}% \DeclareUnicodeCharacter{0064}{d}% \DeclareUnicodeCharacter{0065}{e}% \DeclareUnicodeCharacter{0066}{f}% \DeclareUnicodeCharacter{0067}{g}% \DeclareUnicodeCharacter{0068}{h}% \DeclareUnicodeCharacter{0069}{i}% \DeclareUnicodeCharacter{006A}{j}% \DeclareUnicodeCharacter{006B}{k}% \DeclareUnicodeCharacter{006C}{l}% \DeclareUnicodeCharacter{006D}{m}% \DeclareUnicodeCharacter{006E}{n}% \DeclareUnicodeCharacter{006F}{o}% \DeclareUnicodeCharacter{0070}{p}% \DeclareUnicodeCharacter{0071}{q}% \DeclareUnicodeCharacter{0072}{r}% \DeclareUnicodeCharacter{0073}{s}% \DeclareUnicodeCharacter{0074}{t}% \DeclareUnicodeCharacter{0075}{u}% \DeclareUnicodeCharacter{0076}{v}% \DeclareUnicodeCharacter{0077}{w}% \DeclareUnicodeCharacter{0078}{x}% \DeclareUnicodeCharacter{0079}{y}% \DeclareUnicodeCharacter{007A}{z}% \DeclareUnicodeCharacter{007B}{\char"7B }% \DeclareUnicodeCharacter{007C}{\char"7C }% \DeclareUnicodeCharacter{007D}{\char"7D }% \DeclareUnicodeCharacter{007E}{\char"7E }% % \DeclareUnicodeCharacter{007F}{} % DEL % \DeclareUnicodeCharacter{00A0}{\tie}% \DeclareUnicodeCharacter{00A1}{\exclamdown}% \DeclareUnicodeCharacter{00A2}{{\tcfont \char162}}% 0242=cent \DeclareUnicodeCharacter{00A3}{\pounds{}}% \DeclareUnicodeCharacter{00A4}{{\tcfont \char164}}% 0244=currency \DeclareUnicodeCharacter{00A5}{{\tcfont \char165}}% 0245=yen \DeclareUnicodeCharacter{00A6}{{\tcfont \char166}}% 0246=brokenbar \DeclareUnicodeCharacter{00A7}{\S}% \DeclareUnicodeCharacter{00A8}{\"{ }}% \DeclareUnicodeCharacter{00A9}{\copyright{}}% \DeclareUnicodeCharacter{00AA}{\ordf}% \DeclareUnicodeCharacter{00AB}{\guillemetleft{}}% \DeclareUnicodeCharacter{00AC}{\ensuremath\lnot}% \DeclareUnicodeCharacter{00AD}{\-}% \DeclareUnicodeCharacter{00AE}{\registeredsymbol{}}% \DeclareUnicodeCharacter{00AF}{\={ }}% % \DeclareUnicodeCharacter{00B0}{\textdegree}% \DeclareUnicodeCharacter{00B1}{\ensuremath\pm}% \DeclareUnicodeCharacter{00B2}{$^2$}% \DeclareUnicodeCharacter{00B3}{$^3$}% \DeclareUnicodeCharacter{00B4}{\'{ }}% \DeclareUnicodeCharacter{00B5}{$\mu$}% \DeclareUnicodeCharacter{00B6}{\P}% \DeclareUnicodeCharacter{00B7}{\ensuremath\cdot}% \DeclareUnicodeCharacter{00B8}{\cedilla{ }}% \DeclareUnicodeCharacter{00B9}{$^1$}% \DeclareUnicodeCharacter{00BA}{\ordm}% \DeclareUnicodeCharacter{00BB}{\guillemetright{}}% \DeclareUnicodeCharacter{00BC}{$1\over4$}% \DeclareUnicodeCharacter{00BD}{$1\over2$}% \DeclareUnicodeCharacter{00BE}{$3\over4$}% \DeclareUnicodeCharacter{00BF}{\questiondown}% % \DeclareUnicodeCharacter{00C0}{\`A}% \DeclareUnicodeCharacter{00C1}{\'A}% \DeclareUnicodeCharacter{00C2}{\^A}% \DeclareUnicodeCharacter{00C3}{\~A}% \DeclareUnicodeCharacter{00C4}{\"A}% \DeclareUnicodeCharacter{00C5}{\AA}% \DeclareUnicodeCharacter{00C6}{\AE}% \DeclareUnicodeCharacter{00C7}{\cedilla{C}}% \DeclareUnicodeCharacter{00C8}{\`E}% \DeclareUnicodeCharacter{00C9}{\'E}% \DeclareUnicodeCharacter{00CA}{\^E}% \DeclareUnicodeCharacter{00CB}{\"E}% \DeclareUnicodeCharacter{00CC}{\`I}% \DeclareUnicodeCharacter{00CD}{\'I}% \DeclareUnicodeCharacter{00CE}{\^I}% \DeclareUnicodeCharacter{00CF}{\"I}% % \DeclareUnicodeCharacter{00D0}{\DH}% \DeclareUnicodeCharacter{00D1}{\~N}% \DeclareUnicodeCharacter{00D2}{\`O}% \DeclareUnicodeCharacter{00D3}{\'O}% \DeclareUnicodeCharacter{00D4}{\^O}% \DeclareUnicodeCharacter{00D5}{\~O}% \DeclareUnicodeCharacter{00D6}{\"O}% \DeclareUnicodeCharacter{00D7}{\ensuremath\times}% \DeclareUnicodeCharacter{00D8}{\O}% \DeclareUnicodeCharacter{00D9}{\`U}% \DeclareUnicodeCharacter{00DA}{\'U}% \DeclareUnicodeCharacter{00DB}{\^U}% \DeclareUnicodeCharacter{00DC}{\"U}% \DeclareUnicodeCharacter{00DD}{\'Y}% \DeclareUnicodeCharacter{00DE}{\TH}% \DeclareUnicodeCharacter{00DF}{\ss}% % \DeclareUnicodeCharacter{00E0}{\`a}% \DeclareUnicodeCharacter{00E1}{\'a}% \DeclareUnicodeCharacter{00E2}{\^a}% \DeclareUnicodeCharacter{00E3}{\~a}% \DeclareUnicodeCharacter{00E4}{\"a}% \DeclareUnicodeCharacter{00E5}{\aa}% \DeclareUnicodeCharacter{00E6}{\ae}% \DeclareUnicodeCharacter{00E7}{\cedilla{c}}% \DeclareUnicodeCharacter{00E8}{\`e}% \DeclareUnicodeCharacter{00E9}{\'e}% \DeclareUnicodeCharacter{00EA}{\^e}% \DeclareUnicodeCharacter{00EB}{\"e}% \DeclareUnicodeCharacter{00EC}{\`{\dotless{i}}}% \DeclareUnicodeCharacter{00ED}{\'{\dotless{i}}}% \DeclareUnicodeCharacter{00EE}{\^{\dotless{i}}}% \DeclareUnicodeCharacter{00EF}{\"{\dotless{i}}}% % \DeclareUnicodeCharacter{00F0}{\dh}% \DeclareUnicodeCharacter{00F1}{\~n}% \DeclareUnicodeCharacter{00F2}{\`o}% \DeclareUnicodeCharacter{00F3}{\'o}% \DeclareUnicodeCharacter{00F4}{\^o}% \DeclareUnicodeCharacter{00F5}{\~o}% \DeclareUnicodeCharacter{00F6}{\"o}% \DeclareUnicodeCharacter{00F7}{\ensuremath\div}% \DeclareUnicodeCharacter{00F8}{\o}% \DeclareUnicodeCharacter{00F9}{\`u}% \DeclareUnicodeCharacter{00FA}{\'u}% \DeclareUnicodeCharacter{00FB}{\^u}% \DeclareUnicodeCharacter{00FC}{\"u}% \DeclareUnicodeCharacter{00FD}{\'y}% \DeclareUnicodeCharacter{00FE}{\th}% \DeclareUnicodeCharacter{00FF}{\"y}% % \DeclareUnicodeCharacter{0100}{\=A}% \DeclareUnicodeCharacter{0101}{\=a}% \DeclareUnicodeCharacter{0102}{\u{A}}% \DeclareUnicodeCharacter{0103}{\u{a}}% \DeclareUnicodeCharacter{0104}{\ogonek{A}}% \DeclareUnicodeCharacter{0105}{\ogonek{a}}% \DeclareUnicodeCharacter{0106}{\'C}% \DeclareUnicodeCharacter{0107}{\'c}% \DeclareUnicodeCharacter{0108}{\^C}% \DeclareUnicodeCharacter{0109}{\^c}% \DeclareUnicodeCharacter{010A}{\dotaccent{C}}% \DeclareUnicodeCharacter{010B}{\dotaccent{c}}% \DeclareUnicodeCharacter{010C}{\v{C}}% \DeclareUnicodeCharacter{010D}{\v{c}}% \DeclareUnicodeCharacter{010E}{\v{D}}% \DeclareUnicodeCharacter{010F}{d'}% % \DeclareUnicodeCharacter{0110}{\DH}% \DeclareUnicodeCharacter{0111}{\dh}% \DeclareUnicodeCharacter{0112}{\=E}% \DeclareUnicodeCharacter{0113}{\=e}% \DeclareUnicodeCharacter{0114}{\u{E}}% \DeclareUnicodeCharacter{0115}{\u{e}}% \DeclareUnicodeCharacter{0116}{\dotaccent{E}}% \DeclareUnicodeCharacter{0117}{\dotaccent{e}}% \DeclareUnicodeCharacter{0118}{\ogonek{E}}% \DeclareUnicodeCharacter{0119}{\ogonek{e}}% \DeclareUnicodeCharacter{011A}{\v{E}}% \DeclareUnicodeCharacter{011B}{\v{e}}% \DeclareUnicodeCharacter{011C}{\^G}% \DeclareUnicodeCharacter{011D}{\^g}% \DeclareUnicodeCharacter{011E}{\u{G}}% \DeclareUnicodeCharacter{011F}{\u{g}}% % \DeclareUnicodeCharacter{0120}{\dotaccent{G}}% \DeclareUnicodeCharacter{0121}{\dotaccent{g}}% \DeclareUnicodeCharacter{0122}{\cedilla{G}}% \DeclareUnicodeCharacter{0123}{\cedilla{g}}% \DeclareUnicodeCharacter{0124}{\^H}% \DeclareUnicodeCharacter{0125}{\^h}% \DeclareUnicodeCharacter{0126}{\missingcharmsg{H WITH STROKE}}% \DeclareUnicodeCharacter{0127}{\missingcharmsg{h WITH STROKE}}% \DeclareUnicodeCharacter{0128}{\~I}% \DeclareUnicodeCharacter{0129}{\~{\dotless{i}}}% \DeclareUnicodeCharacter{012A}{\=I}% \DeclareUnicodeCharacter{012B}{\={\dotless{i}}}% \DeclareUnicodeCharacter{012C}{\u{I}}% \DeclareUnicodeCharacter{012D}{\u{\dotless{i}}}% \DeclareUnicodeCharacter{012E}{\ogonek{I}}% \DeclareUnicodeCharacter{012F}{\ogonek{i}}% % \DeclareUnicodeCharacter{0130}{\dotaccent{I}}% \DeclareUnicodeCharacter{0131}{\dotless{i}}% \DeclareUnicodeCharacter{0132}{IJ}% \DeclareUnicodeCharacter{0133}{ij}% \DeclareUnicodeCharacter{0134}{\^J}% \DeclareUnicodeCharacter{0135}{\^{\dotless{j}}}% \DeclareUnicodeCharacter{0136}{\cedilla{K}}% \DeclareUnicodeCharacter{0137}{\cedilla{k}}% \DeclareUnicodeCharacter{0138}{\ensuremath\kappa}% \DeclareUnicodeCharacter{0139}{\'L}% \DeclareUnicodeCharacter{013A}{\'l}% \DeclareUnicodeCharacter{013B}{\cedilla{L}}% \DeclareUnicodeCharacter{013C}{\cedilla{l}}% \DeclareUnicodeCharacter{013D}{L'}% should kern \DeclareUnicodeCharacter{013E}{l'}% should kern \DeclareUnicodeCharacter{013F}{L\U{00B7}}% % \DeclareUnicodeCharacter{0140}{l\U{00B7}}% \DeclareUnicodeCharacter{0141}{\L}% \DeclareUnicodeCharacter{0142}{\l}% \DeclareUnicodeCharacter{0143}{\'N}% \DeclareUnicodeCharacter{0144}{\'n}% \DeclareUnicodeCharacter{0145}{\cedilla{N}}% \DeclareUnicodeCharacter{0146}{\cedilla{n}}% \DeclareUnicodeCharacter{0147}{\v{N}}% \DeclareUnicodeCharacter{0148}{\v{n}}% \DeclareUnicodeCharacter{0149}{'n}% \DeclareUnicodeCharacter{014A}{\missingcharmsg{ENG}}% \DeclareUnicodeCharacter{014B}{\missingcharmsg{eng}}% \DeclareUnicodeCharacter{014C}{\=O}% \DeclareUnicodeCharacter{014D}{\=o}% \DeclareUnicodeCharacter{014E}{\u{O}}% \DeclareUnicodeCharacter{014F}{\u{o}}% % \DeclareUnicodeCharacter{0150}{\H{O}}% \DeclareUnicodeCharacter{0151}{\H{o}}% \DeclareUnicodeCharacter{0152}{\OE}% \DeclareUnicodeCharacter{0153}{\oe}% \DeclareUnicodeCharacter{0154}{\'R}% \DeclareUnicodeCharacter{0155}{\'r}% \DeclareUnicodeCharacter{0156}{\cedilla{R}}% \DeclareUnicodeCharacter{0157}{\cedilla{r}}% \DeclareUnicodeCharacter{0158}{\v{R}}% \DeclareUnicodeCharacter{0159}{\v{r}}% \DeclareUnicodeCharacter{015A}{\'S}% \DeclareUnicodeCharacter{015B}{\'s}% \DeclareUnicodeCharacter{015C}{\^S}% \DeclareUnicodeCharacter{015D}{\^s}% \DeclareUnicodeCharacter{015E}{\cedilla{S}}% \DeclareUnicodeCharacter{015F}{\cedilla{s}}% % \DeclareUnicodeCharacter{0160}{\v{S}}% \DeclareUnicodeCharacter{0161}{\v{s}}% \DeclareUnicodeCharacter{0162}{\cedilla{T}}% \DeclareUnicodeCharacter{0163}{\cedilla{t}}% \DeclareUnicodeCharacter{0164}{\v{T}}% \DeclareUnicodeCharacter{0165}{\v{t}}% \DeclareUnicodeCharacter{0166}{\missingcharmsg{H WITH STROKE}}% \DeclareUnicodeCharacter{0167}{\missingcharmsg{h WITH STROKE}}% \DeclareUnicodeCharacter{0168}{\~U}% \DeclareUnicodeCharacter{0169}{\~u}% \DeclareUnicodeCharacter{016A}{\=U}% \DeclareUnicodeCharacter{016B}{\=u}% \DeclareUnicodeCharacter{016C}{\u{U}}% \DeclareUnicodeCharacter{016D}{\u{u}}% \DeclareUnicodeCharacter{016E}{\ringaccent{U}}% \DeclareUnicodeCharacter{016F}{\ringaccent{u}}% % \DeclareUnicodeCharacter{0170}{\H{U}}% \DeclareUnicodeCharacter{0171}{\H{u}}% \DeclareUnicodeCharacter{0172}{\ogonek{U}}% \DeclareUnicodeCharacter{0173}{\ogonek{u}}% \DeclareUnicodeCharacter{0174}{\^W}% \DeclareUnicodeCharacter{0175}{\^w}% \DeclareUnicodeCharacter{0176}{\^Y}% \DeclareUnicodeCharacter{0177}{\^y}% \DeclareUnicodeCharacter{0178}{\"Y}% \DeclareUnicodeCharacter{0179}{\'Z}% \DeclareUnicodeCharacter{017A}{\'z}% \DeclareUnicodeCharacter{017B}{\dotaccent{Z}}% \DeclareUnicodeCharacter{017C}{\dotaccent{z}}% \DeclareUnicodeCharacter{017D}{\v{Z}}% \DeclareUnicodeCharacter{017E}{\v{z}}% \DeclareUnicodeCharacter{017F}{\missingcharmsg{LONG S}}% % \DeclareUnicodeCharacter{01C4}{D\v{Z}}% \DeclareUnicodeCharacter{01C5}{D\v{z}}% \DeclareUnicodeCharacter{01C6}{d\v{z}}% \DeclareUnicodeCharacter{01C7}{LJ}% \DeclareUnicodeCharacter{01C8}{Lj}% \DeclareUnicodeCharacter{01C9}{lj}% \DeclareUnicodeCharacter{01CA}{NJ}% \DeclareUnicodeCharacter{01CB}{Nj}% \DeclareUnicodeCharacter{01CC}{nj}% \DeclareUnicodeCharacter{01CD}{\v{A}}% \DeclareUnicodeCharacter{01CE}{\v{a}}% \DeclareUnicodeCharacter{01CF}{\v{I}}% % \DeclareUnicodeCharacter{01D0}{\v{\dotless{i}}}% \DeclareUnicodeCharacter{01D1}{\v{O}}% \DeclareUnicodeCharacter{01D2}{\v{o}}% \DeclareUnicodeCharacter{01D3}{\v{U}}% \DeclareUnicodeCharacter{01D4}{\v{u}}% % \DeclareUnicodeCharacter{01E2}{\={\AE}}% \DeclareUnicodeCharacter{01E3}{\={\ae}}% \DeclareUnicodeCharacter{01E6}{\v{G}}% \DeclareUnicodeCharacter{01E7}{\v{g}}% \DeclareUnicodeCharacter{01E8}{\v{K}}% \DeclareUnicodeCharacter{01E9}{\v{k}}% % \DeclareUnicodeCharacter{01F0}{\v{\dotless{j}}}% \DeclareUnicodeCharacter{01F1}{DZ}% \DeclareUnicodeCharacter{01F2}{Dz}% \DeclareUnicodeCharacter{01F3}{dz}% \DeclareUnicodeCharacter{01F4}{\'G}% \DeclareUnicodeCharacter{01F5}{\'g}% \DeclareUnicodeCharacter{01F8}{\`N}% \DeclareUnicodeCharacter{01F9}{\`n}% \DeclareUnicodeCharacter{01FC}{\'{\AE}}% \DeclareUnicodeCharacter{01FD}{\'{\ae}}% \DeclareUnicodeCharacter{01FE}{\'{\O}}% \DeclareUnicodeCharacter{01FF}{\'{\o}}% % \DeclareUnicodeCharacter{021E}{\v{H}}% \DeclareUnicodeCharacter{021F}{\v{h}}% % \DeclareUnicodeCharacter{0226}{\dotaccent{A}}% \DeclareUnicodeCharacter{0227}{\dotaccent{a}}% \DeclareUnicodeCharacter{0228}{\cedilla{E}}% \DeclareUnicodeCharacter{0229}{\cedilla{e}}% \DeclareUnicodeCharacter{022E}{\dotaccent{O}}% \DeclareUnicodeCharacter{022F}{\dotaccent{o}}% % \DeclareUnicodeCharacter{0232}{\=Y}% \DeclareUnicodeCharacter{0233}{\=y}% \DeclareUnicodeCharacter{0237}{\dotless{j}}% % \DeclareUnicodeCharacter{02BC}{'}% % \DeclareUnicodeCharacter{02DB}{\ogonek{ }}% % % Greek letters upper case \DeclareUnicodeCharacter{0391}{{\it A}}% \DeclareUnicodeCharacter{0392}{{\it B}}% \DeclareUnicodeCharacter{0393}{\ensuremath{\mit\Gamma}}% \DeclareUnicodeCharacter{0394}{\ensuremath{\mit\Delta}}% \DeclareUnicodeCharacter{0395}{{\it E}}% \DeclareUnicodeCharacter{0396}{{\it Z}}% \DeclareUnicodeCharacter{0397}{{\it H}}% \DeclareUnicodeCharacter{0398}{\ensuremath{\mit\Theta}}% \DeclareUnicodeCharacter{0399}{{\it I}}% \DeclareUnicodeCharacter{039A}{{\it K}}% \DeclareUnicodeCharacter{039B}{\ensuremath{\mit\Lambda}}% \DeclareUnicodeCharacter{039C}{{\it M}}% \DeclareUnicodeCharacter{039D}{{\it N}}% \DeclareUnicodeCharacter{039E}{\ensuremath{\mit\Xi}}% \DeclareUnicodeCharacter{039F}{{\it O}}% \DeclareUnicodeCharacter{03A0}{\ensuremath{\mit\Pi}}% \DeclareUnicodeCharacter{03A1}{{\it P}}% %\DeclareUnicodeCharacter{03A2}{} % none - corresponds to final sigma \DeclareUnicodeCharacter{03A3}{\ensuremath{\mit\Sigma}}% \DeclareUnicodeCharacter{03A4}{{\it T}}% \DeclareUnicodeCharacter{03A5}{\ensuremath{\mit\Upsilon}}% \DeclareUnicodeCharacter{03A6}{\ensuremath{\mit\Phi}}% \DeclareUnicodeCharacter{03A7}{{\it X}}% \DeclareUnicodeCharacter{03A8}{\ensuremath{\mit\Psi}}% \DeclareUnicodeCharacter{03A9}{\ensuremath{\mit\Omega}}% % % Vowels with accents \DeclareUnicodeCharacter{0390}{\ensuremath{\ddot{\acute\iota}}}% \DeclareUnicodeCharacter{03AC}{\ensuremath{\acute\alpha}}% \DeclareUnicodeCharacter{03AD}{\ensuremath{\acute\epsilon}}% \DeclareUnicodeCharacter{03AE}{\ensuremath{\acute\eta}}% \DeclareUnicodeCharacter{03AF}{\ensuremath{\acute\iota}}% \DeclareUnicodeCharacter{03B0}{\ensuremath{\acute{\ddot\upsilon}}}% % % Standalone accent \DeclareUnicodeCharacter{0384}{\ensuremath{\acute{\ }}}% % % Greek letters lower case \DeclareUnicodeCharacter{03B1}{\ensuremath\alpha}% \DeclareUnicodeCharacter{03B2}{\ensuremath\beta}% \DeclareUnicodeCharacter{03B3}{\ensuremath\gamma}% \DeclareUnicodeCharacter{03B4}{\ensuremath\delta}% \DeclareUnicodeCharacter{03B5}{\ensuremath\epsilon}% \DeclareUnicodeCharacter{03B6}{\ensuremath\zeta}% \DeclareUnicodeCharacter{03B7}{\ensuremath\eta}% \DeclareUnicodeCharacter{03B8}{\ensuremath\theta}% \DeclareUnicodeCharacter{03B9}{\ensuremath\iota}% \DeclareUnicodeCharacter{03BA}{\ensuremath\kappa}% \DeclareUnicodeCharacter{03BB}{\ensuremath\lambda}% \DeclareUnicodeCharacter{03BC}{\ensuremath\mu}% \DeclareUnicodeCharacter{03BD}{\ensuremath\nu}% \DeclareUnicodeCharacter{03BE}{\ensuremath\xi}% \DeclareUnicodeCharacter{03BF}{{\it o}}% omicron \DeclareUnicodeCharacter{03C0}{\ensuremath\pi}% \DeclareUnicodeCharacter{03C1}{\ensuremath\rho}% \DeclareUnicodeCharacter{03C2}{\ensuremath\varsigma}% \DeclareUnicodeCharacter{03C3}{\ensuremath\sigma}% \DeclareUnicodeCharacter{03C4}{\ensuremath\tau}% \DeclareUnicodeCharacter{03C5}{\ensuremath\upsilon}% \DeclareUnicodeCharacter{03C6}{\ensuremath\phi}% \DeclareUnicodeCharacter{03C7}{\ensuremath\chi}% \DeclareUnicodeCharacter{03C8}{\ensuremath\psi}% \DeclareUnicodeCharacter{03C9}{\ensuremath\omega}% % % More Greek vowels with accents \DeclareUnicodeCharacter{03CA}{\ensuremath{\ddot\iota}}% \DeclareUnicodeCharacter{03CB}{\ensuremath{\ddot\upsilon}}% \DeclareUnicodeCharacter{03CC}{\ensuremath{\acute o}}% \DeclareUnicodeCharacter{03CD}{\ensuremath{\acute\upsilon}}% \DeclareUnicodeCharacter{03CE}{\ensuremath{\acute\omega}}% % % Variant Greek letters \DeclareUnicodeCharacter{03D1}{\ensuremath\vartheta}% \DeclareUnicodeCharacter{03D6}{\ensuremath\varpi}% \DeclareUnicodeCharacter{03F1}{\ensuremath\varrho}% % \DeclareUnicodeCharacter{1E02}{\dotaccent{B}}% \DeclareUnicodeCharacter{1E03}{\dotaccent{b}}% \DeclareUnicodeCharacter{1E04}{\udotaccent{B}}% \DeclareUnicodeCharacter{1E05}{\udotaccent{b}}% \DeclareUnicodeCharacter{1E06}{\ubaraccent{B}}% \DeclareUnicodeCharacter{1E07}{\ubaraccent{b}}% \DeclareUnicodeCharacter{1E0A}{\dotaccent{D}}% \DeclareUnicodeCharacter{1E0B}{\dotaccent{d}}% \DeclareUnicodeCharacter{1E0C}{\udotaccent{D}}% \DeclareUnicodeCharacter{1E0D}{\udotaccent{d}}% \DeclareUnicodeCharacter{1E0E}{\ubaraccent{D}}% \DeclareUnicodeCharacter{1E0F}{\ubaraccent{d}}% % \DeclareUnicodeCharacter{1E1E}{\dotaccent{F}}% \DeclareUnicodeCharacter{1E1F}{\dotaccent{f}}% % \DeclareUnicodeCharacter{1E20}{\=G}% \DeclareUnicodeCharacter{1E21}{\=g}% \DeclareUnicodeCharacter{1E22}{\dotaccent{H}}% \DeclareUnicodeCharacter{1E23}{\dotaccent{h}}% \DeclareUnicodeCharacter{1E24}{\udotaccent{H}}% \DeclareUnicodeCharacter{1E25}{\udotaccent{h}}% \DeclareUnicodeCharacter{1E26}{\"H}% \DeclareUnicodeCharacter{1E27}{\"h}% % \DeclareUnicodeCharacter{1E30}{\'K}% \DeclareUnicodeCharacter{1E31}{\'k}% \DeclareUnicodeCharacter{1E32}{\udotaccent{K}}% \DeclareUnicodeCharacter{1E33}{\udotaccent{k}}% \DeclareUnicodeCharacter{1E34}{\ubaraccent{K}}% \DeclareUnicodeCharacter{1E35}{\ubaraccent{k}}% \DeclareUnicodeCharacter{1E36}{\udotaccent{L}}% \DeclareUnicodeCharacter{1E37}{\udotaccent{l}}% \DeclareUnicodeCharacter{1E3A}{\ubaraccent{L}}% \DeclareUnicodeCharacter{1E3B}{\ubaraccent{l}}% \DeclareUnicodeCharacter{1E3E}{\'M}% \DeclareUnicodeCharacter{1E3F}{\'m}% % \DeclareUnicodeCharacter{1E40}{\dotaccent{M}}% \DeclareUnicodeCharacter{1E41}{\dotaccent{m}}% \DeclareUnicodeCharacter{1E42}{\udotaccent{M}}% \DeclareUnicodeCharacter{1E43}{\udotaccent{m}}% \DeclareUnicodeCharacter{1E44}{\dotaccent{N}}% \DeclareUnicodeCharacter{1E45}{\dotaccent{n}}% \DeclareUnicodeCharacter{1E46}{\udotaccent{N}}% \DeclareUnicodeCharacter{1E47}{\udotaccent{n}}% \DeclareUnicodeCharacter{1E48}{\ubaraccent{N}}% \DeclareUnicodeCharacter{1E49}{\ubaraccent{n}}% % \DeclareUnicodeCharacter{1E54}{\'P}% \DeclareUnicodeCharacter{1E55}{\'p}% \DeclareUnicodeCharacter{1E56}{\dotaccent{P}}% \DeclareUnicodeCharacter{1E57}{\dotaccent{p}}% \DeclareUnicodeCharacter{1E58}{\dotaccent{R}}% \DeclareUnicodeCharacter{1E59}{\dotaccent{r}}% \DeclareUnicodeCharacter{1E5A}{\udotaccent{R}}% \DeclareUnicodeCharacter{1E5B}{\udotaccent{r}}% \DeclareUnicodeCharacter{1E5E}{\ubaraccent{R}}% \DeclareUnicodeCharacter{1E5F}{\ubaraccent{r}}% % \DeclareUnicodeCharacter{1E60}{\dotaccent{S}}% \DeclareUnicodeCharacter{1E61}{\dotaccent{s}}% \DeclareUnicodeCharacter{1E62}{\udotaccent{S}}% \DeclareUnicodeCharacter{1E63}{\udotaccent{s}}% \DeclareUnicodeCharacter{1E6A}{\dotaccent{T}}% \DeclareUnicodeCharacter{1E6B}{\dotaccent{t}}% \DeclareUnicodeCharacter{1E6C}{\udotaccent{T}}% \DeclareUnicodeCharacter{1E6D}{\udotaccent{t}}% \DeclareUnicodeCharacter{1E6E}{\ubaraccent{T}}% \DeclareUnicodeCharacter{1E6F}{\ubaraccent{t}}% % \DeclareUnicodeCharacter{1E7C}{\~V}% \DeclareUnicodeCharacter{1E7D}{\~v}% \DeclareUnicodeCharacter{1E7E}{\udotaccent{V}}% \DeclareUnicodeCharacter{1E7F}{\udotaccent{v}}% % \DeclareUnicodeCharacter{1E80}{\`W}% \DeclareUnicodeCharacter{1E81}{\`w}% \DeclareUnicodeCharacter{1E82}{\'W}% \DeclareUnicodeCharacter{1E83}{\'w}% \DeclareUnicodeCharacter{1E84}{\"W}% \DeclareUnicodeCharacter{1E85}{\"w}% \DeclareUnicodeCharacter{1E86}{\dotaccent{W}}% \DeclareUnicodeCharacter{1E87}{\dotaccent{w}}% \DeclareUnicodeCharacter{1E88}{\udotaccent{W}}% \DeclareUnicodeCharacter{1E89}{\udotaccent{w}}% \DeclareUnicodeCharacter{1E8A}{\dotaccent{X}}% \DeclareUnicodeCharacter{1E8B}{\dotaccent{x}}% \DeclareUnicodeCharacter{1E8C}{\"X}% \DeclareUnicodeCharacter{1E8D}{\"x}% \DeclareUnicodeCharacter{1E8E}{\dotaccent{Y}}% \DeclareUnicodeCharacter{1E8F}{\dotaccent{y}}% % \DeclareUnicodeCharacter{1E90}{\^Z}% \DeclareUnicodeCharacter{1E91}{\^z}% \DeclareUnicodeCharacter{1E92}{\udotaccent{Z}}% \DeclareUnicodeCharacter{1E93}{\udotaccent{z}}% \DeclareUnicodeCharacter{1E94}{\ubaraccent{Z}}% \DeclareUnicodeCharacter{1E95}{\ubaraccent{z}}% \DeclareUnicodeCharacter{1E96}{\ubaraccent{h}}% \DeclareUnicodeCharacter{1E97}{\"t}% \DeclareUnicodeCharacter{1E98}{\ringaccent{w}}% \DeclareUnicodeCharacter{1E99}{\ringaccent{y}}% % \DeclareUnicodeCharacter{1EA0}{\udotaccent{A}}% \DeclareUnicodeCharacter{1EA1}{\udotaccent{a}}% % \DeclareUnicodeCharacter{1EB8}{\udotaccent{E}}% \DeclareUnicodeCharacter{1EB9}{\udotaccent{e}}% \DeclareUnicodeCharacter{1EBC}{\~E}% \DeclareUnicodeCharacter{1EBD}{\~e}% % \DeclareUnicodeCharacter{1ECA}{\udotaccent{I}}% \DeclareUnicodeCharacter{1ECB}{\udotaccent{i}}% \DeclareUnicodeCharacter{1ECC}{\udotaccent{O}}% \DeclareUnicodeCharacter{1ECD}{\udotaccent{o}}% % \DeclareUnicodeCharacter{1EE4}{\udotaccent{U}}% \DeclareUnicodeCharacter{1EE5}{\udotaccent{u}}% % \DeclareUnicodeCharacter{1EF2}{\`Y}% \DeclareUnicodeCharacter{1EF3}{\`y}% \DeclareUnicodeCharacter{1EF4}{\udotaccent{Y}}% % \DeclareUnicodeCharacter{1EF8}{\~Y}% \DeclareUnicodeCharacter{1EF9}{\~y}% % % Exotic spaces \DeclareUnicodeCharacter{2007}{\hphantom{0}}% % % Punctuation \DeclareUnicodeCharacter{2013}{--}% \DeclareUnicodeCharacter{2014}{---}% \DeclareUnicodeCharacter{2018}{\quoteleft{}}% \DeclareUnicodeCharacter{2019}{\quoteright{}}% \DeclareUnicodeCharacter{201A}{\quotesinglbase{}}% \DeclareUnicodeCharacter{201C}{\quotedblleft{}}% \DeclareUnicodeCharacter{201D}{\quotedblright{}}% \DeclareUnicodeCharacter{201E}{\quotedblbase{}}% \DeclareUnicodeCharacter{2020}{\ensuremath\dagger}% \DeclareUnicodeCharacter{2021}{\ensuremath\ddagger}% \DeclareUnicodeCharacter{2022}{\bullet{}}% \DeclareUnicodeCharacter{202F}{\thinspace}% \DeclareUnicodeCharacter{2026}{\dots{}}% \DeclareUnicodeCharacter{2039}{\guilsinglleft{}}% \DeclareUnicodeCharacter{203A}{\guilsinglright{}}% % \DeclareUnicodeCharacter{20AC}{\euro{}}% % \DeclareUnicodeCharacter{2192}{\arrow}% \DeclareUnicodeCharacter{21D2}{\result{}}% % % Mathematical symbols \DeclareUnicodeCharacter{2200}{\ensuremath\forall}% \DeclareUnicodeCharacter{2203}{\ensuremath\exists}% \DeclareUnicodeCharacter{2208}{\ensuremath\in}% \DeclareUnicodeCharacter{2212}{\minus{}}% \DeclareUnicodeCharacter{2217}{\ast}% \DeclareUnicodeCharacter{221E}{\ensuremath\infty}% \DeclareUnicodeCharacter{2225}{\ensuremath\parallel}% \DeclareUnicodeCharacter{2227}{\ensuremath\wedge}% \DeclareUnicodeCharacter{2229}{\ensuremath\cap}% \DeclareUnicodeCharacter{2261}{\equiv{}}% \DeclareUnicodeCharacter{2264}{\ensuremath\leq}% \DeclareUnicodeCharacter{2265}{\ensuremath\geq}% \DeclareUnicodeCharacter{2282}{\ensuremath\subset}% \DeclareUnicodeCharacter{2287}{\ensuremath\supseteq}% % \DeclareUnicodeCharacter{2016}{\ensuremath\Vert}% \DeclareUnicodeCharacter{2032}{\ensuremath\prime}% \DeclareUnicodeCharacter{210F}{\ensuremath\hbar}% \DeclareUnicodeCharacter{2111}{\ensuremath\Im}% \DeclareUnicodeCharacter{2113}{\ensuremath\ell}% \DeclareUnicodeCharacter{2118}{\ensuremath\wp}% \DeclareUnicodeCharacter{211C}{\ensuremath\Re}% \DeclareUnicodeCharacter{2135}{\ensuremath\aleph}% \DeclareUnicodeCharacter{2190}{\ensuremath\leftarrow}% \DeclareUnicodeCharacter{2191}{\ensuremath\uparrow}% \DeclareUnicodeCharacter{2193}{\ensuremath\downarrow}% \DeclareUnicodeCharacter{2194}{\ensuremath\leftrightarrow}% \DeclareUnicodeCharacter{2195}{\ensuremath\updownarrow}% \DeclareUnicodeCharacter{2196}{\ensuremath\nwarrow}% \DeclareUnicodeCharacter{2197}{\ensuremath\nearrow}% \DeclareUnicodeCharacter{2198}{\ensuremath\searrow}% \DeclareUnicodeCharacter{2199}{\ensuremath\swarrow}% \DeclareUnicodeCharacter{21A6}{\ensuremath\mapsto}% \DeclareUnicodeCharacter{21A9}{\ensuremath\hookleftarrow}% \DeclareUnicodeCharacter{21AA}{\ensuremath\hookrightarrow}% \DeclareUnicodeCharacter{21BC}{\ensuremath\leftharpoonup}% \DeclareUnicodeCharacter{21BD}{\ensuremath\leftharpoondown}% \DeclareUnicodeCharacter{21C0}{\ensuremath\rightharpoonup}% \DeclareUnicodeCharacter{21C1}{\ensuremath\rightharpoondown}% \DeclareUnicodeCharacter{21CC}{\ensuremath\rightleftharpoons}% \DeclareUnicodeCharacter{21D0}{\ensuremath\Leftarrow}% \DeclareUnicodeCharacter{21D1}{\ensuremath\Uparrow}% \DeclareUnicodeCharacter{21D3}{\ensuremath\Downarrow}% \DeclareUnicodeCharacter{21D4}{\ensuremath\Leftrightarrow}% \DeclareUnicodeCharacter{21D5}{\ensuremath\Updownarrow}% \DeclareUnicodeCharacter{2202}{\ensuremath\partial}% \DeclareUnicodeCharacter{2205}{\ensuremath\emptyset}% \DeclareUnicodeCharacter{2207}{\ensuremath\nabla}% \DeclareUnicodeCharacter{2209}{\ensuremath\notin}% \DeclareUnicodeCharacter{220B}{\ensuremath\owns}% \DeclareUnicodeCharacter{220F}{\ensuremath\prod}% \DeclareUnicodeCharacter{2210}{\ensuremath\coprod}% \DeclareUnicodeCharacter{2211}{\ensuremath\sum}% \DeclareUnicodeCharacter{2213}{\ensuremath\mp}% \DeclareUnicodeCharacter{2218}{\ensuremath\circ}% \DeclareUnicodeCharacter{221A}{\ensuremath\surd}% \DeclareUnicodeCharacter{221D}{\ensuremath\propto}% \DeclareUnicodeCharacter{2220}{\ensuremath\angle}% \DeclareUnicodeCharacter{2223}{\ensuremath\mid}% \DeclareUnicodeCharacter{2228}{\ensuremath\vee}% \DeclareUnicodeCharacter{222A}{\ensuremath\cup}% \DeclareUnicodeCharacter{222B}{\ensuremath\smallint}% \DeclareUnicodeCharacter{222E}{\ensuremath\oint}% \DeclareUnicodeCharacter{223C}{\ensuremath\sim}% \DeclareUnicodeCharacter{2240}{\ensuremath\wr}% \DeclareUnicodeCharacter{2243}{\ensuremath\simeq}% \DeclareUnicodeCharacter{2245}{\ensuremath\cong}% \DeclareUnicodeCharacter{2248}{\ensuremath\approx}% \DeclareUnicodeCharacter{224D}{\ensuremath\asymp}% \DeclareUnicodeCharacter{2250}{\ensuremath\doteq}% \DeclareUnicodeCharacter{2260}{\ensuremath\neq}% \DeclareUnicodeCharacter{226A}{\ensuremath\ll}% \DeclareUnicodeCharacter{226B}{\ensuremath\gg}% \DeclareUnicodeCharacter{227A}{\ensuremath\prec}% \DeclareUnicodeCharacter{227B}{\ensuremath\succ}% \DeclareUnicodeCharacter{2283}{\ensuremath\supset}% \DeclareUnicodeCharacter{2286}{\ensuremath\subseteq}% \DeclareUnicodeCharacter{228E}{\ensuremath\uplus}% \DeclareUnicodeCharacter{2291}{\ensuremath\sqsubseteq}% \DeclareUnicodeCharacter{2292}{\ensuremath\sqsupseteq}% \DeclareUnicodeCharacter{2293}{\ensuremath\sqcap}% \DeclareUnicodeCharacter{2294}{\ensuremath\sqcup}% \DeclareUnicodeCharacter{2295}{\ensuremath\oplus}% \DeclareUnicodeCharacter{2296}{\ensuremath\ominus}% \DeclareUnicodeCharacter{2297}{\ensuremath\otimes}% \DeclareUnicodeCharacter{2298}{\ensuremath\oslash}% \DeclareUnicodeCharacter{2299}{\ensuremath\odot}% \DeclareUnicodeCharacter{22A2}{\ensuremath\vdash}% \DeclareUnicodeCharacter{22A3}{\ensuremath\dashv}% \DeclareUnicodeCharacter{22A4}{\ensuremath\ptextop}% \DeclareUnicodeCharacter{22A5}{\ensuremath\bot}% \DeclareUnicodeCharacter{22A8}{\ensuremath\models}% \DeclareUnicodeCharacter{22C0}{\ensuremath\bigwedge}% \DeclareUnicodeCharacter{22C1}{\ensuremath\bigvee}% \DeclareUnicodeCharacter{22C2}{\ensuremath\bigcap}% \DeclareUnicodeCharacter{22C3}{\ensuremath\bigcup}% \DeclareUnicodeCharacter{22C4}{\ensuremath\diamond}% \DeclareUnicodeCharacter{22C5}{\ensuremath\cdot}% \DeclareUnicodeCharacter{22C6}{\ensuremath\star}% \DeclareUnicodeCharacter{22C8}{\ensuremath\bowtie}% \DeclareUnicodeCharacter{2308}{\ensuremath\lceil}% \DeclareUnicodeCharacter{2309}{\ensuremath\rceil}% \DeclareUnicodeCharacter{230A}{\ensuremath\lfloor}% \DeclareUnicodeCharacter{230B}{\ensuremath\rfloor}% \DeclareUnicodeCharacter{2322}{\ensuremath\frown}% \DeclareUnicodeCharacter{2323}{\ensuremath\smile}% % \DeclareUnicodeCharacter{25B3}{\ensuremath\triangle}% \DeclareUnicodeCharacter{25B7}{\ensuremath\triangleright}% \DeclareUnicodeCharacter{25BD}{\ensuremath\bigtriangledown}% \DeclareUnicodeCharacter{25C1}{\ensuremath\triangleleft}% \DeclareUnicodeCharacter{25C7}{\ensuremath\diamond}% \DeclareUnicodeCharacter{2660}{\ensuremath\spadesuit}% \DeclareUnicodeCharacter{2661}{\ensuremath\heartsuit}% \DeclareUnicodeCharacter{2662}{\ensuremath\diamondsuit}% \DeclareUnicodeCharacter{2663}{\ensuremath\clubsuit}% \DeclareUnicodeCharacter{266D}{\ensuremath\flat}% \DeclareUnicodeCharacter{266E}{\ensuremath\natural}% \DeclareUnicodeCharacter{266F}{\ensuremath\sharp}% \DeclareUnicodeCharacter{26AA}{\ensuremath\bigcirc}% \DeclareUnicodeCharacter{27B9}{\ensuremath\rangle}% \DeclareUnicodeCharacter{27C2}{\ensuremath\perp}% \DeclareUnicodeCharacter{27E8}{\ensuremath\langle}% \DeclareUnicodeCharacter{27F5}{\ensuremath\longleftarrow}% \DeclareUnicodeCharacter{27F6}{\ensuremath\longrightarrow}% \DeclareUnicodeCharacter{27F7}{\ensuremath\longleftrightarrow}% \DeclareUnicodeCharacter{27FC}{\ensuremath\longmapsto}% \DeclareUnicodeCharacter{29F5}{\ensuremath\setminus}% \DeclareUnicodeCharacter{2A00}{\ensuremath\bigodot}% \DeclareUnicodeCharacter{2A01}{\ensuremath\bigoplus}% \DeclareUnicodeCharacter{2A02}{\ensuremath\bigotimes}% \DeclareUnicodeCharacter{2A04}{\ensuremath\biguplus}% \DeclareUnicodeCharacter{2A06}{\ensuremath\bigsqcup}% \DeclareUnicodeCharacter{2A3F}{\ensuremath\amalg}% \DeclareUnicodeCharacter{2AAF}{\ensuremath\preceq}% \DeclareUnicodeCharacter{2AB0}{\ensuremath\succeq}% % \global\mathchardef\checkmark="1370% actually the square root sign \DeclareUnicodeCharacter{2713}{\ensuremath\checkmark}% }% end of \unicodechardefs % UTF-8 byte sequence (pdfTeX) definitions (replacing and @U command) % It makes the setting that replace UTF-8 byte sequence. \def\utfeightchardefs{% \let\DeclareUnicodeCharacter\DeclareUnicodeCharacterUTFviii \unicodechardefs } % Whether the active definitions of non-ASCII characters expand to % non-active tokens with the same character code. This is used to % write characters literally, instead of using active definitions for % printing the correct glyphs. \newif\ifpassthroughchars \passthroughcharsfalse % For native Unicode handling (XeTeX and LuaTeX), % provide a definition macro to replace/pass-through a Unicode character % \def\DeclareUnicodeCharacterNative#1#2{% \ifnum"#1>"7F % only make non-ASCII chars active \catcode"#1=\active \def\dodeclareunicodecharacternative##1##2##3{% \begingroup \uccode`\~="##2\relax \uppercase{\gdef~}{% \ifpassthroughchars ##1% \else ##3% \fi } \endgroup } \begingroup \uccode`\.="#1\relax \uppercase{\def\UTFNativeTmp{.}}% \expandafter\dodeclareunicodecharacternative\UTFNativeTmp{#1}{#2}% \endgroup \fi } % Native Unicode handling (XeTeX and LuaTeX) character replacing definition. % It activates the setting that replaces Unicode characters. \def\nativeunicodechardefs{% \let\DeclareUnicodeCharacter\DeclareUnicodeCharacterNative \unicodechardefs } % For native Unicode handling (XeTeX and LuaTeX), % make the character token expand % to the sequences given in \unicodechardefs for printing. \def\DeclareUnicodeCharacterNativeAtU#1#2{% \def\UTFAtUTmp{#2} \expandafter\globallet\csname uni:#1\endcsname \UTFAtUTmp } % @U command definitions for native Unicode handling (XeTeX and LuaTeX). \def\nativeunicodechardefsatu{% \let\DeclareUnicodeCharacter\DeclareUnicodeCharacterNativeAtU \unicodechardefs } % US-ASCII character definitions. \def\asciichardefs{% nothing need be done \relax } % Define all Unicode characters we know about \iftxinativeunicodecapable \nativeunicodechardefsatu \else \utfeightchardefs \fi \message{formatting,} \newdimen\defaultparindent \defaultparindent = 15pt \chapheadingskip = 15pt plus 4pt minus 2pt \secheadingskip = 12pt plus 3pt minus 2pt \subsecheadingskip = 9pt plus 2pt minus 2pt % Prevent underfull vbox error messages. \vbadness = 10000 % Don't be very finicky about underfull hboxes, either. \hbadness = 6666 % Following George Bush, get rid of widows and orphans. \widowpenalty=10000 \clubpenalty=10000 % Use TeX 3.0's \emergencystretch to help line breaking, but if we're % using an old version of TeX, don't do anything. We want the amount of % stretch added to depend on the line length, hence the dependence on % \hsize. We call this whenever the paper size is set. % \def\setemergencystretch{% \ifx\emergencystretch\thisisundefined % Allow us to assign to \emergencystretch anyway. \def\emergencystretch{\dimen0}% \else \emergencystretch = .15\hsize \fi } % Parameters in order: 1) textheight; 2) textwidth; % 3) voffset; 4) hoffset; 5) binding offset; 6) topskip; % 7) physical page height; 8) physical page width. % % We also call \setleading{\textleading}, so the caller should define % \textleading. The caller should also set \parskip. % \def\internalpagesizes#1#2#3#4#5#6#7#8{% \voffset = #3\relax \topskip = #6\relax \splittopskip = \topskip % \vsize = #1\relax \advance\vsize by \topskip \txipageheight = \vsize % \hsize = #2\relax \txipagewidth = \hsize % \normaloffset = #4\relax \bindingoffset = #5\relax % \ifpdf \pdfpageheight #7\relax \pdfpagewidth #8\relax % if we don't reset these, they will remain at "1 true in" of % whatever layout pdftex was dumped with. \pdfhorigin = 1 true in \pdfvorigin = 1 true in \else \ifx\XeTeXrevision\thisisundefined \special{papersize=#8,#7}% \else \pdfpageheight #7\relax \pdfpagewidth #8\relax % XeTeX does not have \pdfhorigin and \pdfvorigin. \fi \fi % \setleading{\textleading} % \parindent = \defaultparindent \setemergencystretch } % @letterpaper (the default). \def\letterpaper{{\globaldefs = 1 \parskip = 3pt plus 2pt minus 1pt \textleading = 13.2pt % % If page is nothing but text, make it come out even. \internalpagesizes{607.2pt}{6in}% that's 46 lines {\voffset}{.25in}% {\bindingoffset}{36pt}% {11in}{8.5in}% }} % Use @smallbook to reset parameters for 7x9.25 trim size. \def\smallbook{{\globaldefs = 1 \parskip = 2pt plus 1pt \textleading = 12pt % \internalpagesizes{7.5in}{5in}% {-.2in}{0in}% {\bindingoffset}{16pt}% {9.25in}{7in}% % \lispnarrowing = 0.3in \tolerance = 700 \contentsrightmargin = 0pt \defbodyindent = .5cm }} % Use @afourpaper to print on European A4 paper. \def\afourpaper{{\globaldefs = 1 \parskip = 3pt plus 2pt minus 1pt \textleading = 13.2pt % % Double-side printing via postscript on Laserjet 4050 % prints double-sided nicely when \bindingoffset=10mm and \hoffset=-6mm. % To change the settings for a different printer or situation, adjust % \normaloffset until the front-side and back-side texts align. Then % do the same for \bindingoffset. You can set these for testing in % your texinfo source file like this: % @tex % \global\normaloffset = -6mm % \global\bindingoffset = 10mm % @end tex \internalpagesizes{673.2pt}{160mm}% that's 51 lines {\voffset}{\hoffset}% {\bindingoffset}{44pt}% {297mm}{210mm}% % \tolerance = 700 \contentsrightmargin = 0pt \defbodyindent = 5mm }} % Use @afivepaper to print on European A5 paper. % From romildo@urano.iceb.ufop.br, 2 July 2000. % He also recommends making @example and @lisp be small. \def\afivepaper{{\globaldefs = 1 \parskip = 2pt plus 1pt minus 0.1pt \textleading = 12.5pt % \internalpagesizes{160mm}{120mm}% {\voffset}{-11.4mm}% {\bindingoffset}{8pt}% {210mm}{148mm}% % \lispnarrowing = 0.2in \tolerance = 800 \contentsrightmargin = 0pt \defbodyindent = 2mm \tableindent = 12mm }} % A specific text layout, 24x15cm overall, intended for A4 paper. \def\afourlatex{{\globaldefs = 1 \afourpaper \internalpagesizes{237mm}{150mm}% {\voffset}{4.6mm}% {\bindingoffset}{7mm}% {297mm}{210mm}% % % Must explicitly reset to 0 because we call \afourpaper. \globaldefs = 0 }} % Use @afourwide to print on A4 paper in landscape format. \def\afourwide{{\globaldefs = 1 \afourpaper \internalpagesizes{241mm}{165mm}% {\voffset}{-2.95mm}% {\bindingoffset}{7mm}% {297mm}{210mm}% \globaldefs = 0 }} \def\bsixpaper{{\globaldefs = 1 \afourpaper \internalpagesizes{140mm}{100mm}% {-6.35mm}{-12.7mm}% {\bindingoffset}{14pt}% {176mm}{125mm}% \let\SETdispenvsize=\smallword \lispnarrowing = 0.2in \globaldefs = 0 }} % @pagesizes TEXTHEIGHT[,TEXTWIDTH] % Perhaps we should allow setting the margins, \topskip, \parskip, % and/or leading, also. Or perhaps we should compute them somehow. % \parseargdef\pagesizes{\pagesizesyyy #1,,\finish} \def\pagesizesyyy#1,#2,#3\finish{{% \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \hsize=#2\relax \fi \globaldefs = 1 % \parskip = 3pt plus 2pt minus 1pt \setleading{\textleading}% % \dimen0 = #1\relax \advance\dimen0 by 2.5in % default 1in margin above heading line % and 1.5in to include heading, footing and % bottom margin % \dimen2 = \hsize \advance\dimen2 by 2in % default to 1 inch margin on each side % \internalpagesizes{#1}{\hsize}% {\voffset}{\normaloffset}% {\bindingoffset}{44pt}% {\dimen0}{\dimen2}% }} % Set default to letter. % \letterpaper % Default value of \hfuzz, for suppressing warnings about overfull hboxes. \hfuzz = 1pt \message{microtype,} % protrusion, from Thanh's protcode.tex. \def\mtsetprotcode#1{% \rpcode#1`\!=200 \rpcode#1`\,=700 \rpcode#1`\-=700 \rpcode#1`\.=700 \rpcode#1`\;=500 \rpcode#1`\:=500 \rpcode#1`\?=200 \rpcode#1`\'=700 \rpcode#1 34=500 % '' \rpcode#1 123=300 % -- \rpcode#1 124=200 % --- \rpcode#1`\)=50 \rpcode#1`\A=50 \rpcode#1`\F=50 \rpcode#1`\K=50 \rpcode#1`\L=50 \rpcode#1`\T=50 \rpcode#1`\V=50 \rpcode#1`\W=50 \rpcode#1`\X=50 \rpcode#1`\Y=50 \rpcode#1`\k=50 \rpcode#1`\r=50 \rpcode#1`\t=50 \rpcode#1`\v=50 \rpcode#1`\w=50 \rpcode#1`\x=50 \rpcode#1`\y=50 % \lpcode#1`\`=700 \lpcode#1 92=500 % `` \lpcode#1`\(=50 \lpcode#1`\A=50 \lpcode#1`\J=50 \lpcode#1`\T=50 \lpcode#1`\V=50 \lpcode#1`\W=50 \lpcode#1`\X=50 \lpcode#1`\Y=50 \lpcode#1`\v=50 \lpcode#1`\w=50 \lpcode#1`\x=50 \lpcode#1`\y=0 % \mtadjustprotcode#1\relax } \newcount\countC \def\mtadjustprotcode#1{% \countC=0 \loop \ifcase\lpcode#1\countC\else \mtadjustcp\lpcode#1\countC \fi \ifcase\rpcode#1\countC\else \mtadjustcp\rpcode#1\countC \fi \advance\countC 1 \ifnum\countC < 256 \repeat } \newcount\countB \def\mtadjustcp#1#2#3{% \setbox\boxA=\hbox{% \ifx#2\font\else#2\fi \char#3}% \countB=\wd\boxA \multiply\countB #1#2#3\relax \divide\countB \fontdimen6 #2\relax #1#2#3=\countB\relax } \ifx\XeTeXrevision\thisisundefined \ifx\luatexversion\thisisundefined \ifpdf % pdfTeX \mtsetprotcode\textrm \def\mtfontexpand#1{\pdffontexpand#1 20 20 1 autoexpand\relax} \else % TeX \def\mtfontexpand#1{} \fi \else % LuaTeX \mtsetprotcode\textrm \def\mtfontexpand#1{\expandglyphsinfont#1 20 20 1\relax} \fi \else % XeTeX \mtsetprotcode\textrm \def\mtfontexpand#1{} \fi \newif\ifmicrotype \def\microtypeON{% \microtypetrue % \ifx\XeTeXrevision\thisisundefined \ifx\luatexversion\thisisundefined \ifpdf % pdfTeX \pdfadjustspacing=2 \pdfprotrudechars=2 \fi \else % LuaTeX \adjustspacing=2 \protrudechars=2 \fi \else % XeTeX \XeTeXprotrudechars=2 \fi % \mtfontexpand\textrm \mtfontexpand\textsl \mtfontexpand\textbf } \def\microtypeOFF{% \microtypefalse % \ifx\XeTeXrevision\thisisundefined \ifx\luatexversion\thisisundefined \ifpdf % pdfTeX \pdfadjustspacing=0 \pdfprotrudechars=0 \fi \else % LuaTeX \adjustspacing=0 \protrudechars=0 \fi \else % XeTeX \XeTeXprotrudechars=0 \fi } \microtypeOFF \parseargdef\microtype{% \def\txiarg{#1}% \ifx\txiarg\onword \microtypeON \else\ifx\txiarg\offword \microtypeOFF \else \errhelp = \EMsimple \errmessage{Unknown @microtype option `\txiarg', must be on|off}% \fi\fi } \message{and turning on texinfo input format.} % Make UTF-8 the default encoding. \documentencodingzzz{UTF-8} \def^^L{\par} % remove \outer, so ^L can appear in an @comment \catcode`\^^K = 10 % treat vertical tab as whitespace % DEL is a comment character, in case @c does not suffice. \catcode`\^^? = 14 % Define macros to output various characters with catcode for normal text. \catcode`\"=\other \def\normaldoublequote{"} \catcode`\$=\other \def\normaldollar{$}%$ font-lock fix \catcode`\+=\other \def\normalplus{+} \catcode`\<=\other \def\normalless{<} \catcode`\>=\other \def\normalgreater{>} \catcode`\^=\other \def\normalcaret{^} \catcode`\_=\other \def\normalunderscore{_} \catcode`\|=\other \def\normalverticalbar{|} \catcode`\~=\other \def\normaltilde{~} % Set catcodes for Texinfo file % Active characters for printing the wanted glyph. % Most of these we simply print from the \tt font, but for some, we can % use math or other variants that look better in normal text. % \catcode`\"=\active \def\activedoublequote{{\tt\char34}} \let"=\activedoublequote \catcode`\~=\active \def\activetilde{{\tt\char126}} \let~ = \activetilde \chardef\hatchar=`\^ \catcode`\^=\active \def\activehat{{\tt \hatchar}} \let^ = \activehat \catcode`\_=\active \def_{\ifusingtt\normalunderscore\_} \def\_{\leavevmode \kern.07em \vbox{\hrule width.3em height.1ex}\kern .07em } \let\realunder=_ \catcode`\|=\active \def|{{\tt\char124}} \chardef \less=`\< \catcode`\<=\active \def\activeless{{\tt \less}}\let< = \activeless \chardef \gtr=`\> \catcode`\>=\active \def\activegtr{{\tt \gtr}}\let> = \activegtr \catcode`\+=\active \def+{{\tt \char 43}} \catcode`\$=\active \def${\ifusingit{{\sl\$}}\normaldollar}%$ font-lock fix \catcode`\-=\active \let-=\normaldash % used for headline/footline in the output routine, in case the page % breaks in the middle of an @tex block. \def\texinfochars{% \let< = \activeless \let> = \activegtr \let~ = \activetilde \let^ = \activehat \setregularquotes \let\b = \strong \let\i = \smartitalic % in principle, all other definitions in \tex have to be undone too. } % Used sometimes to turn off (effectively) the active characters even after % parsing them. \def\turnoffactive{% \passthroughcharstrue \let-=\normaldash \let"=\normaldoublequote \let$=\normaldollar %$ font-lock fix \let+=\normalplus \let<=\normalless \let>=\normalgreater \let^=\normalcaret \let_=\normalunderscore \let|=\normalverticalbar \let~=\normaltilde \otherbackslash \setregularquotes \unsepspaces } % If a .fmt file is being used, characters that might appear in a file % name cannot be active until we have parsed the command line. % So turn them off again, and have \loadconf turn them back on. \catcode`+=\other \catcode`\_=\other % \backslashcurfont outputs one backslash character in current font, % as in \char`\\. \global\chardef\backslashcurfont=`\\ % Print a typewriter backslash. For math mode, we can't simply use % \backslashcurfont: the story here is that in math mode, the \char % of \backslashcurfont ends up printing the roman \ from the math symbol % font (because \char in math mode uses the \mathcode, and plain.tex % sets \mathcode`\\="026E). Hence we use an explicit \mathchar, % which is the decimal equivalent of "715c (class 7, e.g., use \fam; % ignored family value; char position "5C). We can't use " for the % usual hex value because it has already been made active. \def\ttbackslash{{\tt \ifmmode \mathchar29020 \else \backslashcurfont \fi}} \let\backslashchar = \ttbackslash % \backslashchar{} is for user documents. % These are made active for url-breaking, so need % active definitions as the normal characters. \def\normaldot{.} \def\normalquest{?} \def\normalslash{/} % \newlinesloadsconf - call \loadconf as soon as possible in the % file, e.g. at the first newline. % {\catcode`\^=7 \catcode`\^^M=13 \gdef\newlineloadsconf{% \catcode`\^^M=13 % \newlineloadsconfzz% } \gdef\newlineloadsconfzz#1^^M{% \def\c{\loadconf\c}% % Definition for the first newline read in the file \def ^^M{\loadconf}% % In case the first line has a whole-line or environment command on it \let\originalparsearg\parsearg% \def\parsearg{\loadconf\originalparsearg}% % % \startenvironment is in the expansion of commands defined with \envdef \let\originalstartenvironment\startenvironment% \def\startenvironment{\loadconf\startenvironment}% }} % Emergency active definition of newline, in case an active newline token % appears by mistake. {\catcode`\^=7 \catcode13=13% \gdef\enableemergencynewline{% \gdef^^M{% \par% %\par% }}} % \loadconf gets called at the beginning of every Texinfo file. % If texinfo.cnf is present on the system, read it. Useful for site-wide % @afourpaper, etc. Not opening texinfo.cnf directly in texinfo.tex % makes it possible to make a format file for Texinfo. % \gdef\loadconf{% \relax % Terminate the filename if running as "tex '&texinfo' FILE.texi". % % Turn off the definitions that trigger \loadconf \everyjobreset \catcode13=5 % regular end of line \enableemergencynewline \let\c=\comment \let\parsearg\originalparsearg \let\startenvironment\originalstartenvironment % % Also turn back on active characters that might appear in the input % file name, in case not using a pre-dumped format. \catcode`+=\active \catcode`\_=\active % \openin 1 texinfo.cnf \ifeof 1 \else \input texinfo.cnf \fi \closein 1 } % Redefine some control sequences to be controlled by the \ifdummies % and \ifindexnofonts switches. Do this at the end so that the control % sequences are all defined. \definedummies \catcode`\@=0 % \realbackslash is an actual character `\' with catcode other. {\catcode`\\=\other @gdef@realbackslash{\}} % In Texinfo, backslash is an active character; it prints the backslash % in fixed width font. \catcode`\\=\active % @ for escape char from now on. @let\ = @ttbackslash % If in a .fmt file, print the version number. % \eatinput stops the `\input texinfo' from showing up. % After that, `\' should revert to printing a backslash. % Turn on active characters that we couldn't do earlier because % they might have appeared in the input file name. % @everyjob{@message{[Texinfo version @texinfoversion]}% @global@let\ = @eatinput @catcode`+=@active @catcode`@_=@active} {@catcode`@^=7 @catcode`@^^M=13% @gdef@eatinput input texinfo#1^^M{@loadconf}} @def@everyjobreset{@ifx\@eatinput @let\ = @ttbackslash @fi} % \otherbackslash defines an active \ to be a literal `\' character with % catcode other. @gdef@otherbackslash{@let\=@realbackslash} % Same as @turnoffactive except outputs \ as {\tt\char`\\} instead of % the literal character `\'. % {@catcode`- = @active @gdef@normalturnoffactive{% @turnoffactive @let\=@ttbackslash } } % Say @foo, not \foo, in error messages. @escapechar = `@@ % These look ok in all fonts, so just make them not special. % @hashchar{} gets its own user-level command, because of #line. @catcode`@& = @other @def@normalamp{&} @catcode`@# = @other @def@normalhash{#} @catcode`@% = @other @def@normalpercent{%} @let @hashchar = @normalhash @c Finally, make ` and ' active, so that txicodequoteundirected and @c txicodequotebacktick work right in, e.g., @w{@code{`foo'}}. If we @c don't make ` and ' active, @code will not get them as active chars. @c Do this last of all since we use ` in the previous @catcode assignments. @catcode`@'=@active @catcode`@`=@active @c Local variables: @c eval: (add-hook 'before-save-hook 'time-stamp nil t) @c time-stamp-pattern: "texinfoversion{%Y-%02m-%02d.%02H}" @c page-delimiter: "^\\\\message" @c End: @newlineloadsconf gcl-2.7.1/PaxHeaders/ltmain.sh0000644000000000000000000000013214776006046013176 xustar0030 mtime=1744309286.190034537 30 atime=1744309286.298035059 30 ctime=1744351535.446909541 gcl-2.7.1/ltmain.sh0000644000175000017500000046150014776006046012602 0ustar00cammcamm# 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.7.1/PaxHeaders/config.sub0000644000000000000000000000013214776130437013340 xustar0030 mtime=1744351519.783051006 30 atime=1744351519.963049368 30 ctime=1744351535.446909541 gcl-2.7.1/config.sub0000755000175000017500000011544114776130437012747 0ustar00cammcamm#! /bin/sh # Configuration validation subroutine script. # Copyright 1992-2024 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268,SC2162 # see below for rationale timestamp='2024-05-27' # 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-2024 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 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 cloudabi*-eabi* \ | kfreebsd*-gnu* \ | knetbsd*-gnu* \ | kopensolaris*-gnu* \ | linux-* \ | managarm-* \ | netbsd*-eabi* \ | netbsd*-gnu* \ | nto-qnx* \ | os2-emx* \ | rtmk-nova* \ | storm-chaos* \ | uclinux-gnu* \ | uclinux-uclibc* \ | windows-* ) 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 ;; *-*) case $field1-$field2 in # Shorthands that happen to contain a single dash convex-c[12] | convex-c3[248]) basic_machine=$field2-convex basic_os= ;; decstation-3100) basic_machine=mips-dec basic_os= ;; *-*) # Second component is usually, but not always the OS case $field2 in # Do not treat sunos as a manufacturer sun*os*) basic_machine=$field1 basic_os=$field2 ;; # Manufacturers 3100* \ | 32* \ | 3300* \ | 3600* \ | 7300* \ | acorn \ | altos* \ | apollo \ | apple \ | atari \ | att* \ | axis \ | be \ | bull \ | cbm \ | ccur \ | cisco \ | commodore \ | convergent* \ | convex* \ | cray \ | crds \ | dec* \ | delta* \ | dg \ | digital \ | dolphin \ | encore* \ | gould \ | harris \ | highlevel \ | hitachi* \ | hp \ | ibm* \ | intergraph \ | isi* \ | knuth \ | masscomp \ | microblaze* \ | mips* \ | motorola* \ | ncr* \ | news \ | next \ | ns \ | oki \ | omron* \ | pc533* \ | rebel \ | rom68k \ | rombug \ | semi \ | sequent* \ | siemens \ | sgi* \ | siemens \ | sim \ | sni \ | sony* \ | stratus \ | sun \ | sun[234]* \ | tektronix \ | tti* \ | ultra \ | unicom* \ | wec \ | winbond \ | wrs) basic_machine=$field1-$field2 basic_os= ;; zephyr*) basic_machine=$field1-unknown basic_os=$field2 ;; *) 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 ;; 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 | delta-motorola | 3300-motorola | motorola-delta | motorola-3300) cpu=m68k vendor=motorola ;; # This used to be dpx2*, but that gets the RS6000-based # DPX/20 and the x86-based DPX/2-100 wrong. See # https://oldskool.silicium.org/stations/bull_dpx20.htm # https://www.feb-patrimoine.com/english/bull_dpx2.htm # https://www.feb-patrimoine.com/english/unix_and_bull.htm dpx2 | dpx2[23]00 | dpx2[23]xx) cpu=m68k vendor=bull ;; dpx2100 | dpx21xx) cpu=i386 vendor=bull ;; dpx20) cpu=rs6000 vendor=bull ;; 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 ;; 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/-.*//'` ;; *-*) 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. obj= 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|'` ;; *-*) saved_IFS=$IFS IFS="-" read kernel os <&2 fi ;; *) echo "Invalid configuration '$1': OS '$os' not recognized" 1>&2 exit 1 ;; esac case $obj in aout* | coff* | elf* | pe*) ;; '') # empty is fine ;; *) echo "Invalid configuration '$1': Machine code format '$obj' not recognized" 1>&2 exit 1 ;; esac # Here we handle the constraint that a (synthetic) cpu and os are # valid only in combination with each other and nowhere else. case $cpu-$os in # The "javascript-unknown-ghcjs" triple is used by GHC; we # accept it here in order to tolerate that, but reject any # variations. javascript-ghcjs) ;; javascript-* | *-ghcjs) echo "Invalid configuration '$1': cpu '$cpu' is not valid with os '$os$obj'" 1>&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-$obj in linux-gnu*- | linux-android*- | linux-dietlibc*- | linux-llvm*- \ | linux-mlibc*- | linux-musl*- | linux-newlib*- \ | linux-relibc*- | linux-uclibc*- | linux-ohos*- ) ;; uclinux-uclibc*- | uclinux-gnu*- ) ;; managarm-mlibc*- | managarm-kernel*- ) ;; windows*-msvc*-) ;; -dietlibc*- | -llvm*- | -mlibc*- | -musl*- | -newlib*- | -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 ;; -kernel*- ) echo "Invalid configuration '$1': '$os' needs explicit kernel." 1>&2 exit 1 ;; *-kernel*- ) echo "Invalid configuration '$1': '$kernel' does not support '$os'." 1>&2 exit 1 ;; *-msvc*- ) echo "Invalid configuration '$1': '$os' needs 'windows'." 1>&2 exit 1 ;; kfreebsd*-gnu*- | knetbsd*-gnu*- | netbsd*-gnu*- | kopensolaris*-gnu*-) ;; vxworks-simlinux- | vxworks-simwindows- | vxworks-spe-) ;; nto-qnx*-) ;; os2-emx-) ;; rtmk-nova-) ;; *-eabi*- | *-gnueabi*-) ;; none--*) # None (no kernel, i.e. freestanding / bare metal), # can be paired with an machine code file format ;; -*-) # Blank kernel with real OS is always fine. ;; --*) # Blank kernel and OS with real machine code file format 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* | *-solaris*) 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:+-$os}${obj:+-$obj}" 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.7.1/PaxHeaders/xgcl-20000644000000000000000000000013214776130457012401 xustar0030 mtime=1744351535.566908465 30 atime=1744351538.814879383 30 ctime=1744351535.566908465 gcl-2.7.1/xgcl-2/0000755000175000017500000000000014776130457012054 5ustar00cammcammgcl-2.7.1/xgcl-2/PaxHeaders/gcl_dwindow.lsp0000644000000000000000000000013114555557372015501 xustar0030 mtime=1706483450.816392726 29 atime=1744295041.19414203 30 ctime=1744351535.434909649 gcl-2.7.1/xgcl-2/gcl_dwindow.lsp0000644000175000017500000033540314555557372015110 0ustar00cammcamm; 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. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/gcl_index.lsp0000644000000000000000000000013214776006046015126 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.318035155 30 ctime=1744351535.426909721 gcl-2.7.1/xgcl-2/gcl_index.lsp0000644000175000017500000000561414776006046014532 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_defentry_events.lsp0000644000000000000000000000013214555557372017233 xustar0030 mtime=1706483450.816392726 30 atime=1744346651.877822357 30 ctime=1744351535.422909757 gcl-2.7.1/xgcl-2/gcl_defentry_events.lsp0000644000175000017500000016335014555557372016641 0ustar00cammcamm(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. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/gcl_draw-gates.lsp0000644000000000000000000000013114770537330016053 xustar0029 mtime=1742913240.30249084 30 atime=1744295041.202142065 30 ctime=1744351535.414909828 gcl-2.7.1/xgcl-2/gcl_draw-gates.lsp0000644000175000017500000000666714770537330015471 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_dwtrans.lsp0000644000000000000000000000013214776006046015501 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.314035136 30 ctime=1744351535.426909721 gcl-2.7.1/xgcl-2/gcl_dwtrans.lsp0000644000175000017500000032463414776006046015113 0ustar00cammcamm; 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. ; Copyright (c) 2024 Camm Maguire ; 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)) (#\^Q (setq done t)) (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.7.1/xgcl-2/PaxHeaders/gcl_menu-set.lsp0000644000000000000000000000013214555557372015564 xustar0030 mtime=1706483450.820392725 30 atime=1744295041.202142065 30 ctime=1744351535.430909685 gcl-2.7.1/xgcl-2/gcl_menu-set.lsp0000644000175000017500000004413714555557372015173 0ustar00cammcamm; 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. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/gcl_dwtestcases.lsp0000644000000000000000000000013214776006046016350 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.314035136 30 ctime=1744351535.410909864 gcl-2.7.1/xgcl-2/gcl_dwtestcases.lsp0000644000175000017500000000140614776006046015747 0ustar00cammcamm;(load "/stage/ftp/pub/novak/xgcl-4/gcl_dwtrans.lsp") (in-package :xlib) (load (merge-pathnames "gcl_drawtrans.lsp" *load-pathname*)) (load (merge-pathnames "gcl_editorstrans.lsp" *load-pathname*)) (load (merge-pathnames "gcl_lispservertrans.lsp" *load-pathname*)) (load (merge-pathnames "gcl_menu-settrans.lsp" *load-pathname*)) (load (merge-pathnames "gcl_dwtest.lsp" *load-pathname*)) (load (merge-pathnames "gcl_draw-gates.lsp" *load-pathname*)) (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 '("(edit this, ^Q to quit)" "Now is the time" "for all" "good")) (draw-nand myw 50 50) gcl-2.7.1/xgcl-2/PaxHeaders/gcl_Xakcl.example.lsp0000644000000000000000000000013214763573237016522 xustar0030 mtime=1741616799.681591281 30 atime=1744295041.234142204 30 ctime=1744351535.438909613 gcl-2.7.1/xgcl-2/gcl_Xakcl.example.lsp0000644000175000017500000003054114763573237016123 0ustar00cammcamm(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 button 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.7.1/xgcl-2/PaxHeaders/gcl_general.lsp0000644000000000000000000000013214555557372015444 xustar0030 mtime=1706483450.820392725 30 atime=1744346651.877822357 30 ctime=1744351535.422909757 gcl-2.7.1/xgcl-2/gcl_general.lsp0000644000175000017500000000613314555557372015045 0ustar00cammcamm(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. ; Copyright (c) 2024 Camm Maguire ; 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 (clines "long strlen(char *);");FIXME (clines "char *object_to_string(object);");FIXME ;(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 "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.7.1/xgcl-2/PaxHeaders/gcl_dwtest.lsp0000644000000000000000000000013214555557372015341 xustar0030 mtime=1706483450.816392726 30 atime=1744295041.234142204 30 ctime=1744351535.410909864 gcl-2.7.1/xgcl-2/gcl_dwtest.lsp0000644000175000017500000001555314555557372014750 0ustar00cammcamm; 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. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/general-c.c0000644000000000000000000000013214556224404014447 xustar0030 mtime=1706633476.884467337 30 atime=1744340056.012936259 30 ctime=1744351535.566908465 gcl-2.7.1/xgcl-2/general-c.c0000644000175000017500000000370714556224404014054 0ustar00cammcamm/* 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. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/gcl_tohtml.lsp0000644000000000000000000000013214776006046015326 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.318035155 30 ctime=1744351535.426909721 gcl-2.7.1/xgcl-2/gcl_tohtml.lsp0000644000175000017500000004140114776006046014724 0ustar00cammcamm; 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 *outdir* "") (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) (outdir prefix)) (let (c) (setq *pagenumber* pagenumber) (setq *prefix* (stringify prefix)) (setq *outdir* (stringify outdir)) (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 *outdir* *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.7.1/xgcl-2/PaxHeaders/Xutil-2.c0000644000000000000000000000013214542551763014064 xustar0030 mtime=1703597043.432023104 30 atime=1744340056.020936309 30 ctime=1744351535.566908465 gcl-2.7.1/xgcl-2/Xutil-2.c0000644000175000017500000000372214542551763013466 0ustar00cammcamm/* 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.7.1/xgcl-2/PaxHeaders/gcl_keysymdef.lsp0000644000000000000000000000013114542551763016020 xustar0029 mtime=1703597043.43602311 30 atime=1744346651.881822382 30 ctime=1744351535.422909757 gcl-2.7.1/xgcl-2/gcl_keysymdef.lsp0000644000175000017500000015776114542551763015440 0ustar00cammcamm(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.7.1/xgcl-2/PaxHeaders/dec.copyright0000644000000000000000000000013214542551763015141 xustar0030 mtime=1703597043.432023104 30 atime=1744295041.266142343 30 ctime=1744351535.418909792 gcl-2.7.1/xgcl-2/dec.copyright0000644000175000017500000000235114542551763014540 0ustar00cammcamm;;********************************************************** ;;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.7.1/xgcl-2/PaxHeaders/gcl_Xlib.lsp0000644000000000000000000000013214542551763014717 xustar0030 mtime=1703597043.432023104 30 atime=1744346651.873822333 30 ctime=1744351535.418909792 gcl-2.7.1/xgcl-2/gcl_Xlib.lsp0000644000175000017500000014110614542551763014320 0ustar00cammcamm(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.7.1/xgcl-2/PaxHeaders/gnu.license0000644000000000000000000000013114542551763014610 xustar0029 mtime=1703597043.43602311 30 atime=1744295041.266142343 30 ctime=1744351535.414909828 gcl-2.7.1/xgcl-2/gnu.license0000644000175000017500000003031014542551763014204 0ustar00cammcamm 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.7.1/xgcl-2/PaxHeaders/gcl_drawtrans.lsp0000644000000000000000000000013214776006046016024 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.314035136 30 ctime=1744351535.410909864 gcl-2.7.1/xgcl-2/gcl_drawtrans.lsp0000644000175000017500000022515014776006046015427 0ustar00cammcamm; 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. ; Copyright (c) 2024 Camm Maguire ; 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 :xlib) (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 between (x y z) (<= y x z)) (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.7.1/xgcl-2/PaxHeaders/Xakcl.paper0000644000000000000000000000013214763573237014554 xustar0030 mtime=1741616799.681591281 30 atime=1744295041.266142343 30 ctime=1744351535.430909685 gcl-2.7.1/xgcl-2/Xakcl.paper0000644000175000017500000007172514763573237014166 0ustar00cammcamm 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. Controlling 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 approach 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 controlling minute details in color, to creating pixmaps, and configuring windows. Thus a programmer 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 library 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 libraries' 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 initialised 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 server 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 server 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 graphics 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 foreground 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 necessary 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 structure (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 corresponding 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 called 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 specify which attribute is being changed. This could be clumbersome and inefficient 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 discussed in this report (see section E). The list shown is meant to demonstrate how X names functions, and how X can provide for functional equivalents for most operations. (Of course 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 the 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 pointers 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 allocate 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 structures, 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 information 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)) Similar to Xsetforeground, XSetBackGround will cause all drawings needing the background color to use the specified 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 reference 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 values 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 foreground color). On color screens the foreground color must be set to (logxor foreground-pixel background-pixel) in order for ghosting effects to occur. 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 graphics 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 rectangle 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 ellipses or circles 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 rectangle. 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 discussed 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 graphics context. XDrawString also expects the length of the string (in this case 4), and the display. Often it is necessary 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 character width of all the characters in the string (thus the width of the string in number of pixels). From this information, the user should be 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 inputted 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 encompasses 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 themselves 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 specifying 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 demonstrated 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 applications 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.7.1/xgcl-2/PaxHeaders/README0000644000000000000000000000013214542551763013334 xustar0030 mtime=1703597043.428023097 30 atime=1744295041.266142343 30 ctime=1744351535.430909685 gcl-2.7.1/xgcl-2/README0000644000175000017500000001145614542551763012741 0ustar00cammcammREADME 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.7.1/xgcl-2/PaxHeaders/XStruct-4.c0000644000000000000000000000013214555557372014403 xustar0030 mtime=1706483450.816392726 30 atime=1744340056.016936284 30 ctime=1744351535.566908465 gcl-2.7.1/xgcl-2/XStruct-4.c0000644000175000017500000010413514555557372014005 0ustar00cammcamm/* XStruct-4.c Hiep Huu Nguyen 27 Jun 06 */ /* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/version0000644000000000000000000000013114542551763014063 xustar0029 mtime=1703597043.43602311 30 atime=1744295041.278142395 30 ctime=1744351535.418909792 gcl-2.7.1/xgcl-2/version0000644000175000017500000000000214542551763013452 0ustar00cammcamm2 gcl-2.7.1/xgcl-2/PaxHeaders/sysdef.lisp0000644000000000000000000000013214555557372014650 xustar0030 mtime=1706483450.820392725 30 atime=1744346651.865822283 30 ctime=1744351535.410909864 gcl-2.7.1/xgcl-2/sysdef.lisp0000644000175000017500000000541014555557372014246 0ustar00cammcamm; Copyright (c) 1994 William F. Schelter ; Copyright (c) 2024 Camm Maguire ; 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. (unless (find-package :xlib) (make-package :XLIB :use '(:lisp :si)));(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"))))) (let ((compiler::*default-c-file* t) (compiler::*default-h-file* t) (compiler::*default-data-file* t) (compiler::*default-system-p* t)) (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.7.1/xgcl-2/PaxHeaders/gcl_editorstrans.lsp0000644000000000000000000000013214776006046016540 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.318035155 30 ctime=1744351535.414909828 gcl-2.7.1/xgcl-2/gcl_editorstrans.lsp0000644000175000017500000005741314776006046016150 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_lispservertrans.lsp0000644000000000000000000000013114542551763017266 xustar0029 mtime=1703597043.43602311 30 atime=1744295041.282142413 30 ctime=1744351535.414909828 gcl-2.7.1/xgcl-2/gcl_lispservertrans.lsp0000644000175000017500000001004414542551763016664 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_editors.lsp0000644000000000000000000000013214776006046015470 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.314035136 30 ctime=1744351535.434909649 gcl-2.7.1/xgcl-2/gcl_editors.lsp0000644000175000017500000004331614776006046015075 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_X.lsp0000644000000000000000000000013214542551763014230 xustar0030 mtime=1703597043.432023104 30 atime=1744346651.873822333 30 ctime=1744351535.418909792 gcl-2.7.1/xgcl-2/gcl_X.lsp0000644000175000017500000005223414542551763013634 0ustar00cammcamm(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.7.1/xgcl-2/PaxHeaders/gcl_Xstruct.lsp0000644000000000000000000000013214555557372015503 xustar0030 mtime=1706483450.816392726 30 atime=1744346651.877822357 30 ctime=1744351535.422909757 gcl-2.7.1/xgcl-2/gcl_Xstruct.lsp0000644000175000017500000004551614555557372015114 0ustar00cammcamm(in-package :XLIB) ; Xstruct.lsp Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/dwdoc.tex0000644000000000000000000000013114555553414014274 xustar0030 mtime=1706481420.240964111 29 atime=1744295041.28614243 30 ctime=1744351535.414909828 gcl-2.7.1/xgcl-2/dwdoc.tex0000644000175000017500000011703614555553414013703 0ustar00cammcamm% 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.7.1/xgcl-2/PaxHeaders/gcl_Xinit.lsp0000644000000000000000000000013214763573237015121 xustar0030 mtime=1741616799.681591281 30 atime=1744346651.881822382 30 ctime=1744351535.426909721 gcl-2.7.1/xgcl-2/gcl_Xinit.lsp0000644000175000017500000001267114763573237014526 0ustar00cammcamm(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. ; Copyright (c) 2024 Camm Maguire ; 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 containing 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 attributes 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 accomplished 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.7.1/xgcl-2/PaxHeaders/gcl_draw.lsp0000644000000000000000000000013014555557372014762 xustar0030 mtime=1706483450.816392726 28 atime=1744295041.3021425 30 ctime=1744351535.434909649 gcl-2.7.1/xgcl-2/gcl_draw.lsp0000644000175000017500000011272014555557372014365 0ustar00cammcamm; 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. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/gcl_ice-cream.lsp0000644000000000000000000000012714542551763015652 xustar0029 mtime=1703597043.43602311 28 atime=1744295041.3021425 30 ctime=1744351535.434909649 gcl-2.7.1/xgcl-2/gcl_ice-cream.lsp0000644000175000017500000000316114542551763015245 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_menu-settrans.lsp0000644000000000000000000000012714542551763016632 xustar0029 mtime=1703597043.43602311 28 atime=1744295041.3021425 30 ctime=1744351535.414909828 gcl-2.7.1/xgcl-2/gcl_menu-settrans.lsp0000644000175000017500000005012614542551763016230 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_Xutil.lsp0000644000000000000000000000013214542551763015126 xustar0030 mtime=1703597043.432023104 30 atime=1744346651.873822333 30 ctime=1744351535.418909792 gcl-2.7.1/xgcl-2/gcl_Xutil.lsp0000644000175000017500000003641714542551763014537 0ustar00cammcamm(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.7.1/xgcl-2/PaxHeaders/gcl_XStruct_l_3.lsp0000644000000000000000000000013214555557372016200 xustar0030 mtime=1706483450.816392726 30 atime=1744346651.877822357 30 ctime=1744351535.422909757 gcl-2.7.1/xgcl-2/gcl_XStruct_l_3.lsp0000644000175000017500000007727014555557372015613 0ustar00cammcamm(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. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/gcl_pcalc.lsp0000644000000000000000000000012714542551763015107 xustar0029 mtime=1703597043.43602311 28 atime=1744295041.3021425 30 ctime=1744351535.430909685 gcl-2.7.1/xgcl-2/gcl_pcalc.lsp0000644000175000017500000001022014542551763014474 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_XAtom.lsp0000644000000000000000000000013214542551763015051 xustar0030 mtime=1703597043.432023104 30 atime=1744346651.877822357 30 ctime=1744351535.418909792 gcl-2.7.1/xgcl-2/gcl_XAtom.lsp0000644000175000017500000000654114542551763014455 0ustar00cammcamm(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.7.1/xgcl-2/PaxHeaders/XStruct-2.c0000644000000000000000000000013214555557372014401 xustar0030 mtime=1706483450.816392726 30 atime=1744340056.016936284 30 ctime=1744351535.566908465 gcl-2.7.1/xgcl-2/XStruct-2.c0000644000175000017500000005126014555557372014003 0ustar00cammcamm/* XStruct-2.c Hiep Huu Nguyen 27 Jun 06 */ /* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/xgcl-2/PaxHeaders/gcl_lispserver.lsp0000644000000000000000000000013114542551763016216 xustar0029 mtime=1703597043.43602311 30 atime=1744295041.342142674 30 ctime=1744351535.434909649 gcl-2.7.1/xgcl-2/gcl_lispserver.lsp0000644000175000017500000001074614542551763015625 0ustar00cammcamm; 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.7.1/xgcl-2/PaxHeaders/gcl_X10.lsp0000644000000000000000000000013214542551763014371 xustar0030 mtime=1703597043.432023104 30 atime=1744346651.881822382 30 ctime=1744351535.422909757 gcl-2.7.1/xgcl-2/gcl_X10.lsp0000644000175000017500000000237314542551763013774 0ustar00cammcamm(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.7.1/xgcl-2/PaxHeaders/Events.c0000644000000000000000000000013214555557372014072 xustar0030 mtime=1706483450.816392726 30 atime=1744340056.012936259 30 ctime=1744351535.566908465 gcl-2.7.1/xgcl-2/Events.c0000644000175000017500000016045014555557372013476 0ustar00cammcamm/* Events.c Hiep Huu Nguyen 27 Jun 06 */ /*; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; Copyright (c) 2024 Camm Maguire ; 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.7.1/PaxHeaders/lsp0000644000000000000000000000013114776006046012076 xustar0030 mtime=1744309286.186034518 30 atime=1744351538.814879383 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/0000755000175000017500000000000014776006046011552 5ustar00cammcammgcl-2.7.1/lsp/PaxHeaders/gcl_sf.lsp0000644000000000000000000000013114776006046014130 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.294035039 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_sf.lsp0000644000175000017500000001731514776006046013536 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :cstruct) (defun strcat (&rest r) (declare (dynamic-extent r)) (nstring-downcase (apply 'string-concatenate r))) #.`(defun end-shft (s &optional (sz 1)(b fixnum-length)) (declare (ignorable sz b)) ,(if (member :clx-little-endian *features*) 's '(- b s sz))) (si::putprop 'end-shft t 'si::cmp-inline) (eval-when (eval compile) (defun sferr (&rest r) (print r)) (defun foo-reader (stream subchar) (declare (ignore subchar) (optimize (safety 2))) (let ((x (read-delimited-list #\} stream))) (let (zz z r) (mapc #'(lambda (x) (cond ((member x '(|enum| |union| |struct| |unsigned|)) (setq zz x)) ((not z) (setq z (if zz (list zz x) x))) ((integerp x) (setq r (cons (list z (cadar r) x) (cdr r)))) ((eq x '|;|) (setq z nil zz nil)) ((push (list z x) r)))) x) (nreverse r)))) (defun |;-reader| (stream subchar) (declare (ignore stream subchar) (optimize (safety 2))) '|;|) (defun readtable-h nil (si:set-readtable-case *readtable* :preserve) (set-macro-character #\{ 'foo-reader) (set-macro-character #\; '|;-reader|) (set-syntax-from-char #\# #\;) (set-syntax-from-char #\} #\)) (dolist (l '(#\: #\| #\, #\. #\( #\))) (set-syntax-from-char l #\Space))) (defun get-com (f &aux x com td (*readtable* (copy-readtable))) (readtable-h) (let ((s (si::open-int f :input 'character nil nil nil nil :default))) (do ((y nil x)(z nil y)) ((eq 'eof (setq x (read s nil 'eof))) (unless (and com td) (sferr "h read error" x)) (list com td)) (when (and (member z '(|struct| |union|)) (consp x)) (push (list z y x) com)) (when (eq x '|typedef|) (push (read-delimited-list #\; s) td))))) (defun td (k l) (let* ((kn (when (symbolp k) (string-upcase (symbol-name k)))) (kk (when kn (mktp kn))) (kk (when kk (intern kn :keyword))) (x (car (member k l :key #'(lambda (x) (car (last x))))))) (cond (kk) ((not x) k) ((eq (car x) '|unsigned|) (cons (td (cadr x) l) (car x))) ((not (cddr x)) (td (car x) l)) (x)))) (defun mrin (f x &key key) (mapcan 'identity (maplist #'(lambda (x) (when (funcall f (funcall key (car x))) (list (car x)))) x))) (defun slist nil (let* ((com (get-com "h/cmpinclude.h")) (td (cadr com)) (com (car com)) (u (car (member-if #'(lambda (x) (and (eq (car x) '|union|) (eq (cadr x) '|lispunion|))) com))) (u (mrin 'consp (caddr u) :key 'car))) (mapcar #'(lambda (x) (let ((y (car (member-if #'(lambda (z) (when (consp (car x)) (and (eq (caar x) (car z)) (eq (cadar x) (cadr z))))) com)))) (list (car x) (cadr x) (mapcar #'(lambda (z) (cons (td (car z) td) (cdr z))) (caddr y))))) u))) (defun bz (x) (ash 1 (+ x 3))) (defun ks (k &aux (x (or (cadr (assoc k +ks+)) +fl+))) (bz x)) (defun bs (y &aux (w y)(k (pop y))(k (if (consp k) (car k) k))) (or (cadr y) (ks k))) (defun sb (c z &aux (q (load-time-value (mapcar 'bz '(0 1 2 3))))) ;FIXME dcomplex +kss+ (or (car (member (+ (mod c (car q)) z) q :test '<=)) (sferr "boo" c z))) (defun cmp-norm-tpp (x) x) (defun mtpp (k y &aux (zz (car y))(z (if (consp zz) (car zz) zz))(u (when (consp zz) (eq (cdr zz) '|unsigned|)))) (cond ((caddr y) (unless u (sferr "bar" k y)) (cmp-norm-tpp `(unsigned-byte ,(caddr y)))) ((when (keywordp z) (eq k :object)) (mktp z));(get z 'lisp-type)) ((mktp k));((get k 'lisp-type)) (t))) (defun pp (y &aux (n (string (cadr y)))) (when (eql #\* (aref n 0)) (list :fixnum (intern (subseq n 1))))) (defun m& (x m) (if m `(& ,x ,m) x)) (defun m<< (x s) (if (zerop s) x `(<< ,x ,s))) (defun m>> (x s) (if (zerop s) x `(>> ,x ,s))) (defun m\| (x m) (if m `(\| ,x ,m) x)) (defun mm (m) (if (zerop (logand (ash 1 (1- fixnum-length)) m)) m (- m (ash 1 fixnum-length)))) (defun m+ (a o) (if (zerop o) a `(c+ ,a ,o))) (defun gu (b k &aux (k (car k))) (when(< b fixnum-length) (when (consp k) (eq (cdr k) '|unsigned|))));no unsigned access for fixnum length (defun gk (b y u &aux (k (car y))(k (if (consp k) (car k) k))) (cond ((or u (< b (ks k))) (or (caar (member-if #'(lambda (x) (and (eql (bz (cadr x)) b) (eql (caddr x) (if u 1 0)))) +ks+)) (sferr "key mismatch" b y k u))) ((car (assoc k +ks+))) ((keywordp k) :object) (:fixnum))) (defun mktp (z &aux (z (string-upcase z))) (or (find-symbol z :cl) (get (find-symbol z :keyword) 'lisp-type))) (defun btp (z) (or (cmp-norm-tpp (mktp z)) t)) (defun idefun (args &aux (n (pop args))) `(progn (defun ,n ,@args) (si::putprop ',n t 'si::cmp-inline) (export ',n))) (defun afn (n tp body &optional ytp) (idefun `(,n (x ,@(when ytp `(y))) (declare (optimize (safety 1))) ,@(unless (eq tp t) `((check-type x ,tp))),@(when ytp `((check-type y ,ytp))) ,@body))) (defun gbe (f tp o s sz b a u &aux (s (end-shft s sz b))) `((the ,tp ,(m& (m>> `(,f ,a ,o nil nil) s) (when (< (+ (if u s 0) sz) b) (mm (1- (ash 1 sz))))))));cannot downshift signed without mask (defun sbe (f o s sz b a &aux (s (end-shft s sz b))) `((,f ,a ,o t ,(m\| (m<< 'y s) (when (< sz b) `(& (,f ,a ,o nil nil) ,(~ (mm (ash (1- (ash 1 sz)) s))))))) y)) (defun fnk (k) (intern (string-concatenate "*" (string k)))) (defun mnn (r z f) (intern (nstring-upcase (string-concatenate r z "-" f)))) (defun mn (z p f &aux (f (strcat f))) (list (mnn "C-" z f) (mnn "C-SET-" z f))) (defconstant +unaligned-access+ nil) (defun afn2 (z p c sz y &aux (b (sb c sz))(u (gu b y))(k (gk b y u))(f (fnk k))(rtp (mtpp k y))(tp (btp z))(nl (mn z p (cadr y)))) (multiple-value-bind (o s) (truncate c b) (multiple-value-bind (bo s) (if +unaligned-access+ (truncate s 8) (values 0 s)) (when (> (+ s sz) b) (sferr "bit field overflow" s sz b z p y)) (let ((a (m+ `(address x) bo))) (list (afn (pop nl) tp (gbe f rtp o s sz b a u)) (afn (car nl) tp (sbe f o s sz b a) rtp)))))) (defun nmf (x y &aux (p (strcat (cadr x) "_"))(f (strcat (cadr y)))(s (string= p (subseq f 0 (min (length f) (length p)))))) (when s (rplaca (cdr y) (intern (subseq f (length p)))) t)) (defun fp (c x y) (cond ((nmf x y) x) ((< c fixnum-length) (cons '(|struct| |t|) (cons '|t| (cddr x)))))) (defun mrd (x &key test key) (mapcan 'identity (maplist #'(lambda (x) (unless (member (funcall key (car x)) (cdr x) :test test :key key) (list (car x)))) x))) (defun macc nil (mrd (mapcan #'(lambda (x &aux (c 0)) (mapcan #'(lambda (y &aux (y (or (pp y) y))(sz (bs y))(c (prog1 c (incf c sz)))(x (fp c x y))) (when x `((,(cadar x) ,(cadr x) ,c ,sz ,y)))) (caddr x))) (slist)) :test 'equal :key 'cddr))) #.`(progn ,@(mapcan #'(lambda (x) (apply 'afn2 x)) (macc))) #.(idefun `(function-env (fun i) (declare (optimize (safety 1))) (check-type i seqind) (*object (c-function-env fun) i nil nil))) #.(idefun `(package-internal (p i) (declare (optimize (safety 1))) (check-type i seqind) (*object (c-package-internal p) i nil nil))) #.(idefun `(package-external (p i) (declare (optimize (safety 1))) (check-type i seqind) (*object (c-package-external p) i nil nil))) #.(idefun `(hashtable-self (h i) (declare (optimize (safety 1))) (check-type i seqind) (c+ (c-hashtable-self h) (<< i #.(integer-length (/ si::fixnum-length si::char-length)))))) #.(idefun `(array-dims (s i) (declare (optimize (safety 1)));FIXME check-type s or safety 2 (check-type i seqind) (the seqind (*fixnum (c-matrix-dims s) i nil nil)))) #.(idefun `(set-array-dims (s i j) (declare (optimize (safety 1))) (check-type i seqind) (check-type j seqind) (the seqind (*fixnum (c-matrix-dims s) i t j)))) gcl-2.7.1/lsp/PaxHeaders/gcl_lr.lsp0000644000000000000000000000013114774225145014136 xustar0030 mtime=1743858277.045814259 30 atime=1744346652.093823691 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_lr.lsp0000644000175000017500000001413014774225145013534 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (eval-when (compile) ;; (dolist (l '(^ \| & ~ >> <<)) ;; (unintern l)(import (find-symbol (symbol-name l) 'c) 'si)) );FIXME (eval-when (compile) (defmacro defbltin (n) `(progn (defun ,n (x) (declare (fixnum x)) (the (integer 0 ,(integer-length most-positive-fixnum)) (lit :fixnum ,(strcat "__builtin_" n "(") (:fixnum x) ")"))) (declaim (inline ,n)))) (defmacro defp nil (labels ((lcf (shft &optional res) (if (> (abs shft) (integer-length most-positive-fixnum)) (nreverse res) (lcf (ash shft 1) (cons `(x (+ x (ash x ,shft))) res)))) (lc (pat shft) (if (> shft (integer-length most-positive-fixnum)) pat (lc (logior pat (ash pat shft)) (ash shft 1))))) `(progn (defun popcount (x) (declare (non-negative-fixnum x)) (let* ((x (- x (logand (ash x -1) ,(lc 5 4)))) (x (+ (logand x ,(lc 3 4)) (logand (ash x -2) ,(lc 3 4)))) (x (logand ,(lc 15 8) (+ x (ash x -4)))) ,@(lcf -8)) (logand x ,(1- (ash (1+ (integer-length most-positive-fixnum)) 1))))) (declaim (inline popcount))))) (defmacro defl* ((f d &optional r c c1 c2 (nn f))) (let* ((b (symbol-name nn)) (fb (intern (concatenate 'string (symbol-name f) "B2"))) (ls (intern (concatenate 'string "LOG" b))) (s (cdr (assoc f '((eqv . &)(and . &)(ior . \|)(xor . ^))))) (f `(,s n1 n2)) (f (if c `(~ ,f) f)) (q `(if (and (typep n1 'fixnum) (typep n2 'fixnum)) ,f (the integer (,fb n1 n2 ,c)))) (q (if r `(if r (apply ',ls ,q (car r) (cdr r)) ,q) q))) `(defun ,ls ,(if r `(&optional (n1 ,d) (n2 ,d) &rest r) `(n1 n2)) ,@(when r `((declare (dynamic-extent r)))) (declare (optimize (safety 1))) (check-type n1 integer) (check-type n2 integer) (let (,@(when c1 `((n1 (lognot n1)))) ,@(when c2 `((n2 (lognot n2))))) ,q))))) (defl* (and -1 t)) (defl* (ior 0 t)) (defl* (xor 0 t)) (defl* (xor -1 t t nil nil eqv)) (defl* (and -1 nil t nil nil nand)) (defl* (ior 0 nil t nil nil nor)) (defl* (and -1 nil nil t nil andc1)) (defl* (and -1 nil nil nil t andc2)) (defl* (ior 0 nil nil t nil orc1)) (defl* (ior 0 nil nil nil t orc2)) (defp) (defun lognot (x) (declare (optimize (safety 1))) (check-type x integer) (if (typep x 'fixnum) (~ x) (mpz_com x))) (defun boole (op n1 n2) (declare (optimize (safety 1))) (check-type op (integer 0 15)) (check-type n1 integer) (check-type n2 integer) (case op (#.boole-and (logand n1 n2)) (#.boole-ior (logior n1 n2)) (#.boole-xor (logxor n1 n2)) (#.boole-eqv (logeqv n1 n2)) (#.boole-nand (lognand n1 n2)) (#.boole-nor (lognor n1 n2)) (#.boole-andc1 (logandc1 n1 n2)) (#.boole-andc2 (logandc2 n1 n2)) (#.boole-orc1 (logorc1 n1 n2)) (#.boole-orc2 (logorc2 n1 n2)) (#.boole-clr 0) (#.boole-set -1) (#.boole-1 n1) (#.boole-2 n2) (#.boole-c1 (lognot n1)) (#.boole-c2 (lognot n2)))) (deftype shft-integer nil `(integer * ,most-positive-fixnum)) (defbltin clzl) (defbltin ctzl) (defbltin popcountl) (defbltin parityl) (defbltin ffsl) (defun ash (x y &aux (lw #.(- fixnum-length))) (declare (optimize (safety 1))) (check-type x integer) (check-type y shft-integer) (if (typep y 'fixnum) (let ((y y)) (if (= y 0) x (if (typep x 'fixnum) (let ((x x)) (if (< y 0) (let ((y (if (= y most-negative-fixnum) y (- y)))) (if (/= 0 (logand y lw)) (if (< x 0) -1 0) (>> x y))) (if (< y (clzl x)) (<< x y) (mpz_mul_2exp x y)))) (if (< y 0) (mpz_fdiv_q_2exp x (if (= y most-negative-fixnum) y (- y))) (mpz_mul_2exp x y))))) (if (< x 0) -1 0))) (defun integer-length (x) (declare (optimize (safety 1))) (check-type x integer) (if (typep x 'fixnum) (let ((x (if (minusp x) (lognot x) x))) (if (= x 0) x (- fixnum-length (clzl x)))) (mpz_sizeinbase (if (minusp x) (lognot x) x) 2))) (defun logcount (x) (declare (optimize (safety 1))(inline popcountl)) (check-type x integer) (if (typep x 'fixnum) (popcountl (if (< x 0) (lognot x) x)) (mpz_popcount (if (< x 0) (lognot x) x)))) (defun logbitp (y x) (declare (optimize (safety 1))) (check-type x integer) (check-type y (integer 0)) (if (typep y 'fixnum) (if (typep x 'fixnum) (if (<= y #.(1- (integer-length most-positive-fixnum))) (not (zerop (logand x (ash 1 y)))) (minusp x)) (not (zerop (mpz_tstbit x y)))) (minusp x))) (declaim (inline immfixp)) (defun immfixp (x) (lit :boolean "is_imm_fixnum(" (:object x) ")")) (defun mpz_sgn (x) (declare (optimize (safety 1))) (check-type x bignum) (lit :fixnum "mpz_sgn(&(" (:object x) "->big.big_mpz_t))")) (putprop 'mpz_sgn t 'compiler::cmp-inline) ;(declaim (inline mpz_sgn)) (defun mpz_odd_p (x) (declare (optimize (safety 1))) (check-type x bignum) (lit :fixnum "mpz_odd_p(&(" (:object x) "->big.big_mpz_t))")) (putprop 'mpz_odd_p t 'compiler::cmp-inline) ;(declaim (inline mpz_odd_p)) (defun mpz_even_p (x) (declare (optimize (safety 1))) (check-type x bignum) (lit :fixnum "mpz_even_p(&(" (:object x) "->big.big_mpz_t))")) (putprop 'mpz_even_p t 'compiler::cmp-inline) ;(declaim (inline mpz_even_p)) (defun plusp (x) (declare (optimize (safety 1))) (check-type x real) (typecase x (fixnum (> x 0)) (bignum (> (mpz_sgn x) 0)) (ratio (plusp (numerator x))) (short-float (> x 0)) (long-float (> x 0)))) (defun minusp (x) (declare (optimize (safety 1))) (check-type x real) (typecase x (fixnum (< x 0)) (bignum (< (mpz_sgn x) 0)) (ratio (minusp (numerator x))) (short-float (< x 0)) (long-float (< x 0)))) (defun zerop (x) (declare (optimize (safety 1))) (check-type x number) (typecase x (fixnum (= x 0)) (short-float (= x 0)) (long-float (= x 0)) (fcomplex (= x 0)) (dcomplex (= x 0)))) (defun oddp (x) (declare (optimize (safety 1))) (check-type x integer) (typecase x (fixnum (/= 0 (logand 1 x))) (bignum (/= 0 (mpz_odd_p x))))) (defun evenp (x) (declare (optimize (safety 1))) (check-type x integer) (typecase x (fixnum (= 0 (logand 1 x))) (bignum (/= 0 (mpz_even_p x))))) gcl-2.7.1/lsp/PaxHeaders/gcl_debug.lsp0000644000000000000000000000013214774225145014610 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.344938378 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_debug.lsp0000644000175000017500000005746714774225145014231 0ustar00cammcamm;;Copyright William F. Schelter 1990, All Rights Reserved ;;Copyright 2024 Camm Maguire (In-package :SYSTEM) (import 'sloop::sloop) (eval-when (compile eval) (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);FIXME (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 ((functionp fun) (setq name (fun-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) ;FIXME &aux (ihs *current-ihs*) (base (ihs-vs ihs)) (*print-level* *debug-print-level*) (*print-circle* t) (*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 ((functionp fun) (setq name (fun-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)) (defun stream-name (str) (when (typep str 'pathname-designator) (namestring (pathname str)))) (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*) (unless (open-stream-p (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) (declare (ignore 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)))) (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) (ignorable na)) (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))))))) ((mv-values nil nil nil nil nil))))))) (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)(= 0 (address (vs i)))));FIXME (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.7.1/lsp/PaxHeaders/gcl_make_pathname.lsp0000644000000000000000000000013114774225145016313 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_make_pathname.lsp0000644000175000017500000002035514774225145015717 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defun pathnamep (x) (declare (optimize (safety 1))) (when (typep x 'pathname) t)) (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) (defun msub (a x) (if a (msub (cdr a) (substitute (caar a) (cdar a) x)) x)) (defconstant +glob-to-regexp-alist+ (list (cons #v"{[^}]*}" (lambda (x y) (declare (ignore y)) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x))) (cons #v"\\[[^\\]*\\]" (lambda (x y) (declare (ignore y)) (string-concatenate "(" (substitute #\^ #\! (subseq x 0 2)) (subseq x 2) ")"))) (cons #v"\\*" (lambda (x y) (declare (ignore x)) (if (plusp (length y)) (string-concatenate "([^" y "]*)") "(.*)"))) (cons #v"\\?" (lambda (x y) (declare (ignore x)) (if (plusp (length y)) (string-concatenate "([^" y "])") "(.)"))) (cons #v"\\." (lambda (x y) (declare (ignore x y))"\\.")))) (defconstant +physical-pathname-defaults+ '(("" "" "" "") ("" "" "" "") ("" "(/?([^/]+/)*)" "" "" "" "([^/]+/)" "/" "/") ("" "([^/.]*)" "" ".") ("." "(\\.[^/]*)?" "" "") ("" "" "" ""))) (defconstant +logical-pathname-defaults+ '(("" "([-0-9A-Z]+:)?" ":" ":") ("" "" "" "") ("" "(;?((\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*\\*?);)*)" "" "" "" "((\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*);)" ";" ";"); ; ("" "(;?((\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*|\\*\\*);)*)" "" "" "((\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*);)" ";") ("" "(\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*)?" "" ".") ; ("" "(\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*)?" "") ("." "(\\.(\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*))?" "" ".") ; ("." "(\\.(\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*))?" "") ("." "(\\.([1-9][0-9]*|newest|NEWEST|\\*))?" "" ""))) (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 term &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)) term) (mgsub x term l (cadr w))) (subseq x b))) (defun elsub (el x rp lp &aux (y x) (pref (pop y))(dflt (pop y))(post (pop y))(term (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 (lambda (x) (mgsub x term)) 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) (cond ((eq l :wild) (canonicalize-pathname-directory '(:absolute :wild-inferiors))) ((stringp l) (canonicalize-pathname-directory (list :absolute l))) ((mapl (lambda (x &aux (c (car x))) (when (and (or (stringp c) (eq c :wild)) (eq (cadr x) :back)) (return-from canonicalize-pathname-directory (canonicalize-pathname-directory (nconc (ldiff-nf l x) (cddr x)))))) l)))) (defvar *default-pathname-defaults* (init-pathname nil nil nil nil nil nil "")) (declaim (type pathname *default-pathname-defaults*)) (defun toggle-case (x) (etypecase x (symbol x) (list (mapcar 'toggle-case x)) (string (if (find-if 'upper-case-p x) (if (find-if 'lower-case-p x) x (string-downcase x)) (string-upcase x))))) (declaim (inline toggle-case)) (defun assert-uppercase (x) (etypecase x (symbol x) (list (mapcar 'assert-uppercase x)) (string (if (find-if 'lower-case-p x) (string-upcase x) x))));FIXME find in string-upcase (declaim (inline assert-uppercase)) (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 (if h (assert-uppercase 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 (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-nf x q) q)))) gcl-2.7.1/lsp/PaxHeaders/gcl_top.lsp0000644000000000000000000000013114774225145014323 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_top.lsp0000644000175000017500000006027714774225145013736 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 '(loc *tmp-dir* *debug-print-level* *break-readtable* *break-enable* vs ihs-vs ihs-fun frs-vs frs-bds frs-ihs bds-var bds-val super-go)) ;FIXME ? (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) (defconstant +top-ihs+ 1) (defvar *current-ihs* +top-ihs+) (defvar *frs-base* 0) (defvar *frs-top* 0) (defvar *break-enable* t) (defvar *break-message* "") (defvar *break-on-warnings* nil) (defvar *break-readtable* nil) (defvar *top-level-hook* nil) (defvar *top-eof* (cons nil nil)) (defvar *no-prompt* nil) (defun user-package nil (find-package (if (member :ansi-cl *features*) "CL-USER" "USER"))) (defun emergency-reset nil (let ((x (load-time-value (mapcar (lambda (x) (cons x (symbol-function x))) '(format read find-package package-name reset-stack-limits eq bye eval fresh-line prin1 terpri)))) (y (load-time-value (copy-readtable nil))) (z (load-time-value (user-package)))) (dolist (x x) (emergency-fset (car x) (cdr x))) (setq *readtable* y) (setq *package* z) (format t "Emergency reset complete~%"))) (defun show-lib-syms nil (when (find-package "LIB") (do-external-symbols (p "LIB") (print (list p (symbol-value p) (find-package p))) (do-external-symbols (s p) (print (list s (symbol-value s) (when (fboundp s) (symbol-function s)))))))) (defun coerce-to-package (p) (cond ((packagep p) p) ((find-package p)) (t (cerror "Input new package" 'package-error :package p :format-control "~a is not a package" :format-arguments (list p)) (coerce-to-package (eval (read)))))) ;(declaim (inline coerce-to-package)) (defun reset-lib-syms nil (when (find-package "LIB") (do-external-symbols (p "LIB") (setf (symbol-value p) (dlopen (lib-name p))) (do-external-symbols (s p) (setf (symbol-value s) (dlsym (symbol-value p) s))))) (cfdl)) (defun top-level1 () (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)) ((stat "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 set to ~a~%" *tmp-dir*)) (loop (when (catch +top-abort-tag+ (loop (when (catch *quit-tag* (setq +++ ++ ++ + + -) (if *no-prompt* (setq *no-prompt* nil) (format t "~%~a>" (if (eq *package* (user-package)) "" (package-name *package*)))) (reset-stack-limits t) ;; have to exit and re-enter to multiply stacks (cond (*multiply-stacks* (Return-from top-level1))) (setq - (locally (declare (notinline read)) (read *standard-input* nil *top-eof*))) (when (eq - *top-eof*) (bye)) ; (si::clear-c-stack 4096) (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) (break-current))) nil) (emergency-reset))))) (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."))) (defvar *system-banner*) (defun gcl-top-level nil (set-up-top-level) (setq *package* (user-package)) (setq *ihs-top* (ihs-top)) (top-level1)) (defun top-level nil (gcl-top-level)) (defun set-dir (sym val) (let ((tem (or val (and (boundp sym) (symbol-value sym))))) (if tem (set sym (coerce-slash-terminated tem))))) (defun process-some-args (args &optional compile &aux *load-verbose*) (when args (let ((x (pop args))) (cond ((string-equal x "-load") (load (pop args))) ((string-equal x "-eval") (eval (read-from-string (pop args)))) ((string-equal x "-batch") (setq *top-level-hook* 'bye)) ((or (equal x "-v") (equal x "--version")) (format t "~a~%" (lisp-implementation-version)) (setq *top-level-hook* 'bye)) ((string-equal x "-o-file") (unless (read-from-string (car args)) (push (cons :o-file nil) compile) (pop args))) ((string-equal x "-h-file") (push (cons :h-file t) compile)) ((string-equal x "-data-file") (push (cons :data-file t) compile)) ((string-equal x "-c-file") (push (cons :c-file t) compile)) ((string-equal x "-system-p") (push (cons :system-p t) compile)) ((string-equal x "-compile") (push (cons :compile (pop args)) compile)) ((string-equal x "-o") (push (cons :o (pop args)) compile)) ((string-equal x "-libdir") (set-dir '*lib-directory* (pop args))) ((string-equal x "-dir") (set-dir '*system-directory* (pop args))) ((string-equal x "-f") (do-f (car (setq *command-args* args)))) ((string-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))) (multiple-value-bind (r w e) (apply 'compile-file file (mapcan (lambda (x) (list (car x) (cdr x))) compile)) (declare (ignore r w)) (bye (if e 1 0)))))) (defun dbl-read (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil)) (tagbody top (let ((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))) (let* ((x (read stream eof-error-p eof-value)) (ch (read-char-no-hang stream eof-error-p eof-value))) (cond ((when ch (unless (eq ch eof-value) (unread-char ch stream)))) ((and (keywordp x) ch) (cons x (read-from-string (string-concatenate "(" (read-line stream eof-error-p eof-value) ")")))) (x)))) (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) (let ((x (bds-val bi))) (if (zerop x) "unbound" (nani x))))))) (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));FIXME (format t "~&~:[ ~;@ ~]IHS[~d]: ~s ---> VS[~d]" (= i *current-ihs*) i (let ((fun (ihs-fun i))) (cond ((symbolp fun) fun) ((functionp fun) (fun-name 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 (> *current-ihs* +top-ihs+) (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) ((functionp fun) (fun-name fun));(name fun) ((consp fun) (case (car fun) (lambda 'lambda) ((lambda-block lambda-block-expanded) (cadr fun)) (lambda-block-closure (cadr (cdddr fun))) (lambda-closure 'lambda-closure) (t (if (and (symbolp (car fun)) (or (special-operator-p (car fun)) (fboundp (car fun)))) (car fun) :zombi) ))) (: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. To add a new one, add an '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 (and (eq (stat str) :directory) (not (eql #\/ (aref str (1- (length str)))))) (string-concatenate 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 (stat x) :directory) (return-from get-temp-dir x)))))) (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 dir-name (s &aux (i (string-match "/[^/]*$" s))) (if (eql -1 i) "" (subseq s 0 i))) (defvar *lib-directory* (coerce-slash-terminated (dir-name (dir-name (kcl-self))))) (defvar *cc* nil) (defvar *ld* nil) (defvar *objdump* nil) (defvar *current-directory* *system-directory*) (defun current-directory-namestring nil (coerce-slash-terminated (getcwd))) (defun set-up-top-level (&aux (i (argc)) tem) (declare (fixnum i)) (reset-lib-syms) (setq *tmp-dir* (get-temp-dir) *current-directory* (current-directory-namestring)) (when *cc* ;raw-image init complete (setq *current-directory* (pathname *current-directory*) *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*) (let ((dir (getenv "GCL_LIBDIR"))) (when dir (setq *lib-directory* (coerce-slash-terminated dir)))) (unless (and *load-path* (equal tem *lib-directory*)) (reset-sys-paths *lib-directory*))) (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-file 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.7.1/lsp/PaxHeaders/gcl_evalmacros.lsp0000644000000000000000000000013214774225145015656 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_evalmacros.lsp0000644000175000017500000005411714774225145015264 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) (export '(*debug* *compiler-check-args* *safe-compile* *compiler-new-safety* *compiler-push-events* *space* *speed* proclaimed-signature *alien-declarations* write-sys-proclaims make-function-plist lit sgen cmp-inline cmp-notinline cmp-type)) ;(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 zcollect (v r rp np &aux (s (sgen "ZCOLLECT"))) `(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))) (defun lit (&rest r) (error "lit called with args ~s~%" r)) (defmacro sgen (&optional (pref "G")) `(load-time-value (gensym ,pref))) (defmacro defvar (var &optional (form nil form-sp) doc-string) (declare (optimize (safety 2))) `(progn (*make-special ',var) ,@(when doc-string `((set-documentation ',var 'variable ,doc-string))) ,@(when form-sp `((unless (boundp ',var) (setq ,var ,form)))) ',var)) (defmacro defparameter (var form &optional doc-string) (declare (optimize (safety 2))) `(progn (*make-special ',var) ,@(when doc-string `((set-documentation ',var 'variable ,doc-string))) (setq ,var ,form) ',var)) (defmacro defconstant (var form &optional doc-string) (declare (optimize (safety 2))) `(progn (*make-constant ',var ,form) ,@(when doc-string `((set-documentation ',var 'variable ,doc-string))) ',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);FIXME simplify with recursive labels (declare (optimize (safety 2))) (do ((y forms))((endp y) (if forms r t)) (let ((x (pop y))) (if (constantp x) (unless (if (eval x) y) (zcollect x r rp np) (setq y nil)) (if y (zcollect `(if ,@(setq np (list x))) r rp np) (zcollect x r rp np)))))) (defmacro or (&rest forms &aux r rp np (s (sgen "OR"))) (declare (optimize (safety 2))) (do ((y forms))((endp y) r) (let ((x (pop y))) (if (constantp x) (when (eval x) (zcollect x r rp np) (setq y nil)) (if (symbolp x) (zcollect `(if ,x ,@(setq np (list x))) r rp np) (if y (zcollect `(let ((,s ,x)) (if ,s ,@(setq np (list s)))) r rp np) (zcollect x r rp np))))))) ;; ,@(mapcan (lambda (x &aux (z (pop x))(z (if (eq z 'type) (pop x) z))) ;; (case z ;; ((ftype inline notinline optimize special dynamic-extent) nil) ;; (otherwise (mapcar (lambda (x) (list x x)) x)))) ;; (apply 'append (mapcar 'cdr dec))) (defmacro locally (&rest body) (declare (optimize (safety 2))) `(let () ,@body)) (defmacro loop (&rest body &aux (tag (sgen "LOOP"))) `(block nil (tagbody ,tag ,(?cons 'progn body) (go ,tag)))) (defun import (s &optional (p *package*)) (import-internal s p) t) (defun delete-package (p) (the boolean (values (delete-package-internal p)))) ;(import 'while #+ansi-cl 'cl-user #-ansi-cl 'user) (defmacro while (test &rest forms) (declare (optimize (safety 2))) `(loop (unless ,test (return)) ,@forms)) (defun funid-sym-p (funid &optional err) (cond ((symbolp funid) funid) ((when (consp funid);FIXME Too early for typecase (when (eq (car funid) 'setf) (when (consp (cdr funid)) (when (symbolp (cadr funid)) (null (cddr funid)))))) (setf-sym (cadr funid))) (t (when err (error 'type-error :datum funid :expected-type 'function-name))))) (defun funid-sym (funid) (funid-sym-p funid t)) (defun funid-p (funid &optional err) (cond ((symbolp funid) funid) ((when (consp funid) (eq (car funid) 'lambda)) funid) ((when (consp funid);FIXME Too early for typecase (when (eq (car funid) 'setf) (when (consp (cdr funid)) (when (symbolp (cadr funid)) (null (cddr funid)))))) (setf-sym (cadr funid))) (t (when err (error 'type-error :datum funid :expected-type 'function-name))))) (defun funid (funid) (funid-p funid t)) (defun funid-to-sym (funid) (funid-sym funid)) (defun setf-sym (funid) (values (intern (si::string-concatenate (let ((x (symbol-package funid))) (if x (package-name x) "")) "::" (symbol-name funid)) (load-time-value (or (find-package 'setf) (make-package-int 'setf nil nil)))))) (defmacro defmacro (name vl &rest body) (declare (optimize (safety 2))) `(let ((.fn. ,(defmacro-lambda name vl body))) (setf (macro-function ',name) .fn.) ',name)) (defmacro define-symbol-macro (sym exp) (declare (optimize (safety 2)) (ignore sym exp)) nil);FIXME placeholder (defmacro defun (name lambda-list &rest body) (declare (optimize (safety 2))) (let* ((doc (parse-body-header body)) (rs (funid-sym name)) (bn (if (eq rs name) name (cadr name)))) `(progn ,@(when doc `((setf (get ',rs 'function-documentation) ,doc))) (setf (symbol-function ',rs) ,(block-lambda lambda-list bn body)) ',name))) ; assignment (defmacro psetq (&rest args) (declare (optimize (safety 2))) (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 2))) (do ((y clauses))((endp y) r) (let* ((x (pop y))(z (pop x))) (if (constantp z) (when (eval z) (zcollect (if x (?cons 'progn x) z) r rp np) (setq y nil)) (if x (zcollect `(if ,z ,@(setq np (list (?cons 'progn x)))) r rp np) (if (symbolp z) (zcollect `(if ,z ,@(setq np (list z))) r rp np) (if y (zcollect `(let ((,s ,z)) (if ,s ,@(setq np (list s)))) r rp np) (zcollect `(values ,z) r rp np)))))))) (defmacro when (pred &rest body &aux (x (?cons 'progn body))) (declare (optimize (safety 2))) (if (constantp pred) (if (eval pred) x) `(if ,pred ,x))) (defmacro unless (pred &rest body &aux (x (?cons 'progn body))) (declare (optimize (safety 2))) (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) (declare (optimize (safety 2))) (prog?* 'let vl body)) (defmacro prog* (vl &rest body) (declare (optimize (safety 2))) (prog?* 'let* vl body)) ; sequencing (defmacro prog1 (first &rest body &aux (sym (sgen "PROG1"))) (declare (optimize (safety 2))) `(let ((,sym ,first)) (declare (ignorable ,sym)) ,@body ,sym)) (defmacro prog2 (first second &rest body &aux (sym (sgen "PROG2"))) (declare (optimize (safety 2))) `(progn ,first (let ((,sym ,second)) (declare (ignorable ,sym)) ,@body ,sym))) ; multiple values (defmacro multiple-value-list (form) (declare (optimize (safety 2))) `(multiple-value-call 'list ,form)) (defmacro multiple-value-setq (vars form) (declare (optimize (safety 2))) (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 2))) `(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-nf 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) (declare (optimize (safety 2))) (do?* nil control test result body)) (defmacro do* (control (test . result) &rest body) (declare (optimize (safety 2))) (do?* t control test result body)) (defmacro case (keyform &rest clauses &aux (key (sgen "CASE")) (c (reverse clauses))) (declare (optimize (safety 2))) (labels ((sw (x) `(eql ,key ',x))(dfp (x) (or (eq x t) (eq x 'otherwise))) (v (x) (if (when (listp x) (not (cdr x))) (car x) x)) (m (x c &aux (v (v x))) (if (eq v x) (cons c v) v))) `(let ((,key ,keyform)) (declare (ignorable ,key)) ,(let ((df (when (dfp (caar c)) (m (cdr (pop c)) 'progn)))) (lreduce (lambda (y c &aux (a (pop c))(v (v a))) (when (dfp a) (error 'program-error "default case must be last")) `(if ,(if (when (eq a v) (listp v)) (m (mapcar #'sw v) 'or) (sw v)) ,(m c 'progn) ,y)) c :initial-value df))))) ;; (defmacro case (keyform &rest clauses &aux (key (sgen "CASE")) f) ;; (declare (optimize (safety 2))) ;; (labels ((sw (x) `(eql ,key ',x)) ;; (df (aa ff) (when (member aa '(t otherwise)) (when ff (error 'program-error "default case must be last")) t))) ;; `(let ((,key ,keyform)) ;; (declare (ignorable ,key)) ;; ,(reduce (lambda (c y &aux (ff f)) (setq f t) ;; (let* ((aa (pop c)) ;; (ka (or (atom aa) (cdr aa))) ;; (da (if (and (listp c) (cdr c)) (cons 'progn c) (car c))) ;; (v (if ka aa (car aa)))) ;; (if (df aa ff) da ;; `(if ,(if (when ka (listp aa)) `(or ,@(mapcar #'sw v)) (sw v)) ,da ,y)))) ;; clauses :initial-value nil :from-end t)))) (defmacro ecase (keyform &rest clauses &aux (key (?key keyform))) (declare (optimize (safety 2))) (?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 2))) (?let key keyform `(do nil (nil);FIXME block (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 nil)) (declare (optimize (safety 2))) `(return-from nil ,val)) (defmacro dolist ((var form &optional (val nil)) &rest body &aux (temp (sgen "DOLIST"))) (declare (optimize (safety 2))) `(do* ((,temp ,form (cdr ,temp)) (,var (car ,temp) (car ,temp))) ((endp ,temp) ,val) (declare (ignorable ,temp)) ,@body)) ;FIXME try labels (defconstant +nontype-declare-keywords+ ;FIXME sync c1body '(special ignore ignorable optimize ftype inline notinline hint class object :register :dynamic-extent dynamic-extent)) (defmacro dotimes ((var form &optional val) &rest body &aux (s (sgen "DOTIMES"))(m (sgen "DOTIMES")) (t1 (load-time-value (list nil)))(t2 (load-time-value (list nil)))) (declare (optimize (safety 1))) (unless (car t1) (setf (car t1) (object-tp most-positive-fixnum))) (unless (car t2) (setf (car t2) (cmp-norm-tp `(integer ,(1+ most-positive-fixnum))))) (multiple-value-bind (doc decls) (parse-body-header body) (declare (ignore doc)) (let* ((dtypes (mapcan (lambda (x) (mapcan (lambda (y) (when (consp y) (unless (member (car y) +nontype-declare-keywords+) (when (member var (cdr y)) (list (if (eq (car y) 'type) (cadr y) (car y))))))) (cdr x))) decls)) (dtypes (if dtypes (cmp-norm-tp (cons 'and dtypes)) t))) `(let ((,s (block nil ,form))) (check-type ,s integer) (let ((,m (min (max 0 ,s) most-positive-fixnum))) (do ((,var 0 (1+ ,var))) ((>= ,var ,m) (when (> ,s most-positive-fixnum) ,@(when (tp-and (car t1) dtypes) `((let ((,var most-positive-fixnum)) (declare (ignorable ,var)) ,@body))) ;; non-negative-bignum a bumped type ,@(when (tp-and (car t2) dtypes) `((do ((,var (1+ most-positive-fixnum) (1+ ,var)))((>= ,var ,s)) ,@body)))) ,val) ,@body)))))) (defmacro declaim (&rest l) (declare (optimize (safety 2))) `(eval-when (compile eval load) ,@(mapcar (lambda (x) `(proclaim ',x)) l))) (defmacro lambda (&whole l &rest args) (declare (optimize (safety 2)) (ignore args)) `(function ,l)) (defmacro memq (a b) `(member ,a ,b :test 'eq)) (defmacro background (form) (let ((x (sgen "BACKGROUND"))) `(let ((,x (si::fork))) (if (eql 0 (car ,x)) (progn (si::write-pointer-object ,form ,x)(bye)) ,x)))) (defmacro with-read-values ((i r b) (forms timeout) &body body) (let* ((m (sgen "WITH-READ-VALUES")) (j (sgen "WITH-READ-VALUES")) (k (sgen "WITH-READ-VALUES")) (p (sgen "WITH-READ-VALUES")) (pbl (length forms)) (pbm (1- (ash 1 pbl)))) `(let* ((,m ,pbm) (,b (list ,@(mapcar (lambda (x) `(background ,x)) forms)))) (declare ((integer 0 ,pbm) ,m)) (unwind-protect (do nil ((= ,m 0)) (let ((,p (si::select-read ,b ,timeout)));;FAILURE code here on 0 return (declare ((integer 0 ,pbm) ,p)) (do ((,i 0 (1+ ,i))(,j 1 (ash ,j 1)) (,k ,b (cdr ,k))) ((= ,i ,pbl) (setq ,m (logandc2 ,m ,p))) (declare ((integer 0 ,pbl) ,i) ((integer 1 ,(1+ pbm)) ,j)) (when (/= 0 (logand ,j ,p)) (let ((,r (si::read-pointer-object (car ,k)))) ,@body))))) (dolist (,b ,b (cdr ,b)) (si::kill ,b 0)))))) (defmacro p-let (bindings &body body) (let* ((i (sgen "PLET")) (r (sgen "PLET")) (c (sgen "PLET")) (pb (remove-if 'atom bindings))) `(let* (,@(mapcar 'car pb) ,@(remove-if 'consp bindings)) (with-read-values (,i ,r ,c) (,(mapcar 'cadr pb) -1) (case ,i ,@(let ((g -1)) (mapcar (lambda (x) `(,(incf g) (setq ,(car x) ,r))) pb)))) ,@body))) (defmacro p-and (&rest forms) (let* ((i (sgen "P-AND")) (r (sgen "P-AND")) (c (sgen "P-AND")) (top (sgen "P-AND"))) `(block ,top (with-read-values (,i ,r ,c) (,forms -1) (unless ,r (dolist (,c ,c) (si::kill ,c 0)) (return-from ,top nil))) t))) (defmacro p-or (&rest forms) (let* ((i (sgen "P-OR")) (r (sgen "P-OR")) (c (sgen "P-OR")) (top (sgen "P-OR"))) `(block ,top (with-read-values (,i ,r ,c) (,forms -1) (when ,r (dolist (,c ,c) (si::kill ,c 0)) (return-from ,top t))) nil))) (defmacro define-compiler-macro (name vl &rest body &aux (n (funid-sym name)) (q (gensym (string n)))) (declare (optimize (safety 2))) `(progn (defun ,q ,@(cdr (defmacro-lambda (if (eq n name) name (cadr name)) vl body))) (putprop ',n ;FIXME setf not available at pre_gcl stage (symbol-function ',q) 'compiler-macro-prop) ',name)) (defun undef-compiler-macro (name) (remprop (funid-sym name) 'compiler-macro-prop)) (defun compiler-macro-function (n &optional env &aux (n (funid-sym n))) (declare (ignorable env)) (get n 'compiler-macro-prop)) (defun (setf compiler-macro-function) (fun n &optional env &aux (n (funid-sym n))) (declare (ignorable env)) (setf (get n 'compiler-macro-prop) fun)) (defvar *safe-compile* nil) (defvar *compiler-check-args* nil) (defvar *compiler-new-safety* nil) (defvar *compiler-push-events* nil) (defvar *speed* 3) (defvar *space* 0) (defvar *debug* 0) (defvar *alien-declarations* nil) (defun normalize-function-plist (plist) (setf (car plist) (uniq-sig (car plist)) (cadr plist) (mapcar (lambda (x) (cons (car x) (uniq-sig (cdr x)))) (cadr plist))) plist) (defvar *function-plists* nil);rely on defvar not resetting to nil on loading this file compiled (defun make-function-plist (&rest args) (cond ((and (fboundp 'cmp-norm-tp) (fboundp 'typep) (fboundp 'uniq-sig)) (mapc 'normalize-function-plist *function-plists*) (unintern '*function-plists*) (defun make-function-plist (&rest args) (normalize-function-plist args)) (normalize-function-plist args)) ((car (push args *function-plists*))))) (defun proclaim (decl &aux (a (car decl))(d (cdr decl))) (declare (optimize (safety 1))) (check-type decl list) (check-type (cdr decl) list) (case a (special (mapc (lambda (x) (check-type x symbol) (*make-special x)) d)) (optimize (mapc (lambda (y &aux (x (if (symbolp y) (list y 3) y))) (check-type x (cons t (cons (integer 0 3) null))) (let ((a (pop x))(ad (car x))) (ecase a (debug (setq *debug* ad)) (safety (setq *compiler-check-args* (>= ad 1)) (setq *safe-compile* (>= ad 2)) (setq *compiler-new-safety* (>= ad 3)) (setq *compiler-push-events* (>= ad 4))) (space (setq *space* ad)) (speed (setq *speed* ad)) (compilation-speed (setq *speed* (- 3 ad)))))) d)) (type (let ((q (pop d))) (check-type q type-spec) (proclaim-var q d))) (ftype (let ((q (pop d))) (check-type q ftype-spec) (proclaim-ftype q d))) ((inline notinline) (mapc (lambda (x &aux (y (funid-sym x))) (check-type x function-name) (putprop y t (if (eq a 'inline) 'cmp-inline 'cmp-notinline)) (remprop y (if (eq a 'inline) 'cmp-notinline 'cmp-inline))) d)) ((ignore ignorable) (mapc (lambda (x) (check-type x function-name)) d)) (declaration (mapc (lambda (x) (check-type x symbol) (pushnew x *alien-declarations*)) d)) (otherwise (cond ((when (symbolp a) (cmp-norm-tp a)) (proclaim-var a d)) ((unless (member a *alien-declarations*) (warn "The declaration specifier ~s is unknown." a))) ((symbolp a) (let ((y (get a :proclaim))) (when y (mapc (lambda (x) (funcall y x)) d))))))) nil) (defun proclaim-var (tp l &aux (tp (cmp-norm-tp tp))) (declare (optimize (safety 2))) (unless (or (eq tp '*) (eq tp t)) (mapc (lambda (x) (check-type x symbol) (assert (setq tp (tp-and tp (get x 'cmp-type t)))) (putprop x tp 'cmp-type)) l)));sch-global, improper-list (defun readable-sig (sig) (list (mapcar 'cmp-unnorm-tp (car sig)) (cmp-unnorm-tp (cadr sig)))) (defun type= (t1 t2) (when (type>= t1 t2) (type>= t2 t1))) ;FIXME, implement these in place of returns-exactly, etc. (defun ftype-to-sig (ftype &aux (a (pop ftype))(d (car ftype))) (let* ((x (member-if (lambda (x) (member x '(&optional &rest &key))) a)) (a (nconc (ldiff a x) (when x '(*)))) (x (when (and (listp d) (eq (car d) 'values)) d)) (y (member '&optional x)) (z (member-if (lambda (x) (member x '(&rest &allow-other-keys))) x)) (d (cond (z '*)(y (remove '&optional d))(x `(returns-exactly ,@(cdr d)))(d)))) (list a d))) (defun norm-possibly-unknown-type (type &aux (tp (cmp-norm-tp type))) (flet ((fix (tp) (or tp (when type t)))) (cond ((cmpt tp) `(,(pop tp) ,@(mapcar #'fix tp))) ((fix tp))))) (defun proclaim-ftype (ftype var-list &aux (sig (ftype-to-sig (cdr ftype))) (sig (uniq-sig (list (mapcar 'norm-possibly-unknown-type (car sig)) (norm-possibly-unknown-type (cadr sig)))))) (declare (optimize (safety 2))) (mapc (lambda (x) (setf (get x 'proclaimed-signature) sig));(unless (car (call x)) ) var-list)) (defun write-sys-proclaims (fn &rest string-list &aux (h (make-hash-table :test 'eq)) (*print-readably* t)) (with-open-file (q fn :direction :output) (do-all-symbols (s) (when (and (file s) (if string-list (member-if (lambda (x) (search x (namestring (file s)))) string-list) t)) (let ((x (or (car (sym-plist s)) (sig s)))) (when x (setf (gethash x h) (adjoin s (gethash x h))))))) (maphash (lambda (x y) (flet ((ptp (x) (normalize-type (cmp-unnorm-tp x)))) (print `(proclaim '(ftype (function ,(mapcan (lambda (x) (if (eq x '*) '(&rest t) (list (ptp x)))) (car x)) ,(cond ((cmpt (cadr x)) `(values ,@(when (eq (caadr x) 'values) `(&optional)) ,@(mapcar (lambda (x) (ptp x)) (cdadr x)))) ((eq (cadr x) '*) '(values &rest t)) ((ptp (cadr x))))) ,@y)) q))) h))) (defun write-sys-proclaims1 (fn sl &aux (h (make-hash-table :test 'eq)) (*print-readably* t)) (with-open-file (q fn :direction :output) (dolist (s sl) (let ((sym (car s))(sig (cadr s))) (setf (gethash sig h) (adjoin sym (gethash sig h))))) (flet ((ptp (x) (normalize-type (cmp-unnorm-tp x)))) (maphash (lambda (x y) (print `(proclaim '(ftype (function ,(mapcan (lambda (x) (if (eq x '*) '(&rest t) (list (ptp x)))) (car x)) ,(cond ((cmpt (cadr x)) `(values ,@(when (eq (caadr x) 'values) `(&optional)) ,@(mapcar (lambda (x) (ptp x)) (cdadr x)))) ((eq (cadr x) '*) '(values &rest t)) ((ptp (cadr x))))) ,@y)) q)) h)))) gcl-2.7.1/lsp/PaxHeaders/gcl_describe.lsp0000644000000000000000000000013214774225145015302 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_describe.lsp0000644000175000017500000004257714774225145014717 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'lisp) ;; (export '(describe inspect)) (in-package :system) (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") ((characterp character) "~S - 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 &optional stream &aux (*standard-output* (cond ((eq stream t) *terminal-io*) ((not stream) *standard-output*) (stream))) (*inspect-mode* nil) (*inspect-level* 0) (*inspect-history* nil) (*print-level* nil) (*print-length* nil)) ; "The lisp function DESCRIBE." (declare (optimize (safety 2))) (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." (declare (optimize (safety 2))) (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 (real-documentation symbol 'function) "") (if (macro-function symbol) "[Special form and Macro]" "[Special form]"))) ((macro-function symbol) (doc1 (or (real-documentation symbol 'function) "") "[Macro]")) ((fboundp symbol) (doc1 (or (real-documentation symbol 'function) (if (consp (setq x (function-lambda-expression (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 (real-documentation symbol 'function)) (doc1 x "[Macro or Function]"))) (cond ((constantp symbol) (unless (and (eq (symbol-package symbol) (find-package "KEYWORD")) (null (real-documentation symbol 'variable))) (doc1 (or (real-documentation symbol 'variable) "") "[Constant]"))) ((si:specialp symbol) (doc1 (or (real-documentation symbol 'variable) "") "[Special variable]")) ((or (setq x (real-documentation symbol 'variable)) (boundp symbol)) (doc1 (or x "") "[Variable]"))) (cond ((setq x (real-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 (real-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 (real-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 (package (or package (list-all-packages)))) (setq string (string string)) (do-symbols (symbol package) ;FIXME? do-symbols takes package list (when (search 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.7.1/lsp/PaxHeaders/gcl_sharp.lsp0000644000000000000000000000013114774225145014636 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_sharp.lsp0000644000175000017500000000527714774225145014250 0ustar00cammcamm(in-package :si) (defstruct context (first 1 :type seqind) (vec (make-array 10 :adjustable t :fill-pointer 0) :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 &aux (ctxt *sharp-eq-context*)) (declare (seqind i)) (when ctxt (let ((v (context-vec ctxt))(i (- i (context-first ctxt)))) (if (< -1 i (length v)) (aref v i) (let ((h (context-hash ctxt))) (when h (gethash1 i h))))))) (defun push-context (i) (declare (seqind i)) (unless *sharp-eq-context* (setq *sharp-eq-context* (make-context :first i))) (let* ((ctxt *sharp-eq-context*)(v (context-vec ctxt)) (l (length v))(x (cons nil nil))(i (- i (context-first ctxt)))) (cond ((< -1 i l) (error "#~s= multiply defined" i)) ((eql i l) (vector-push-extend x v (1+ l)) x) ((let ((h (context-hash ctxt))) (if h (when (gethash1 i h) (error "#~s= multiply defined" i)) (setf (context-hash ctxt) (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 (unless *read-suppress* (push-context i)))) (declare (ignore subchar));(fixnum i) (let ((y (read stream t 'eof t))) (unless *read-suppress* (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 (unless *read-suppress* (get-context i)))) (declare (ignore stream subchar));(fixnum i) (unless *read-suppress* (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 d) 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.7.1/lsp/PaxHeaders/gcl_auto_new.lsp0000644000000000000000000000013214776006046015342 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.294035039 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_auto_new.lsp0000644000175000017500000002120514776006046014740 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (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-method '|gcl_setf|) ;; (autoload 'get-setf-method-multiple-value '|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|) ;; (autoload 'logical-pathname-translations '|gcl_iolib|) ;; (autoload 'si::set-logical-pathname-translations '|gcl_iolib|) ;; (autoload 'ensure-directories-exist '|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|) ;; (autoload-macro 'with-standard-io-syntax '|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_dwtestcases|) (defun user::xgcl nil (use-package :xlib) (format t "Welcome to xgcl! Try (xgcl-demo) for a demonstration.")) (defun user::gcl-tk-demo nil (in-package :tk) (tkconnect) (load (file-search "gc-monitor" *load-path* (list ".o" ".lsp") nil)) (tk::mkgcmonitor)) ;; 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|) (AUTOLOAD 'user::xgcl-demo '|gcl_dwtest|) (defun user::xgcl nil (use-package :xlib) (format t "Welcome to xgcl! Try (xgcl-demo) for a demonstration.")) gcl-2.7.1/lsp/PaxHeaders/gcl_packlib.lsp0000644000000000000000000000013114774225145015126 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.356938455 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_packlib.lsp0000644000175000017500000002363514774225145014536 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'lisp) ;; (export '(find-all-symbols do-symbols do-external-symbols do-all-symbols with-package-iterator)) ;; (export '(apropos apropos-list)) (in-package :system) ;; ;; This slightly slower version uses less invocation history stack space ;; ;; (defmacro with-package-iterator ((name packlist key &rest keys) &rest body ;; &aux (*gensym-counter* 0) ;; (pl (sgen "WPI-PL")) (ql (sgen "WPI-QL")) ;; (ilim (sgen "WPI-ILIM")) (elim (sgen "WPI-ELIM")) ;; (p (sgen "WPI-P")) (q (sgen "WPI-Q")) (l (sgen "WPI-L")) ;; (a (sgen "WPI-A")) (x (sgen "WPI-X")) (y (sgen "WPI-Y"))) ;; (declare (optimize (safety 2))) ;; (let (int ext inh) ;; (dolist (key (cons key keys)) ;; (ecase key ;; (:internal (setq int t)) ;; (:external (setq ext t)) ;; (:inherited (setq inh t)))) ;; `(let* ((,pl ,packlist) ,p ,q ,ql (,x 0) (,y 0) (,ilim 0) (,elim 0) ,l ,a) ;; (declare ((integer 0 1048573) ,x ,y ,ilim ,elim) (ignorable ,x ,y ,ilim ,elim)) ;; (labels ;; ((match (s l) (member-if (lambda (x) (declare (symbol x)) (string= s x)) l)) ;; (iematch (s p h) (or (match s (package-internal p (mod h (package-internal_size p)))) ;; (match s (package-external p (mod h (package-external_size p)))))) ;; (next-var nil ;; (tagbody ;; :top ;; (cond ,@(when (or int ext) `(((when (eq ,q ,p) ,l) (return-from next-var (prog1 ,l (pop ,l)))))) ;; ,@(when inh `(((unless (eq ,q ,p) ,l) ;; (let* ((v (prog1 ,l (pop ,l))) (s (symbol-name (car v))) (h (pack-hash s))) ;; (when (iematch s ,p h) (go :top)) ;; (return-from next-var (progn (setq ,a :inherited) v)))))) ;; ,@(when int `(((and (eq ,q ,p) (< ,x ,ilim)) (setq ,l (package-internal ,q ,x) ,a :internal ,x (1+ ,x)) (go :top)))) ;; ,@(when (or ext inh) `(((< ,y ,elim) (setq ,l (package-external ,q ,y) ,a :external ,y (1+ ,y)) (go :top)))) ;; (,ql ;; (setq ,x 0 ,y 0 ,q (if (listp ,ql) (pop ,ql) (prog1 ,ql (setq ,ql nil)))) ;; (multiple-value-setq (,elim ,ilim) (package-size ,q)) ;; (go :top)) ;; (,pl ;; (setq ,p (coerce-to-package (if (listp ,pl) (pop ,pl) (prog1 ,pl (setq ,pl nil)))) ;; ,ql ,(if inh `(cons ,p (package-use-list ,p)) p)) ;; (go :top))))) ;; (,name nil (let ((f (next-var))) (values f (car f) ,a ,p)))) ;; ,@body)))) (defmacro with-package-iterator ((name packlist key &rest keys) &rest body &aux (*gensym-counter* 0) (pl (sgen "WPI-PL")) (ql (sgen "WPI-QL")) (ilim (sgen "WPI-ILIM")) (elim (sgen "WPI-ELIM")) (p (sgen "WPI-P")) (q (sgen "WPI-Q")) (l (sgen "WPI-L")) (a (sgen "WPI-A")) (x (sgen "WPI-X")) (y (sgen "WPI-Y"))) (declare (optimize (safety 1))) (let (int ext inh) (dolist (key (cons key keys)) (ecase key (:internal (setq int t)) (:external (setq ext t)) (:inherited (setq inh t)))) `(let* ((,pl ,packlist) ,p ,q ,ql (,x 0) (,y 0) (,ilim 0) (,elim 0) ,l ,a) (declare ((integer 0 1048573) ,x ,y ,ilim ,elim) (ignorable ,x ,y ,ilim ,elim)) (labels ((match (s l) (member-if (lambda (x) (declare (symbol x)) (string= s x)) l)) (inh-match (&aux (v (prog1 ,l (pop ,l))) (s (symbol-name (car v))) (h (pack-hash s))) (cond ((match s (package-internal ,p (mod h (package-internal_size ,p)))) (next-var)) ((match s (package-external ,p (mod h (package-external_size ,p)))) (next-var)) ((setq ,a :inherited) v))) (next-var nil (cond ,@(when (or int ext) `(((when (eq ,q ,p) ,l) (prog1 ,l (pop ,l))))) ,@(when inh `(((unless (eq ,q ,p) ,l) (inh-match)))) ,@(when int `(((and (eq ,q ,p) (< ,x ,ilim)) (setq ,l (package-internal ,q ,x) ,a :internal ,x (1+ ,x)) (next-var)))) ,@(when (or ext inh) `(((< ,y ,elim) (setq ,l (package-external ,q ,y) ,a :external ,y (1+ ,y)) (next-var)))) (,ql (setq ,x 0 ,y 0 ,q (if (listp ,ql) (pop ,ql) (prog1 ,ql (setq ,ql nil)))) (multiple-value-setq (,elim ,ilim) (package-size ,q)) (next-var)) (,pl (setq ,p (coerce-to-package (if (listp ,pl) (pop ,pl) (prog1 ,pl (setq ,pl nil)))) ,ql ,(if inh `(cons ,p (package-use-list ,p)) p)) (next-var)))) (,name nil (let ((f (next-var))) (values f (car f) ,a ,p)))) (declare (ignorable #'inh-match)) ,@body)))) ;; (defmacro with-package-iterator ((name packlist key &rest keys) &rest body ;; &aux (*gensym-counter* 0) ;; (pl (sgen "WPI-PL")) (ql (sgen "WPI-QL")) ;; (ilim (sgen "WPI-ILIM")) (elim (sgen "WPI-ELIM")) ;; (p (sgen "WPI-P")) (q (sgen "WPI-Q")) (l (sgen "WPI-L")) ;; (a (sgen "WPI-A")) (x (sgen "WPI-X")) (y (sgen "WPI-Y"))) ;; (declare (optimize (safety 2))) ;; (let (int ext inh) ;; (dolist (key (cons key keys)) ;; (ecase key ;; (:internal (setq int t)) ;; (:external (setq ext t)) ;; (:inherited (setq inh t)))) ;; `(let* ((,pl ,packlist) ,p ,q ,ql (,x 0) (,y 0) (,ilim 0) (,elim 0) ,l ,a) ;; (declare ((integer 0 1048573) ,x ,y ,ilim ,elim) (ignorable ,x ,y ,ilim ,elim)) ;; (labels ;; ((match (s l) (member-if (lambda (x) (declare (symbol x)) (string= s x)) l)) ;; (inh-match (&aux (v (prog1 ,l (pop ,l))) (s (symbol-name (car v))) (h (pack-hash s))) ;; (cond ((match s (package-internal ,p (mod h (package-internal_size ,p)))) (next-var)) ;; ((match s (package-external ,p (mod h (package-external_size ,p)))) (next-var)) ;; ((setq ,a :inherited) v))) ;; (next-var nil ;; (tagbody ;; :top ;; (cond ,@(when (or int ext) `(((when (eq ,q ,p) ,l) (return-from next-var (prog1 ,l (pop ,l)))))) ;; ,@(when inh `(((unless (eq ,q ,p) ,l) (return-from next-var (inh-match))))) ;; ,@(when int `(((and (eq ,q ,p) (< ,x ,ilim)) (setq ,l (package-internal ,q ,x) ,a :internal ,x (1+ ,x)) (go :top)))) ;; ,@(when (or ext inh) `(((< ,y ,elim) (setq ,l (package-external ,q ,y) ,a :external ,y (1+ ,y)) (go :top)))) ;; (,ql ;; (setq ,x 0 ,y 0 ,q (if (listp ,ql) (pop ,ql) (prog1 ,ql (setq ,ql nil)))) ;; (multiple-value-setq (,elim ,ilim) (package-size ,q)) ;; (go :top)) ;; (,pl ;; (setq ,p (coerce-to-package (if (listp ,pl) (pop ,pl) (prog1 ,pl (setq ,pl nil)))) ;; ,ql ,(if inh `(cons ,p (package-use-list ,p)) p)) ;; (go :top))))) ;; (,name nil (let ((f (next-var))) (values f (car f) ,a ,p)))) ;; ,@body)))) (eval-when (eval compile) (defmacro do-symbols1 ((var package result-form &rest keys) body &aux (*gensym-counter* 0)(m (sgen "DS-M"))(f (sgen "DS-F"))) `(multiple-value-bind (doc declarations check-types body) (parse-body-header ,body) (declare (ignore doc)) `(with-package-iterator (,',f ,,package ,,@keys) (do (,',m ,,var) ((not (multiple-value-setq (,',m ,,var) (,',f))) ,,result-form) (declare (ignorable ,',m) (symbol ,,var)) ,@declarations ,@check-types ,@body))))) (defmacro do-symbols ((var &optional (package '*package*) result-form) &rest body) (do-symbols1 (var package result-form :internal :external :inherited) body)) (defmacro do-external-symbols ((var &optional (package '*package*) result-form) &rest body) (do-symbols1 (var package result-form :external) body)) (defmacro do-all-symbols ((var &optional result-form) &rest body) (do-symbols1 (var '(list-all-packages) result-form :internal :external :inherited) body)) (defun find-all-symbols (sd) (declare (optimize (safety 1))) (check-type sd string-designator) (setq sd (string sd)) (mapcan (lambda (p) (multiple-value-bind (s i) (find-symbol sd p) (when (or (eq i :internal) (eq i :external)) (list s)))) (list-all-packages))) ;; (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-list (string &optional package &aux list (package (or package (list-all-packages)))) (declare (optimize (safety 1))) (setq string (string string)) (do-symbols (symbol package list) ;FIXME? (when (search string (string symbol) :test 'char-equal) (push symbol list))) (stable-sort list 'string< :key 'symbol-name)) (defun apropos (string &optional package) (declare (optimize (safety 1))) (dolist (symbol (apropos-list string package)) (print-symbol-apropos symbol)) (values)) (defun package-name (p) (c-package-name (si::coerce-to-package p))) (defun make-package (name &key nicknames use) (declare (optimize (safety 1))) (check-type name string-designator) (check-type nicknames proper-list) (check-type use proper-list) (make-package-int name nicknames use)) gcl-2.7.1/lsp/PaxHeaders/gcl_rm.lsp0000644000000000000000000000013114774225145014137 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_rm.lsp0000644000175000017500000000257714774225145013551 0ustar00cammcamm(in-package :si) (defun eval-feature (x) (cond ((atom x) (member x *features*)) ((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.) (*package* (load-time-value (find-package 'keyword)))) (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.) (*package* (load-time-value (find-package 'keyword)))) (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.7.1/lsp/PaxHeaders/gcl_typeof.lsp0000644000000000000000000000013114774225145015027 xustar0030 mtime=1743858277.049814274 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_typeof.lsp0000644000175000017500000001376514774225145014442 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defconstant +vtps+ (mapcar (lambda (x) (list x (intern (string-concatenate "VECTOR-" (string x))))) +array-types+)) (defconstant +atps+ (mapcar (lambda (x) (list x (intern (string-concatenate "ARRAY-" (string x))))) +array-types+)) (defconstant +vtpsn+ `((nil vector-nil) ,@+vtps+)) (defconstant +atpsn+ `((nil array-nil) ,@+atps+)) (defun real-rep (x) (case x (integer 1) (ratio 1/2) (short-float 1.0s0) (long-float 1.0))) (defun complex-rep (x) (let* ((s (symbolp x)) (r (real-rep (if s x (car x)))) (i (real-rep (if s x (cadr x))))) (complex r i))) (defun make-string-output-stream (&key (element-type 'character)) (declare (optimize (safety 1))(ignore element-type)) (make-string-output-stream-int)) (defconstant +r+ `(,@(when (plusp most-positive-immfix) `((immfix 1))) (bfix most-positive-fixnum) (bignum (1+ most-positive-fixnum)) (ratio 1/2) (short-float 1.0s0) (long-float 1.0) ,@(mapcar (lambda (x &aux (v (complex-rep (car x)))) `(,(cadr x) ,v)) +ctps+) (standard-char #\a) (non-standard-base-char #\Return) (structure (make-dummy-structure)) (std-instance (set-d-tt 1 (make-dummy-structure))) (funcallable-std-instance (set-d-tt 1 (lambda nil nil))) (non-logical-pathname (init-pathname nil nil nil nil nil nil "")) (logical-pathname (set-d-tt 1 (init-pathname nil nil nil nil nil nil ""))) (hash-table-eq (make-hash-table :test 'eq)) (hash-table-eql (make-hash-table :test 'eql)) (hash-table-equal (make-hash-table :test 'equal)) (hash-table-equalp (make-hash-table :test 'equalp)) (package *package*) (file-input-stream (let ((s (open-int "/dev/null" :input 'character nil nil nil nil :default))) (close s) s)) (file-output-stream (let ((s (open-int "/dev/null" :output 'character nil nil nil nil :default))) (close s) s)) (file-io-stream (let ((s (open-int "/dev/null" :io 'character nil nil nil nil :default))) (close s) s)) (file-probe-stream (let ((s (open-int "/dev/null" :probe 'character nil nil nil nil :default))) (close s) s)) (file-synonym-stream (let* ((*standard-output* (open-int "/dev/null" :output 'character nil nil nil nil :default))) (close *standard-output*) (make-synonym-stream '*standard-output*))) (non-file-synonym-stream *debug-io*);FIXME (broadcast-stream (make-broadcast-stream)) (concatenated-stream (make-concatenated-stream)) (two-way-stream *terminal-io*) (echo-stream (make-echo-stream *standard-output* *standard-output*)) (string-input-stream (make-string-input-stream-int (make-vector 'character 0 t 0 nil 0 nil nil) 0 0)) (string-output-stream (make-string-output-stream));FIXME user defined, socket (random-state (make-random-state)) (readtable (standard-readtable)) (non-standard-object-compiled-function (function eq)) (interpreted-function (set-d-tt 2 (lambda nil nil))) ,@(mapcar (lambda (x) `((simple-array ,(car x) 1) (make-vector ',(car x) 1 nil nil nil 0 nil nil))) +vtps+) ,@(mapcar (lambda (x) `((matrix ,(car x)) (make-array1 ',(car x) nil nil nil 0 '(1 1) t))) +atps+) ((non-simple-array character) (make-vector 'character 1 t nil nil 0 nil nil)) ((non-simple-array bit) (make-vector 'bit 1 t nil nil 0 nil nil)) ((non-simple-array t) (make-vector 't 1 t nil nil 0 nil nil)) ((vector nil) (set-d-tt 16 (make-vector 't 1 t nil nil 0 nil nil)));FIXME ((matrix nil) (set-d-tt 16 (make-array1 't nil nil nil 0 '(1 1) t)));FIXME (spice (alloc-spice)) (cons '(1)) (keyword :a) (null nil) (true t) (gsym 'a))) (defconstant +tfns1+ '(tp0 tp1 tp2 tp3 tp4 tp5 tp6 tp7 tp8)) (defconstant +tfnsx+ '#.(let ((x (lreduce (lambda (y x) (if (> (cadr x) (cadr y)) x y)) (mapcar (lambda (x &aux (z (lremove-duplicates (mapcar (lambda (q) (funcall x (eval (cadr q)))) +r+)))) (list x (length z) (lreduce 'min z) (lreduce 'max z))) +tfns1+) :initial-value (list nil 0)))) (unless (eql (cadr x) (length +r+)) (print (list "type-of functions too general" x (length +r+)))) x)) (defconstant +type-of-dispatch+ (make-vector t #.(1+ (- (cadddr +tfnsx+) (caddr +tfnsx+))) nil nil nil 0 nil nil)) (defmacro tp7-ind (x) `(- (#.(car +tfnsx+) ,x) #.(caddr +tfnsx+))) (defun array-type-of (array-tp array) (list array-tp (nth (c-array-elttype array) +array-types+) (array-dimensions array))) (defun simple-array-type-of (array) (array-type-of 'simple-array array)) (defun non-simple-array-type-of (array) (array-type-of 'non-simple-array array)) (defun integer-type-of (x) `(integer ,x ,x)) (defun ratio-type-of (x) `(ratio ,x ,x)) (defun short-float-type-of (x) `(short-float ,x ,x)) (defun long-float-type-of (x) `(long-float ,x ,x)) (defun complex-type-of (cmp) (declare (complex cmp));FIXME `(complex* ,(type-of (realpart cmp)) ,(type-of (imagpart cmp)))) (defun structure-type-of (str) (sdata-name (c-structure-def str))) (defun valid-class-name (class &aux (name (si-class-name class))) (when (eq class (si-find-class name nil)) name)) (setf (get 'valid-class-name 'cmp-inline) t) (defun std-object-type-of (x) (let* ((c (si-class-of x))) (or (valid-class-name c) c))) (defun cons-type-of (x);recurse? (if (improper-consp x) 'improper-cons 'proper-cons)) (mapc (lambda (x) (setf (aref +type-of-dispatch+ (tp7-ind (eval (cadr x)))) (let* ((x (car x))(x (if (listp x) (car x) x))) (case x ((immfix bfix bignum) #'integer-type-of) (#.(mapcar 'cadr +ctps+) #'complex-type-of) ((structure simple-array non-simple-array cons ratio short-float long-float) (symbol-function (intern (string-concatenate (string x) "-TYPE-OF")))) (matrix #'simple-array-type-of) ((std-instance funcallable-std-instance) #'std-object-type-of) (otherwise x))))) +r+) (defun type-of (x &aux (z (aref +type-of-dispatch+ (tp7-ind x)))) (if (functionp z) (values (funcall z x)) z)) gcl-2.7.1/lsp/PaxHeaders/gcl_merge_pathnames.lsp0000644000000000000000000000013114774225145016660 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_merge_pathnames.lsp0000644000175000017500000000175514774225145016267 0ustar00cammcamm(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.7.1/lsp/PaxHeaders/gcl_subtypep.lsp0000644000000000000000000000013114774225145015374 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_subtypep.lsp0000644000175000017500000005467014774225145015007 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (let (fso (h (make-hash-table :test 'eq))) (defun funcallable-class-p (x) (multiple-value-bind (r f) (gethash x h) (if f r (let ((y (si-cpl-or-nil x))) (when y (setf (gethash x h) (member (or fso (setq fso (si-find-class (find-symbol "FUNCALLABLE-STANDARD-OBJECT" "PCL") nil))) y)))))))) (defun normalize-instance (c) (cond ((funcallable-class-p c) `(funcallable-std-instance ,c)) ((member-if 'funcallable-class-p (si-subclasses c)) `(or (std-instance ,c) (funcallable-std-instance ,c))) (`(std-instance ,c)))) (defun just-expand-deftype (type &aux tem (atp (listp type)) (ctp (if atp (car type) type))) (cond ((setq tem (when (symbolp ctp) (macro-function (get ctp 'deftype-definition)))) (funcall tem (if atp type (list type)) nil)) ((setq tem (coerce-to-standard-class ctp)) (normalize-instance tem));FIXME don't want to normalize a nil type, redundant code ((si-classp ctp) (si-class-name ctp));built-in ((setq tem (get ctp 's-data)) (or (sdata-type tem) `(structure ,ctp))) (t (warn 'warning :format-control "Expanding unknown type ~s to nil:" :format-arguments (list type)) nil))) (defun expand-deftype (type &aux (e (just-expand-deftype type))) (unless (eq type e) e)) (eval-when (compile eval load) (defvar *array-types* (cons (cons nil 'array-nil) +array-type-alist+)) (defvar *simple-array-types* (mapcar (lambda (x) (cons x (intern (string-concatenate "SIMPLE-ARRAY-" (string x))))) (cons nil +array-types+))) (defvar *non-simple-array-types* (mapcan (lambda (x) (when (member x '(character bit t));FIXME (list (cons x (intern (string-concatenate "NON-SIMPLE-ARRAY-" (string x))))))) (cons nil +array-types+))) (defvar *all-array-types* (append *simple-array-types* *non-simple-array-types*)) (defconstant +atps+ (mapcar (lambda (x) (list x (intern (string-concatenate "ARRAY-" (string x))))) +array-types+));FIXME (defconstant +k-ops+ `((integer int^ int~ urng-recon) (ratio rng^ rng~ urng-recon) ((short-float long-float) urng^ urng~ urng-recon) (complex-integer cmpi^ cmpi~ cmp-recon) (complex-integer-ratio cmpir^ cmpir~ cmp-recon) (complex-ratio-integer cmpri^ cmpri~ cmp-recon) (complex-ratio cmpr^ cmpr~ cmp-recon) ((complex-short-float complex-long-float) cmp^ cmp~ cmp-recon) ((std-instance structure funcallable-std-instance) std^ std~ std-recon) ((proper-cons improper-cons) cns^ cns~ cns-recon) (,(mapcar 'cdr *all-array-types*) ar^ ar~ ar-recon) (,+singleton-types+ sing^ sing~ sing-recon))) (defconstant +k-len+ (lreduce (lambda (xx x &aux (x (car x))) (+ (if (listp x) (length x) 1) xx)) +k-ops+ :initial-value 0))) (defmacro negate (lst) (let ((l (gensym))) `(let ((,l ,lst)) (cond ((not ,l)) ((eq ,l t) nil) ((and (consp ,l) (eq (car ,l) 'not)) (cadr ,l)) (`(not ,,l)))))) ;;; ARRAY (defun rnki (x) (when (listp x) (when (eq (car x) 'rank) (cdr x)))) (defun rd^ (x y) (cond ((eql x y) x);eq ((atom x) (when (listp y) (unless (member x y) x)));memq ((atom y) (rd^ y x)) ((union x y))));test (defun dim^ (x y) (cond ((eq x '*) y) ((eq y '*) x) ((rd^ x y)))) (defun dims^ (x y) (cond ((and x y) (let* ((a (dim^ (car x) (car y))) (d (when a (dims^ (cdr x) (cdr y))))) (when d (list (cons a (car d)))))) ((or x y) nil) ((list nil)))) (defun adims (x) (cond ((arrayp x) (array-dimensions x)) ((when (listp x) (arrayp (car x))) (array-dimensions (car x))) (x))) (defun ar^ (x y &aux (rx (rnki x))(ry (rnki y))(ax (adims x))(ay (adims y))) (cond ((and rx ry) (let ((d (rd^ rx ry))) (when d (cons 'rank d)))) (rx (when (rd^ rx (length (adims y))) y)) (ry (ar^ y x)) ((and (eq x ax) (eq y ay)) (car (dims^ x y))) ((eq x ax) (when (ar^ x ay) y)) ((eq y ay) (ar^ y x)) ((ar^ ax ay) (rd^ x y)))) (defun disu (x) (when x (let* ((cx (pop x))(cx (if (atom cx) (list cx) cx))) (mapcan (lambda (y) (mapcar (lambda (x) (cons x y)) cx)) (if x (disu x) (list x)))))) (defun ar-recon (x &optional (s (rassoc (car x) *simple-array-types*)) (tp (car (rassoc (pop x) *all-array-types*)) tpp) &aux (ax (adims x))(ar (if s 'simple-array 'non-simple-array))) (cond ((not tpp) (?or (mapcar (lambda (z) (ar-recon z s tp)) x))) ((eq x t) `(,ar ,tp *));'* ((consp (rnki x)) `(and ,(ar-recon t s tp) (not ,(?or (mapcar (lambda (x) (ar-recon (cons 'rank x) s tp)) (rnki x)))))) ((rnki x) `(,ar ,tp ,(rnki x))) ((when (eq x ax) (member-if 'listp x)) `(and ,(ar-recon (mapcar (lambda (x) (if (atom x) x '*)) x) s tp) (not ,(?or (mapcar (lambda (x) (ar-recon x s tp)) (disu x)))))) ((eq ax x) `(,ar ,tp ,x)) ((consp x) `(and ,(ar-recon ax s tp) (not (member ,@x)))) (`(member ,x)))) (defun onot (x) (when x (let ((d (mapcar (lambda (y) (cons (car x) y)) (onot (cdr x))))) (if (eq (car x) '*) d (cons (cons (list (car x)) (make-list (length (cdr x)) :initial-element '*)) d))))) (defun ar~ (x &aux (ax (adims x))) (cond ((consp (rnki x)) (mapcar (lambda (x) (cons 'rank x)) (rnki x))) ((rnki x) `((rank ,(rnki x)))) ((when (eq x ax) (member-if 'listp x)) (nconc (ar~ (substitute-if '* 'listp x)) (disu x))) ((eq x ax) (nconc (ar~ (cons 'rank (length x))) (onot x))) ((listp x) (nconc (ar~ (array-dimensions (car x))) x));FIXME ((nconc (ar~ (array-dimensions x)) `((,x)))))) (defun ar-ld (type &aux (s (eq (car type) 'simple-array))) `(,(cdr (assoc (cadr type) (if s *simple-array-types* *non-simple-array-types*))) ,(let ((x (caddr type))) (cond ((eq x '*) t) ((integerp x) (cons 'rank x));FIXME (x))))) ;;; SINGETON (defun sing^ (x y) (rd^ y x)) (defun sing~ (x) (cond ((listp x) x) ((list (list x))))) (defun sing-ld (type) (cons (car type) '(t))) (defun sing-recon (x &aux (c (pop x))) (cond ((eq (car x) t) (case c (null `(member nil)) (true `(member t)) (otherwise c)));FIXME ((listp (car x)) `(and ,c (not (member ,@(car x))))) (`(member ,@x)))) ;;; INTEGER (defun intcmp (x y f) (cond ((eq x '*) y)((eq y '*) x)((funcall f x y) y)(x))) (defun icons (a d) (when (or (eq a '*) (eq d '*) (<= a d)) (if (and (eq a '*) (eq d '*)) t (cons a d)))) (defun int^ (x y) (icons (intcmp (car x) (car y) '<) (intcmp (cdr x) (cdr y) '>))) (defun int~ (x) (cond ((eq (car x) '*) (list (cons (1+ (cdr x)) '*))) ((eq (cdr x) '*) (list (cons '* (1- (car x))))) ((nconc (int~ (cons (car x) '*)) (int~ (cons '* (cdr x))))))) ;;; RANGES (defun range-cons (range &aux (a (pop range))(a (or (eq a 'unordered) a))(d (car range))) (if (and (eq '* a) (eq '* d)) t (cons a d))) (defun rngnum (x) (if (listp x) (car x) x)) (defun rngcmp (x y f &aux (nx (rngnum x))(ny (rngnum y))) (cond ((eq x '*) y)((eq y '*) x) ((funcall f nx ny) y)((funcall f ny nx) x) ((eq y ny) x)(y))) (defun ncons (a d &aux (na (rngnum a))(nd (rngnum d))) (when (or (eq a '*) (eq d '*) (< na nd) (and (eql a d) (eql na nd) (eql a na))) (cons a d))) (defun rng^ (x y) (ncons (rngcmp (car x) (car y) '<) (rngcmp (cdr x) (cdr y) '>))) (defun unord^ (x y &aux (cx (car x))(cy (car y)) (z (if (eq cx t) cy (if (eq cy t) cx (rd^ cx cy))))) (when z (list z))) (defun urng^ (x y) (cond ((and (cdr x) (cdr y)) (rng^ x y)) ((and (null (cdr x)) (null (cdr y))) (unord^ x y)))) (defun rngi (x) (if (listp x) (if (integerp (car x)) x (car x)) (list x))) (defun rng~ (x) (cond ((eq (car x) '*) (list (cons (rngi (cdr x)) '*))) ((eq (cdr x) '*) (list (cons '* (rngi (car x))))) ((nconc (rng~ (cons (car x) '*)) (rng~ (cons '* (cdr x))))))) (defun unord~ (x &aux (cx (car x))) (unless (eq cx t) (if (listp cx) (mapcar (lambda (x) (list x)) cx) (list (list x))))) (defun urng~ (x) (cond ((null (cdr x)) (nconc (unord~ x) (list (cons '* '*)))) ((and (eq (car x) '*) (eq (cdr x) '*)) (list (cons t nil))) ((nconc (list (cons t nil)) (rng~ x))))) (defun rng-ld (type) (list (pop type) (range-cons type))) (defun urng-recon (x &aux (c (pop x))) (if (eq (car x) t) (list c '* '*) (?or (mapcar (lambda (x &aux (o (list c (car x) (cdr x)))) (cond ((and (eq (car x) '*) (eq (cdr x) '*)) `(and ,o (not (,c unordered)))) ((cdr x) o) ((listp (car x)) `(and (,c unordered) (not (member ,@(car x))))) ((eq (car x) t) `(,c unordered)) (`(member ,(car x))))) x)))) ;;; COMPLEX (defun sking (tp &aux (tp (nprocess-type tp))) (unless (or (cadr tp) (caddr tp) (cdar tp)) (caar tp))) (defun lookup-cmp-k (rk ik) (cadr (assoc (if (eq rk ik) rk (list rk ik)) +ctps+ :test 'equal))) (defun cmp-k (x y) (lookup-cmp-k (car (sking x)) (car (sking y)))) (defun cmp-ld (type &aux (r (sking (cadr type)))(rk (pop r)) (i (sking (or (caddr type) (cadr type))))(ik (pop i))) (let ((k (lookup-cmp-k rk ik))) (when k `(,k ,(if (and (eq (car r) t) (eq (car i) t)) t (cons r i)))))) (defun irange (x) (if (isnan x) (list x) (cons x x))) (defun cmp-irange (x &aux (r (realpart x))(i (imagpart x))) `((,(irange r)) . (,(irange i)))) (defun rng-ip (x) (unless (cdr x) (when (consp (car x)) (when (realp (caar x)) (eql (caar x) (cdar x)))))) (defun cmp-cons (a d) (when (and a d) (if (and (rng-ip a) (rng-ip d)) (list (complex (caar a) (caar d))) (list (cons a d))))) (defun cmpg~ (kr ki x) (cond ((consp x) (let ((a (kop-not kr (car x))) (d (kop-not ki (cdr x)))) (nconc (cmp-cons a (cdr x)) (cmp-cons (car x) d) (cmp-cons a d)))) ((cmpg~ kr ki (cmp-irange x))))) (defun cmpi~ (x) (cmpg~ 'integer 'integer x)) (defun cmpir~ (x) (cmpg~ 'integer 'ratio x)) (defun cmpri~ (x) (cmpg~ 'ratio 'integer x)) (defun cmpr~ (x) (cmpg~ 'ratio 'ratio x)) (defun cmp~ (x) (cmpg~ 'long-float 'long-float x)) (defun cmpg^ (kr ki x y) (cond ((and (consp x) (consp y)) (car (cmp-cons (kop-and kr (car x) (car y)) (kop-and ki (cdr x) (cdr y))))) ((consp x) (when (cmpg^ kr ki x (cmp-irange y)) y)) ((consp y) (cmpg^ kr ki y x)) ((rd^ x y)))) (defun cmpi^ (x y) (cmpg^ 'integer 'integer x y)) (defun cmpir^ (x y) (cmpg^ 'integer 'ratio x y)) (defun cmpri^ (x y) (cmpg^ 'ratio 'integer x y)) (defun cmpr^ (x y) (cmpg^ 'ratio 'ratio x y)) (defun cmp^ (x y) (cmpg^ 'long-float 'long-float x y)) (defun cmp-recon (x &optional (c (car (rassoc (pop x) +ctps+ :key 'car)) cp)) (cond ((not cp) (?or (mapcar (lambda (x) (cmp-recon x c)) x))) ((eq x t) (if (consp c) `(complex* (,(pop c) * *) (,(car c) * *)) `(complex (,c * *)))) ((consp x) (let* ((rx (k-recon (cons (if (consp c) (pop c) c) (car x)))) (ry (k-recon (cons (if (consp c) (car c) c) (cdr x))))) (if (equal rx ry) `(complex ,rx) `(complex* ,rx ,ry)))) (`(member ,x)))) ;;; CONS (defun cns-list (a d &optional m n &aux (mn (or m n))) (when (and (or (car a) (cadr a) (unless a mn)) (or (car d) (cadr d) (unless d mn))) (if (and (unless (car a) (cadr a)) (unless (car d) (cadr d))); (not m) (not n) `(t) `((,a ,d ,m ,n))))) (defun cns-and (x y) (if (and x y) (ntp-and x y) (or x y))) ;(defun cns-type (a d) `(cons ,(fourth a) ,(fourth d))) (defun cns-type (a d) `(cons ,(nreconstruct-type-int a) ,(nreconstruct-type-int d)));FIXME separage car cdr (defun cns-match (a d &rest r &aux (tp (when a (cns-type a d)))) (if tp (lremove-if-not (lambda (x) (typep x tp)) r) r)) (defun cns^ (x y) (let* ((a (cns-and (car x) (car y)))(d (cns-and (cadr x) (cadr y))) (mx (caddr x))(nx (cadddr x))(my (caddr y))(ny (cadddr y))) (cond (mx (cond (my (when (eql mx my) x)) ((member mx ny) nil) ((when a (not (typep mx (cns-type a d)))) nil) (x))) (my (cns^ y x)) (nx (car (cns-list a d nil (apply 'cns-match a d (union nx ny))))) (ny (cns^ y x)) ((car (cns-list a d)))))) (defun cns~ (x) (cond ((let ((a (when (car x) (ntp-not (car x)))) (d (when (cadr x) (ntp-not (cadr x))))) (nconc (cns-list a (cadr x)) (cns-list (car x) d) (cns-list a d) (when (caddr x) (cns-list (car x) (cadr x) nil (list (caddr x)))) (mapcan (lambda (y) (cns-list nil nil y)) (cadddr x))))))) (defconstant +tp-nil+ `(nil nil nil)) (defconstant +tp-t+ `(nil t nil)) (defun mntp (x) (case x ((t) +tp-t+) ((nil) +tp-nil+) (otherwise (if (eq (car x) 'satisfies) (list (list +tp-t+ +tp-nil+ x) nil t) (list (if (consp (car x)) x (list x)) nil nil))))) (defvar *pcnsk* '(proper-cons null)) (defvar *pcns-ntp* (mntp (mapcar (lambda (x) (list x t)) *pcnsk*) )) (defvar *pcns-nntp* (mntp (mapcar (lambda (x) (list x t)) (set-difference (lreduce (lambda (xx x &aux (x (car x))) (if (listp x) (append x xx) (cons x xx))) +k-ops+ :initial-value nil) *pcnsk*)))) (defun pcdr (u type &aux (z (ntp-and u (nprocess-type type)))) (ntp-prune (pop z) (pop z) (car z) (length (car u)))) (defun pcns (u type) (k-mk (pop type) nil (cns-list (nprocess-type (pop type)) (pcdr u (car type))))) (defun cns-ld (type) (pcns (if (eq (car type) 'proper-cons) *pcns-ntp* *pcns-nntp*) type)) (defun cns-recon (x &optional (c (pop x) cp)) (cond ((not cp) (?or (mapcar (lambda (x) (cns-recon x c)) x))) ((eq x t) c) ((caddr x) `(member ,(caddr x))) ((cadddr x) (let ((y `(not (member ,@(cadddr x))))) (if (car x) `(and ,(cns-recon (list (car x) (cadr x)) c) ,y) y))) (x `(,c ,(nreconstruct-type-int (pop x)) ,(nreconstruct-type-int (car x)))))) ;;; STRUCTURE and CLASS (defun gen-def (x) (cond ((or (symbolp x) (si-classp x)) 'top) ((structurep x) (sdata-name (c-structure-def x))) ((si-class-of x)))) (defun std-car (x c) (if (s-class-p x) (list c) (gen-get-included (std-def x)))) (defun orthog-to-and-not (x c) (cond ((eq x t) (list c)) ((listp x) (nconc (std-car (car x) c) x));FIXME ((s-class-p x) (gen-get-included x)) (`((member ,x))))) (defun std-def (x) (gen-def (if (listp x) (car x) x))) (defun s-class-p (x &aux (x (std-def x))) (eq x (std-def x))) (defun std~ (x) (cond ((s-class-p x) (if (listp x) x `((,x)))) ((nconc (std~ (std-def x)) (if (listp x) x `((,x))))))) (defun std^ (x y) (cond ((eq (std-def x) (std-def y)) (rd^ x y)) ((s-class-p x) (when (std^ x (std-def y)) y)) ((s-class-p y) (std^ y x)))) (defun si-subclasses (c) (when c (cons c (lreduce (lambda (y x) (lreduce (lambda (y x) (adjoin x y)) (si-subclasses x) :initial-value y)) (si-class-direct-subclasses c) :initial-value nil)))) (defun gen-get-included (x) (if (symbolp x) (get-included x) (si-subclasses x))) (defun filter-included (c x) (case c (std-instance (lremove-if 'funcallable-class-p x)) (funcallable-std-instance (lremove-if-not 'funcallable-class-p x)) (otherwise x))) (defun std-ld (x &aux (c (pop x))) (cons c (if x (filter-included c (gen-get-included (car x))) '(t)))) (defun std-matches (x) (lremove-if-not (lambda (y) (member (car y) x :test 'member :key 'cdr)) x)) (defun std-recon (x &optional (c (pop x)) &aux (x (mapcar (lambda (x) (orthog-to-and-not x c)) x)) (m (std-matches x))) (?or (mapcar (lambda (x &aux (h (pop x))) (if x `(and ,h (not ,(std-recon x c))) h)) (mapcar (lambda (x) (lreduce (lambda (y x &aux (m (member x m :key 'car))) (nconc y (if m (lremove-if 's-class-p (car m)) (list x)))) x :initial-value nil)) (set-difference x m))))) ;;; INDIVIDUALS (defun kktype-of (x) (cond ((atom x) (cond ((coerce-to-standard-class x) 'std-instance) ((when (symbolp x) (get x 's-data)) 'structure)(x)));FIXME ((eq (car x) 'simple-array) (cdr (assoc (cadr x) *simple-array-types*))) ((eq (car x) 'non-simple-array) (cdr (assoc (cadr x) *non-simple-array-types*))) ((member (car x) '(complex complex*)) (cmp-k (cadr x) (or (caddr x) (cadr x)))) ((car x)))) (defun ktype-of (x) (or (kktype-of (type-of x)) (error "unknown type"))) (defun cons-to-cns-list (x) (cns-list nil nil x)) (defun mcns-ld (c x) (cons c (cons-to-cns-list x))) #.`(defun kmem (x &aux (z (ktype-of x))) (case z ((proper-cons improper-cons) (mcns-ld z x)) (,+range-types+ `(,z (,x . ,(unless (isnan x) x)))) (null `(,z t)) (otherwise `(,z ,x)))) (defun member-ld (type) (car (ntp-not (lreduce (lambda (y x) (ntp-and y (ntp-not (mntp (list (kmem x)))))) (cdr type) :initial-value +tp-t+)))) #.`(defun k^ (k x y) (case k ,@(mapcar (lambda (x) `(,(car x) (,(cadr x) x y))) (butlast +k-ops+)) (otherwise (,(cadr (car (last +k-ops+))) x y)))) (defun kop-and (k x y) (cond ((eq (car x) t) y) ((eq (car y) t) x) ((lreduce (lambda (xx x) (lreduce (lambda (yy y) (?cns (k^ k x y) yy)) y :initial-value xx)) x :initial-value nil)))) #.`(defun k~ (k x) (unless (eq x t) (case k ,@(mapcar (lambda (x) `(,(car x) (,(caddr x) x))) (butlast +k-ops+)) (otherwise (,(caddr (car (last +k-ops+))) x))))) (defun kop-not (k x) (lreduce (lambda (xx x) (when xx (kop-and k (k~ k x) xx))) x :initial-value '(t))) (defun kop-or (k x y) (kop-not k (kop-not k (append x y)))) (defun k-mk (k d x) (unless (eq d (car x)) (cons k x))) (defun k-op (op x y d &aux (k (car x))) (k-mk k d (case op (and (kop-and k (cdr x) (cdr y))) (or (kop-or k (cdr x) (cdr y))) (not (kop-not k (cdr x)))))) (defun ntp-prune (x y z &rest u) (cond ((not (or x z u)) (if y +tp-t+ +tp-nil+)) ((unless (member (not y) x :test-not 'eq :key 'cadr);FIXME? shortest of list and complement? (eql (length x) (or (car u) +k-len+))) (apply 'ntp-prune nil (not y) z u)) ((list* x y z u)))) (defun ?cns (x y) (if x (cons x y) y)) (defun ntp-not (x &aux (l (pop x)) (d (not (pop x))) (u (pop x))) (if u (list (list (ntp-not (cadr l)) (ntp-not (car l)) `(not ,(caddr l))) nil u) (apply 'ntp-prune (lreduce (lambda (ll l) (?cns (k-op 'not l nil d) ll)) l :initial-value nil) d u x))) (defun ntp-list (op lx ly d dx dy) (lreduce (lambda (ll l &aux (ny (assoc (car l) ly))) (?cns (cond (ny (k-op op l ny d)) (dy l)) ll)) lx :initial-value (when dx (lreduce (lambda (ll l) (?cns (unless (assoc (car l) lx) l) ll)) ly :initial-value nil)))) (defun ntp-subtp (x y) (ntp-and?c2-nil-p x y t)) (defun ntp-and-unknown (ox lx ux oy ly uy d) (let* ((xx (if ux (pop lx) ox))(xy (if uy (pop ly) oy))(x (ntp-and xx xy)) (mx (if ux (pop lx) ox))(my (if uy (pop ly) oy))(m (ntp-and mx my))) (cond ((ntp-subtp x m) x) ((unless ux (ntp-subtp xy xx)) oy) ((unless uy (ntp-subtp xx xy)) ox) ((list (list x m `(and ,(if ux (car lx) (car (nreconstruct-type ox))) ,(if uy (car ly) (car (nreconstruct-type oy))))) d t))))) (defun ntp-or-unknown (ox lx ux oy ly uy d) (let* ((xx (if ux (pop lx) ox))(xy (if uy (pop ly) oy))(x (ntp-or xx xy)) (mx (if ux (pop lx) ox))(my (if uy (pop ly) oy))(m (ntp-or mx my))) (cond ((ntp-subtp x m) x) ((unless ux (ntp-subtp mx my)) oy) ((unless uy (ntp-subtp my mx)) ox) ((list (list x m `(or ,(if ux (car lx) (car (nreconstruct-type ox))) ,(if uy (car ly) (car (nreconstruct-type oy))))) d t))))) (defun ntp-and?c2-nil-p (x y ?c2) (let* ((x (if (caddr x) (caar x) x))(y (if (caddr y) (if ?c2 (cadar y) (caar y)) y)) (lx (pop x))(ly (pop y))(dx (pop x))(dy (pop y))(dy (if ?c2 (not dy) dy))(i 0)(d (and dx dy)) (lk (or (car x) +k-len+))) (not (or (when dx (member-if-not (lambda (x) (or (eq (cadr x) ?c2) (assoc (car x) lx))) ly)) (member-if (lambda (x &aux (y (assoc (car x) ly))) (cadr (cond (y (k-op 'and x (if ?c2 (k-op 'not y nil d) y) d));FIXME remove last consing from this (dy (incf i) x)))) lx) (when d (not (eql lk (+ i (length ly))))))))) (defun ntp-and (&rest xy) (when xy (let* ((x (car xy)) (y (cadr xy)) (ox x)(oy y)(lx (pop x))(ly (pop y))(dx (pop x))(dy (pop y)) (d (and dx dy))(ux (pop x))(uy (pop y))) (cond ((or ux uy) (ntp-and-unknown ox lx ux oy ly uy d)) ((not lx) (if dx oy ox)) ((not ly) (if dy ox oy)) ((apply 'ntp-prune (ntp-list 'and lx ly d dx dy) d nil x)))))) (defun ntp-or (&rest xy) (when xy (let* ((x (car xy)) (y (cadr xy)) (ox x)(oy y)(lx (pop x))(ly (pop y))(dx (pop x))(dy (pop y)) (d (or dx dy))(ux (pop x))(uy (pop y))) (cond ((or ux uy) (ntp-or-unknown ox lx ux oy ly uy d)) ((not (or (car x) lx)) (if dx ox oy)) ((not (or (car y) ly)) (if dy oy ox)) ((apply 'ntp-prune (ntp-list 'or lx ly d (not dx) (not dy)) d nil x)))))) (defconstant +ntypes+ `(,@+singleton-types+ std-instance structure funcallable-std-instance t nil)) (defconstant +dtypes+ '(or and not member satisfies integer ratio short-float long-float complex* simple-array non-simple-array proper-cons improper-cons)) (defun normalize-type (type &aux e (type (if (listp type) type (list type)));FIXME (ctp (car type))) (cond ((eq ctp 'structure-object) `(structure));FIXME ((member ctp +ntypes+) type) ((member ctp +dtypes+) (funcall (macro-function (get ctp 'deftype-definition)) type nil));FIXME ((eq type (setq e (just-expand-deftype type))) type) ((normalize-type e)))) #.`(defun ntp-load (type) (mntp (ecase (car type) ((t nil) (car type)) (,+range-types+ (rng-ld type)) (complex* (cmp-ld type)) ((cons proper-cons improper-cons) (cns-ld type)) ((std-instance structure funcallable-std-instance) (std-ld type)) ((simple-array non-simple-array) (ar-ld type)) (,+singleton-types+ (sing-ld type)) (member (member-ld type)) (satisfies type)))) (defun nprocess-type (type) (case (car type) (and (lreduce 'ntp-and (mapcar 'nprocess-type (cdr type)))) (or (lreduce 'ntp-or (mapcar 'nprocess-type (cdr type)))) (not (ntp-not (nprocess-type (cadr type)))) (otherwise (ntp-load type)))) #.`(defun k-recon (x) (case (car x) ,@(mapcar (lambda (x) `(,(car x) (,(cadddr x) x))) (butlast +k-ops+)) (otherwise (,(cadddr (car (last +k-ops+))) x)))) (defun nreconstruct-type-int (x) (cond ((caddr x) (caddr (car x))) ((cadr x) (let* ((x (ntp-not x))) (let ((z (nreconstruct-type-int x))) (or (not z) `(not ,z))))) ((?or (mapcar 'k-recon (car x)))))) (defun nreconstruct-type (x) (list (nreconstruct-type-int x) (caddr x))) (defun resolve-type (type) (nreconstruct-type (nprocess-type (normalize-type type)))) (defun subtypep (t1 t2 &optional env) (declare (ignore env) (optimize (safety 1))) (check-type t1 full-type-spec) (check-type t2 full-type-spec) (if (or (not t1) (eq t2 t)) (values t t) (let* ((n1 (nprocess-type (normalize-type t1))) (n2 (nprocess-type (normalize-type t2)))) (values (ntp-subtp n1 n2) (not (or (caddr n1) (caddr n2))))))) gcl-2.7.1/lsp/PaxHeaders/gcl_numlib.lsp0000644000000000000000000000013114774225145015007 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.356938455 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_numlib.lsp0000644000175000017500000002202414774225145014406 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :system) (defun powm (a b c) (declare (optimize (safety 1))) (check-type a integer) (check-type b (integer 0)) (check-type c (integer 0)) (if (typep b 'fixnum) (gmp:mpz_powm_ui a b c) (gmp:mpz_powm a b c))) (declaim (inline powm)) (defconstant imag-one #C(0.0d0 1.0d0)) (defun isqrt (i) (declare (optimize (safety 1))) (check-type i (integer 0)) (typecase i (fixnum (do* ((y 0 (floor i x)) (x (ash 1 (ceiling (integer-length i) 2)) (+ (ash x -1) (ash y -1) (logand x y 1)))) ((<= x y) x))) (otherwise (mpz_sqrt i)))) (deftype bytespec nil `(cons (integer 0) (integer 0))) (defun byte (size position) (declare (optimize (safety 1))) (check-type size (integer 0)) (check-type position (integer 0)) (cons size position)) (defun byte-position (bytespec) (declare (optimize (safety 1))) (check-type bytespec cons) (cdr bytespec)) (defun byte-size (bytespec) (declare (optimize (safety 1))) (check-type bytespec cons) (car bytespec)) (defun ldb (bytespec integer) (declare (optimize (safety 1))) (check-type bytespec bytespec) (check-type integer integer) (logand (ash integer (- (byte-position bytespec))) (1- (ash 1 (byte-size bytespec))))) (defun ldb-test (bytespec integer) (declare (optimize (safety 1))) (check-type bytespec bytespec) (check-type integer integer) (not (zerop (ldb bytespec integer)))) (defun dpb (newbyte bytespec integer &aux (z (1- (ash 1 (byte-size bytespec))))) (declare (optimize (safety 1))) (check-type newbyte integer) (check-type bytespec bytespec) (check-type integer integer) (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)))) (declare (optimize (safety 1))) (check-type newbyte integer) (check-type bytespec bytespec) (check-type integer integer) (logior (logandc2 integer z) (logand newbyte z))) (defun mask-field (bytespec integer) (declare (optimize (safety 1))) (check-type bytespec bytespec) (check-type integer integer) (logand integer (ash (1- (ash 1 (byte-size bytespec))) (byte-position bytespec)))) (defun phase (x) (declare (optimize (safety 1))) (check-type x number) (if (= 0 x) 0.0 (atan (imagpart x) (realpart x)))) (defun signum (x) (declare (optimize (safety 1))) (check-type x number) (if (zerop x) x (typecase x (rational (if (minusp x) -1 1)) (short-float (if (minusp x) -1.0s0 1.0s0)) (long-float (if (minusp x) -1.0 1.0)) (fcomplex (/ x (abs x))) (dcomplex (/ x (abs x))) (complex (let* ((y (max (abs (realpart x)) (abs (imagpart x)))) (z (complex (/ (realpart x) y) (/ (imagpart x) y)))) (/ z (abs z))))))) (defun cis (x) (declare (optimize (safety 1))) (check-type x real) (exp (* #c(0 1) (float x)))) (defun ffloor (x &optional (y 1.0s0)) (declare (optimize (safety 1))) (check-type x real) (check-type y real) (multiple-value-bind (i r) (floor x y) (values (float i (if (floatp x) x 1.0)) r))) (defun fceiling (x &optional (y 1.0s0)) (declare (optimize (safety 1))) (check-type x real) (check-type y real) (multiple-value-bind (i r) (ceiling x y) (values (float i (if (floatp x) x 1.0)) r))) (defun ftruncate (x &optional (y 1.0s0)) (declare (optimize (safety 1))) (check-type x real) (check-type y real) (multiple-value-bind (i r) (truncate x y) (values (float i (if (floatp x) x 1.0)) r))) (defun fround (x &optional (y 1.0s0)) (declare (optimize (safety 1))) (check-type x real) (check-type y real) (multiple-value-bind (i r) (round x y) (values (float i (if (floatp x) x 1.0)) r))) (defun logtest (x y) (declare (optimize (safety 1))) (check-type x integer) (check-type y integer) (not (zerop (logand x y)))) (defconstant +make-complex-alist+ `((complex-integer #tinteger #tinteger) (complex-integer-ratio #tinteger #tratio) (complex-ratio-integer #tratio #tinteger) (complex-ratio #tratio #tratio) (complex-short-float #tshort-float #tshort-float) (complex-long-float #tlong-float #tlong-float))) (eval-when (compile eval) (defmacro complex-tt (s) (or (position s +make-complex-alist+ :key 'car) (baboon)))) (defun complex (rp &optional (ip (typecase rp (rational 0)(short-float 0.0s0)(long-float 0.0)))) (declare (optimize (safety 1))) (check-type rp real) (check-type ip real) (typecase rp (integer (typecase ip ((integer 0 0) rp) (integer (make-complex #.(complex-tt complex-integer) rp ip)) (ratio (make-complex #.(complex-tt complex-integer-ratio) rp ip)) (short-float (make-complex #.(complex-tt complex-short-float) (float rp ip) ip)) (long-float (make-complex #.(complex-tt complex-long-float) (float rp ip) ip)))) (ratio (typecase ip ((integer 0 0) rp) (integer (make-complex #.(complex-tt complex-ratio-integer) rp ip)) (ratio (make-complex #.(complex-tt complex-ratio) rp ip)) (short-float (make-complex #.(complex-tt complex-short-float) (float rp ip) ip)) (long-float (make-complex #.(complex-tt complex-long-float) (float rp ip) ip)))) (short-float (typecase ip (rational (make-complex #.(complex-tt complex-short-float) rp (float ip rp))) (short-float (make-complex #.(complex-tt complex-short-float) rp ip)) (long-float (make-complex #.(complex-tt complex-long-float) (float rp ip) ip)))) (long-float (make-complex #.(complex-tt complex-long-float) rp (float ip rp))))) (defun make-complex-propagator (f t1 t2 t3 &aux (i -1)) (declare (ignore f)) (reduce 'tp-or (mapcan (lambda (x) (when (tp-and t1 (object-tp (incf i))) (list (cmp-norm-tp `(complex* ,(cmp-unnorm-tp (tp-and t2 (cadr x))) ,(cmp-unnorm-tp (tp-and t3 (caddr x)))))))) +make-complex-alist+) :initial-value nil)) (setf (get 'make-complex 'type-propagator) 'make-complex-propagator) (defun float-digits (x) (declare (optimize (safety 1))) (check-type x float);FIXME etypecase (typecase x (short-float 24) (t 53))) (defun float-precision (x) (declare (optimize (safety 1))) (check-type x float);FIXME etypecase (typecase x ((member 0.0 0.0s0) 0) (short-float 24) (t 53))) (defun float-sign (x &optional (y 1.0)) (declare (optimize (safety 1))) (check-type x float) (check-type y float) (let ((y (float (abs y) x))) (if (minusp x) (- y) y))) (defun float-radix (x) (declare (optimize (safety 1))) (check-type x float);FIXME etypecase 2) (defun atomic-tp-propagator (f &rest r); tp &aux (atp (atomic-tp tp))) (declare (dynamic-extent r)) (unless (member-if-not 'atomic-tp r) (let ((l (multiple-value-list (apply f (mapcar (lambda (x) (car (atomic-tp x))) r))))) (if (cdr l) `(returns-exactly ,@(mapcar 'object-tp l)) (object-tp (car l)))))) (dolist (l '(integer-decode-float decode-float scale-float));float-radix float-digits float-precision float-sign (setf (get l 'type-propagator) 'atomic-tp-propagator (get l 'compiler::c1no-side-effects) t)) (declaim (inline fryi)) (defun fryi (x a) (labels ((fryn (x a) (abs (- (* x (denominator a)) (numerator a)))) (fryk (x a b &aux (c (fryn x a))(d (fryn x b)) (kf 0.8);heuristic guard against overshoot (cf (* c kf))(df (* d kf))) (cond ((> cf d 0) (values (truncate (/ cf d)))) ((> df c 0) (values (truncate (/ df c)))) (1))) (med (a b k) (/ (+ (numerator a) (* k (numerator b))) (+ (denominator a) (* k (denominator b))))) (fry (x a b) (cond ((= (float a x) x) a) ((= (float b x) x) b) ((< (med a b 1) x) (fry x (med a b (fryk x a b)) b)) ((fry x a (med b a (fryk x a b))))))) (fry x a (1+ a)))) (defun rationalize (x) (declare (optimize (safety 1))) (check-type x real) (typecase x (rational x) (float (if (isnan x) (rational x) (multiple-value-bind (f r) (truncate x) (cond ((minusp r) (fryi x (1- f))) ((zerop r) f) ((fryi x f)))))))) gcl-2.7.1/lsp/PaxHeaders/gcl_typep.lsp0000644000000000000000000000013114774225145014662 xustar0030 mtime=1743858277.049814274 30 atime=1744340056.376938583 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_typep.lsp0000644000175000017500000002320414774225145014262 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defun ib (o l &optional f) (let* ((a (atom l)) (l (if a l (car l))) (l (unless (eq '* l) l))) (or (not l) (if (eq l 'unordered) (isnan o) (if f (if a (<= l o) (< l o)) (if a (<= o l) (< o l))))))) (setf (get 'ib 'cmp-inline) t) (defun db (o tp) (let* ((b (car tp))(i -1)) (cond ((not tp)) ((eq b '*)) ((not (listp b)) (eql (c-array-rank o) b)) ((eql (length b) (c-array-rank o)) (not (member-if-not (lambda (x) (incf i) (or (eq x '*) (eql x (array-dimension o i)))) b)))))) (defun dbv (o tp) (let* ((b (car tp))(b (if (listp b) (car b) b))) (cond ((not tp)) ((eq b '*)) ((eql (c-array-dim o) b))))) (setf (get 'db 'cmp-inline) t) (setf (get 'dbv 'cmp-inline) t) (defun ibb (o tp) (and (ib o (car tp) t) (ib o (cadr tp)))) (setf (get 'ibb 'cmp-inline) t) (defun sdata-includes (x) (when x (the (or s-data null) (*object (c-structure-self x) 4 nil nil))));FIXME s-data-name boostrap loop (setf (get 'sdata-includes 'cmp-inline) t) (defun sdata-included (x) (when x (the proper-list (*object (c-structure-self x) 3 nil nil))));FIXME s-data-name boostrap loop (setf (get 'sdata-included 'cmp-inline) t) (defun sdata-name (x) (when x (the symbol (*object (c-structure-self x) 0 nil nil))));FIXME s-data-name boostrap loop (defun sdata-type (x) (when x (the symbol (*object (c-structure-self x) 16 nil nil))));FIXME s-data-name boostrap loop (setf (get 'sdata-name 'cmp-inline) t) (defun mss (o sn) (when o (or (eq (sdata-name o) sn) (mss (sdata-includes o) sn)))) (setf (get 'mss 'cmp-inline) t) #.`(defun listp (x) ,(simple-type-case 'x 'list)) (defun valid-class-name (class &aux (name (si-class-name class))) (when (eq class (si-find-class name nil)) name)) (setf (get 'valid-class-name 'cmp-inline) t) (defun lookup-simple-typep-fn (name) (when (symbolp name) (get name 'simple-typep-fn))) (defun lookup-typep-fn (name) (when (symbolp name) (get name 'typep-fn))) (defmacro define-typep-fn (name lambda-list &rest body &aux (q (intern (string-concatenate (string name) "-TYPEP-FN")))) `(progn (defun ,q ,lambda-list ,@body) (setf (get ',name 'typep-fn) ',q (get ',q 'cmp-inline) t))) (define-typep-fn or (o tp) (when tp (or (typep o (pop tp)) (or-typep-fn o tp)))) (define-typep-fn and (o tp) (if tp (and (typep o (pop tp)) (and-typep-fn o tp)) t)) (define-typep-fn not (o tp) (not (when tp (typep o (car tp))))) (defmacro define-compound-typep-fn (name (o tp) &rest body &aux (q (intern (string-concatenate (string name) "-TYPEP-FN")))) `(progn (defun ,q (,o ,tp) (declare (ignorable ,o ,tp)) (when ,(simple-type-case o name) ,@body)) (setf (get ',name 'typep-fn) ',q (get ',q 'cmp-inline) t))) #.`(progn ,@(mapcar (lambda (y) `(define-compound-typep-fn ,y (o tp) (ibb o tp))) (append '(real float rational) +range-types+))) (define-typep-fn unsigned-byte (o tp &aux (s (if tp (car tp) '*))) (typecase o (fixnum (unless (minusp o) (or (eq s '*) (<= (integer-length o) s)))) (integer (unless (minusp o) (or (eq s '*) (<= (integer-length o) s)))))) (define-typep-fn signed-byte (o tp &aux (s (if tp (car tp) '*))) (typecase o (fixnum (or (eq s '*) (< (integer-length o) s))) (integer (or (eq s '*) (< (integer-length o) s))))) #.`(progn ,@(mapcar (lambda (y) `(define-simple-typep-fn ,y)) +singleton-types+)) #.`(progn ,@(mapcan (lambda (x) (mapcar (lambda (y) `(deftype ,(cadr y) (&optional dims) `(,',(car x) ,',(car y) ,dims))) (cdr x))) +array-typep-alist+) ,@(mapcan (lambda (x) (mapcar (lambda (y) `(define-compound-typep-fn ,(cadr y) (o tp) (,(if (eq (car x) 'vector) 'dbv 'db) o tp))) (cdr x))) +array-typep-alist+) ,@(mapcan (lambda (x) `((define-typep-fn ,(car x) (o tp) (when (funcall (cddr (assoc (upgraded-array-element-type (if tp (car tp) '*)) (cdr (assoc ',(car x) +array-typep-alist+)))) o) (,(if (eq (car x) 'vector) 'dbv 'db) o (cdr tp)))))) +array-typep-alist+)) (defun cmp-real-tp (x y) (when (member x +range-types+) (when (member y +range-types+) (if (eq x y) x (ecase x (integer (ecase y (ratio 'integer-ratio))) (ratio (ecase y (integer 'ratio-integer)))))))) (defconstant +complex*-typep-alist+ (mapcar (lambda (x &aux (k (cmp-real-tp (if (listp x) (car x) x) (if (listp x) (cadr x) x))) (q (intern (string-concatenate "COMPLEX*-" (string k))))) (list* x k q (intern (string-concatenate (string q) "-SIMPLE-TYPEP-FN")))) (list* '(integer ratio) '(ratio integer) +range-types+))) #.`(progn ,@(mapcan (lambda (x) `((deftype ,(caddr x) nil ',`(complex* ,(if (listp (car x)) (caar x) (car x)) ,(if (listp (car x)) (cadar x) (car x)))))) +complex*-typep-alist+)) (define-typep-fn complex* (o tp &aux (rtp (if tp (pop tp) '*))(itp (if tp (car tp) rtp)) (rctp (if (listp rtp) (car rtp) rtp))(ictp (if (listp itp) (car itp) itp)) (rdtp (when (listp rtp) (cdr rtp)))(idtp (when (listp itp) (cdr itp))) (k (cmp-real-tp rctp ictp))) (if k (when (funcall (cdddr (rassoc k +complex*-typep-alist+ :key 'car)) o) (and (ibb (realpart o) rdtp) (ibb (imagpart o) idtp))) (when (complex*-simple-typep-fn o) (and (or (eq rtp '*) (typep (realpart o) rtp)) (or (eq itp '*) (typep (imagpart o) itp)))))) (define-typep-fn complex (o tp &aux (rtp (if tp (pop tp) '*)) (rlp (listp rtp))(rctp (if rlp (car rtp) rtp))(rdtp (when rlp (cdr rtp))) (k (cmp-real-tp rctp rctp))) (if k (when (funcall (cdddr (rassoc k +complex*-typep-alist+ :key 'car)) o) (and (ibb (realpart o) rdtp) (ibb (imagpart o) rdtp))) (when (complex-simple-typep-fn o) (or (eq rtp '*) (and (typep (realpart o) rtp) (typep (imagpart o) rtp)))))) (define-compound-typep-fn structure (o tp) (if tp (mss (c-structure-def o) (car tp)) t)) (setf (get 'structure-object 'typep-fn) 'structure-typep-fn);FIXME (define-compound-typep-fn std-instance (o tp) (if tp (when (member (car tp) (si-cpl-or-nil (si-class-of o))) t) t)) (define-compound-typep-fn funcallable-std-instance (o tp) (if tp (when (member (car tp) (si-cpl-or-nil (si-class-of o))) t) t)) (define-compound-typep-fn proper-cons (o tp) (if tp (and (typep (car o) (car tp)) (if (cdr tp) (typep (cdr o) (cadr tp)) t)) t)) (define-compound-typep-fn improper-cons (o tp) (if tp (and (typep (car o) (car tp)) (if (cdr tp) (typep (cdr o) (cadr tp)) t)) t)) (define-compound-typep-fn cons (o tp) (if tp (and (typep (car o) (car tp)) (if (cdr tp) (typep (cdr o) (cadr tp)) t)) t)) (define-typep-fn eql (o tp) (when tp (eql o (car tp)))) (define-typep-fn member (o tp) (when tp (when (member o tp) t))) (define-simple-typep-fn t) (define-simple-typep-fn nil) (define-typep-fn satisfies (o tp) (funcall (car tp) o)) (defun typep (x type &optional env &aux (lp (listp type))(ctp (if lp (car type) type))(tp (when lp (cdr type))) (sfn (unless tp (lookup-simple-typep-fn ctp)))(fn (unless sfn (lookup-typep-fn ctp)))) (declare (ignore env)) (cond (sfn (when (funcall sfn x) t)) (fn (when (funcall fn x tp) t)) ((case ctp (values t) (function tp) (otherwise (not (or (symbolp ctp) (si-classp ctp))))) (error 'type-error :datum type :expected-type 'type-spec)) ((typep x (expand-deftype type))))) (setq *typep-defined* t);FIXME (defun array-offset (x) (typecase x ((and (array bit) adjustable-array) (c-array-offset x)) (otherwise 0))) (setf (get 'array-offset 'cmp-inline) t) ;; (defun open-stream-p (x) ;; (declare (optimize (safety 1))) ;; (typecase x (open-stream t))) (defun input-stream-p (x) (declare (optimize (safety 1))) (etypecase x (broadcast-stream nil) (string-output-stream nil) (file-output-stream nil) (file-probe-stream nil) (synonym-stream (input-stream-p (symbol-value (synonym-stream-symbol x)))) (stream t))) ;; (defun interactive-stream-p (x) ;; (declare (optimize (safety 1))) ;; (typecase x (interactive-stream t))) (defun output-stream-p (x) (declare (optimize (safety 1))) (etypecase x (concatenated-stream nil) (string-input-stream nil) (file-input-stream nil) (file-probe-stream nil) (synonym-stream (output-stream-p (symbol-value (synonym-stream-symbol x)))) (stream t))) (defun floatp (x) (declare (optimize (safety 1))) (typecase x (float t))) (defun numberp (x) (declare (optimize (safety 1))) (typecase x (number t))) (defun characterp (x) (declare (optimize (safety 1))) (typecase x (character t))) (defun readtablep (x) (declare (optimize (safety 1))) (typecase x (readtable t))) (defun realp (x) (declare (optimize (safety 1))) (typecase x (real t))) (defun integerp (x) (declare (optimize (safety 1))) (typecase x (integer t))) (defun rationalp (x) (declare (optimize (safety 1))) (typecase x (rational t))) (defun complexp (x) (declare (optimize (safety 1))) (typecase x (complex t))) (defun bit-vector-p (x) (declare (optimize (safety 1))) (typecase x (bit-vector t))) (defun simple-string-p (x) (declare (optimize (safety 1))) (typecase x (simple-string t))) (defun simple-vector-p (x) (declare (optimize (safety 1))) (typecase x (simple-vector t))) (defun streamp (x) (declare (optimize (safety 1))) (typecase x (stream t))) (defun arrayp (x) (declare (optimize (safety 1))) (typecase x (array t))) (defun vectorp (x) (declare (optimize (safety 1))) (typecase x (vector t))) (defun packagep (x) (declare (optimize (safety 1))) (typecase x (package t))) (defun simple-bit-vector-p (x) (declare (optimize (safety 1))) (typecase x (simple-bit-vector t))) (defun random-state-p (x) (declare (optimize (safety 1))) (typecase x (random-state t))) gcl-2.7.1/lsp/PaxHeaders/gcl_defseq.lsp0000644000000000000000000000013214774225145014771 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.344938378 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_defseq.lsp0000644000175000017500000001005014774225145014363 0ustar00cammcamm(in-package :si) (defmacro defseq (n (il seq &key count list (+ifnot il) nokey) &body body &aux (ts (sgen))(tsc (sgen))(kf (sgen)) (q2 (listp seq))(seq1 (when q2 (car seq)))(seq (if q2 (cadr seq) seq)) (st (if list 'proper-list 'proper-sequence)) (start (unless list (if q2 'start2 'start)))(end (unless list (if q2 'end2 'end))) (keys `(&key ,@(unless nokey '(key)) ,@(unless list `(from-end (,start 0) ,end ,@(when q2 `((start1 0) end1)) ,@(when count `(count))))))) `(progn (defun ,n (,@il ,@(when q2 (list seq1)) ,seq ,@keys test test-not &aux (,ts (coerce (or test test-not #'eql) 'function)) (,tsc (cond ((eq ,ts #'eq) 0) ((eq ,ts #'eql) 1) ((eq ,ts #'equal) 2) ((eq ,ts #'equalp) 3) ((eq ,ts #'funcall) 4) (5))) ,@(unless nokey `((,kf (when key (coerce key 'function))) (,kf (unless (eq ,kf #'identity) ,kf)))) ,@(unless list `((l (listp ,seq))))) (declare (optimize (safety 1))) ,@(unless (case list ((tree tree2) t)) `((check-type ,seq ,st))) ,@(when q2 (unless (eq list 'tree2) `((check-type ,seq1 ,st)))) (check-type test (or null function-designator)) (check-type test-not (or null function-designator)) ,@(unless nokey `((check-type key (or null function-designator)))) ,@(unless list `((check-type ,start seqind) (check-type ,end (or null seqbnd)) ,@(when q2 `((check-type start1 seqind) (check-type end1 (or null seqbnd)))))) ,@(when count `((check-type count (or null integer)))) (and test test-not (error "both test and test not supplied")) (let* ,(unless list `((lsa (if l (1- array-dimension-limit) (length ,seq))) (jj (unless ,end l))(j (if from-end -1 1))(,end (or ,end lsa)) ,@(when count `((cnt (or count (1- array-dimension-limit))) (cnt (min (1- array-dimension-limit) (max 0 cnt))))) r (s (if l (nthcdr ,start ,seq) ,seq)))) ,@(unless list `((declare (dynamic-extent r)(ignorable j jj)) (when (and l from-end) (do ((p s (cdr p))(i ,start (1+ i))) ((or (when l (endp p)) (>= i ,end)) (setq ,end (min ,end i))) (push p r))))) (labels (,@(unless list `((el (p i) (if l (if from-end (caar p) (car p)) (aref ,seq i))) (hd (p i) (if l (if from-end (car p) p) i)))) ,@(unless nokey `((key (x) (if ,kf (funcall ,kf x) x)))) (test-no-key (x y) (if (case ,tsc (0 (eq x y)) (1 (eql x y)) (2 (equal x y)) (3 (equalp x y)) (4 (funcall x y)) (otherwise (funcall ,ts x y))) (not test-not) test-not)) (test (x y) (test-no-key x ,(if nokey 'y '(key y))))) (declare (ignorable #'test ,@(unless list `(#'el #'hd)))) (when (case ,tsc ((1 2 3) (or ,@(unless list `((unless l (array-eql-is-eq ,seq)) ,@(when seq1 `((unless (listp ,seq1) (array-eql-is-eq ,seq1)))))) ,@(when il (let ((i (car (last il)))) `((case ,tsc (1 (eql-is-eq ,i)) (2 (equal-is-eq ,i)) (3 (equalp-is-eq ,i))))))))) (setq ,tsc 0)) (macrolet ((collect (a b c) `(let ((tmp ,a)) (setq ,c (if ,c (cdr (rplacd ,c tmp)) (setq ,b tmp)))))) ,@body)))) ,@(when +ifnot (let* ((s (sgen))(tk (sgen))(new (when (cdr il) (list (car il)))) (x `(defun ,s (,@new fd ,seq ,@keys) (declare (optimize (safety 1))) (check-type fd function-designator) ,@(unless (case list ((tree tree2) t)) `((check-type ,seq ,st))) (check-type key (or null function-designator)) ,@(unless list `((check-type ,start seqind) (check-type ,end (or null seqbnd)))) ,@(when count `((check-type count (or null integer)))) (,n ,@new (coerce fd 'function) ,seq ,tk #'funcall :key key ,@(unless list `(:from-end from-end :start start :end end)) ,@(when count `(:count count))))));try apply (list (sublis `((,s . ,(intern (string-concatenate (string n) "-IF")))(,tk . :test)) x) (sublis `((,s . ,(intern (string-concatenate (string n) "-IF-NOT")))(,tk . :test-not)) x)))))) gcl-2.7.1/lsp/PaxHeaders/gcl_mislib.lsp0000644000000000000000000000013114774225145015000 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_mislib.lsp0000644000175000017500000002353314774225145014405 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'lisp) ;(export 'time) ;(export '(reset-sys-paths ; decode-universal-time ; encode-universal-time compile-file-pathname complement constantly)) (in-package :system) (export '(funcallable-symbol-function));FIXME fsf (defmacro time (form) (declare (optimize (safety 2))) (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)) (alloc-start (gensym))) `(let (,real-start ,real-end (,gbc-time-start (gbc-time)) ,gbc-time ,x (,alloc-start (cumulative-allocation))) (setq ,real-start (get-internal-real-time)) (multiple-value-bind (,run-start ,child-run-start) (get-internal-run-times) (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-times) (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~%~ allocation : ~10D Mbytes~%" (/ (- ,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) (- (cumulative-allocation) ,alloc-start)))) (values-list ,x)))) (defun this-tz (&aux (x (current-timezone))) (if (current-dstp) (1+ x) x)) (defconstant +secs-to-1970+ (* (+ 17 (* 70 365)) 24 60 60)) (defun decode-universal-time (ut &optional (tz (this-tz) tzp) &aux dstp1) (declare (optimize (safety 2))) (check-type ut integer) (check-type tz rational) (let ((ut (- ut +secs-to-1970+ (* (- tz (this-tz)) 3600)))) (multiple-value-bind (s n h d m y w yd dstp off) (localtime ut) (declare (ignore yd)) (when (when tzp (> dstp 0)) (multiple-value-setq (s n h d m y w yd dstp1) (localtime (- ut 3600)))) (values s n (+ h (- dstp (or dstp1 dstp))) 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) (+ (mktime s n h d (1- m) (- y 1900) (if tzp 0 -1)) +secs-to-1970+ (* (- tz (this-tz)) 3600))) (defun get-decoded-time () (decode-universal-time (get-universal-time))) ;Courtesy Paul Dietz (defun compile-file-pathname (pathname) (declare (optimize (safety 2))) (make-pathname :defaults pathname :type "o")) (defun constantly (x) (declare (optimize (safety 2))) (lambda (&rest args) (declare (ignore args) (dynamic-extent args)) x)) (defun complement (fn) (declare (optimize (safety 2))) (lambda (&rest args) (not (apply fn args)))) (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 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~%" "physical pages: ~a~%" "immfix start: 0x~x~%" "immfix size: ~a fixnums~%")) (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 (room-report));(multiple-value-list (si:room-report))) maxpage holepage leftpage ncbpage maxcbpage ncb cbgbccount npage rbused rbfree nrbpage rbgbccount maxrbpage maxnpage 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 7 l)) (j 0 (+ j (if (nth 3 l) (nth 3 l) 0))) (i 0 (+ i (if (nth 3 l) (nth 3 l) 0)))) ((null l) (setq npage i maxnpage j)) (let ((typename (intern (nth 0 l))) (nused (nth 1 l)) (nfree (nth 2 l)) (npage (nth 3 l)) (maxpage (nth 4 l)) (gbccount (nth 5 l)) (ws (nth 6 l))) (if nused (push (list typename ws npage maxpage (if (zerop (+ nused nfree)) 0 (/ nused 0.01 (+ nused nfree))) (if (zerop gbccount) nil gbccount)) info-list) (let* ((nfree (intern nfree)) (a (assoc nfree link-alist))) (if a (nconc a (list typename)) (push (list nfree typename) link-alist)))))) (terpri) (format t "~@[~2A~]~10@A/~A~21T~6@A%~@[~8@A~]~37T~{~A~^ ~}~%~%" "WS" "UP" "MP" "FI" "GC" '("TYPES")) (dolist (info (reverse info-list)) (apply #'format t "~@[~2D~]~10D/~D~21T~6,1F%~@[~8D~]~37T~{~A~^ ~}" (append (cdr info) (if (assoc (car info) link-alist) (list (assoc (car info) link-alist)) (list (list (car info)))))) (terpri) ) (terpri) (format t "~12D/~D~28T~@[~8D~]~37Tcontiguous (~D blocks)~%" ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb) (format t "~13T~D~37Thole~%" holepage) (format t "~12D/~D~21T~6,1F%~@[~8D~]~37Trelocatable~%~%" nrbpage maxrbpage (/ rbused 0.01 (+ rbused rbfree)) (if (zerop rbgbccount) nil rbgbccount)) (format t "~12D pages for cells~%~%" npage) (format t "~12D total pages in core~%" (+ npage ncbpage nrbpage)) (format t "~12D current core maximum pages~%" (+ maxnpage maxcbpage maxrbpage)) (format t "~12D pages reserved for gc~%" maxrbpage) (format t "~12D pages available for adding to core~%" leftpage) (format t "~12D pages reserved for core exhaustion~%~%" (- maxpage (+ maxnpage maxcbpage (ash maxrbpage 1) leftpage))) (format t "~12D 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)) (defun pool-watch (&optional (s 3) (c 10) &aux (x (pool-stat))) (when (plusp c) (format t "master pid ~s ~s processes ~s pages~%" (pop x) (pop x) (car x)) (sleep s) (pool-watch s (1- c)))) (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 (make-array 0 :element-type 'character :adjustable t :fill-pointer 0))) (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.7.1/lsp/PaxHeaders/gcl_truename.lsp0000644000000000000000000000013114774225145015341 xustar0030 mtime=1743858277.049814274 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_truename.lsp0000644000175000017500000000353614774225145014747 0ustar00cammcamm(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 #v"/" 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 (concatenate 'string (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.7.1/lsp/PaxHeaders/gcl_wild_pathname_p.lsp0000644000000000000000000000013114774225145016654 xustar0030 mtime=1743858277.049814274 30 atime=1744340056.376938583 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_wild_pathname_p.lsp0000644000175000017500000000211114774225145016246 0ustar00cammcamm(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.7.1/lsp/PaxHeaders/gcl_namestring.lsp0000644000000000000000000000013114774225145015670 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_namestring.lsp0000644000175000017500000000304014774225145015264 0ustar00cammcamm(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 (concatenate 'string "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.7.1/lsp/PaxHeaders/gcl_listlib.lsp0000644000000000000000000000013114776006046015162 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.294035039 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_listlib.lsp0000644000175000017500000004120414776006046014562 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :system) (eval-when (compile eval) (defmacro collect (r rp form) `(let ((tmp ,form)) (setq ,rp (cond (,rp (rplacd ,rp tmp) tmp) ((setq ,r tmp)))))) (defmacro cons-length (x) (declare (optimize (safety 2))) `(let ((,x ,x)) (if (not ,x) 0 (do ((i 1 (1+ i))(s ,x (cdr s))(f (cdr ,x) (cddr f))) ((>= i array-dimension-limit) (- array-dimension-limit)) (cond ((eq s f) (return i)) ((endp f) (return (1+ (- (+ i i))))) ((endp (cdr f)) (return (- (+ i i)))))))))) #.(let (r) (labels ((f (n r) (when (plusp n) (cons `(pop ,r) (f (1- n) r)))) (d (n &aux (s (intern (format nil "AFC~a" n)))) (setq r (cons (cons n s) r)) `(progn (declaim (inline ,s)) (defun ,s (f s r) (declare (function f)(proper-list r)) (values (funcall f s ,@(f n 'r)))))) (a (n) (when (plusp n) (cons (d n) (a (1- n)))))) `(progn ,@(a (- call-arguments-limit 2)) (defconstant +afc-syms+ ',r)))) (declaim (inline afc-sym)) (defun afc-sym (n) (labels ((f (n s) (when s (if (eql (caar s) n) (cdar s) (f n (cdr s)))))) (f n +afc-syms+))) (defun mapl (fd list &rest r &aux (fun (coerce fd 'function))) (declare (optimize (safety 1))(dynamic-extent r)(notinline make-list));FIXME (check-type fd function-designator) (check-type list proper-list) (labels ((lmap (f x) (when x (funcall f x) (lmap f (cdr x)))) (lmapr (f x) (lmap f x) x)) (if (not r) (lmapr fun list);compiler accelerator (let* ((lr (length r))(q (make-list lr))(nf (afc-sym lr))) (declare (dynamic-extent q)) (labels ((a-cons (x) (check-type x list) (or x (return-from mapl list))) (last nil (lmapr (lambda (x) (rplaca x (if r (a-cons (pop r)) (a-cons (cdar x))))) q))) ;cannot apply as fun might capture (last) via &rest (lmapr (lambda (x) (funcall nf fun x (last))) list)))))) (defun mapc (fd list &rest r &aux (fun (coerce fd 'function))) (declare (optimize (safety 1))(dynamic-extent r)) (check-type fd function-designator) (check-type list proper-list) (if (not r) (mapl (lambda (x) (funcall fun (car x))) list);compiler accelerator (let* ((lr (length r))(q (make-list lr))(nf (afc-sym lr))) (declare (dynamic-extent q)) (apply 'mapl (lambda (x &rest r) (funcall nf fun (car x) (mapl (lambda (x) (setf (car x) (car (pop r)))) q))) list r)))) (defun mapcar (fd list &rest r &aux (fun (coerce fd 'function)) res rp) (declare (optimize (safety 1))(dynamic-extent r)) (check-type fd function-designator) (check-type list proper-list) (apply 'mapc (lambda (x &rest z &aux (tem (cons (apply fun x z) nil))) (setq rp (if rp (cdr (rplacd rp tem)) (setq res tem)))) list r) res) (defun mapcan (fd list &rest r &aux (fun (coerce fd 'function)) res rp) (declare (optimize (safety 1))(dynamic-extent r)) (check-type fd function-designator) (check-type list proper-list) (apply 'mapc (lambda (x &rest z &aux (tem (apply fun x z))) (if rp (rplacd rp tem) (setq res tem)) (when (consp tem) (setq rp (last tem)))) list r) res) (defun maplist (fd list &rest r &aux (fun (coerce fd 'function)) res rp) (declare (optimize (safety 1))(dynamic-extent r)) (check-type fd function-designator) (check-type list proper-list) (apply 'mapl (lambda (x &rest z &aux (tem (cons (apply fun x z) nil))) (setq rp (if rp (cdr (rplacd rp tem)) (setq res tem)))) list r) res) (defun mapcon(fd list &rest r &aux (fun (coerce fd 'function)) res rp) (declare (optimize (safety 1))(dynamic-extent r)) (check-type fd function-designator) (check-type list proper-list) (apply 'mapl (lambda (x &rest z &aux (tem (apply fun x z))) (if rp (rplacd rp tem) (setq res tem)) (when (consp tem) (setq rp (last tem)))) list r) res) (defun endp (x) (declare (optimize (safety 2))) (check-type x list) (not x)) (defun nthcdr (n x) (declare (optimize (safety 2))) (check-type n (integer 0)) (check-type x list) (when x ;FIXME? (let ((n (cond ((<= n array-dimension-limit) n) ((let ((j (cons-length x))) (when (> j 0) (mod n j)))) ((return-from nthcdr nil))))) (labels ((lnthcdr (x n) (if (or (<= n 0) (endp x)) x (lnthcdr (cdr x) (1- n))))) (lnthcdr x n))))) (defun last (x &optional (n 1));FIXME check for circle (declare (optimize (safety 2))) (check-type x list) (check-type n (integer 0)) (let* ((n (min array-dimension-limit n)) (w (cond ((= n 1) (cdr x)) ((do ((n n (1- n))(w x (cdr w))) ((<= n 0) w) (unless (consp w) (return-from last x))))))) (do ((x x (cdr x)) (w w (cdr w))) ((atom w) x)))) (defun butlast (x &optional (n 1));FIXME check for circle (declare (optimize (safety 2))) (check-type x list) (check-type n (integer 0)) (let* ((n (min array-dimension-limit n)) (w (cond ((= n 1) (cdr x)) ((do ((n n (1- n))(w x (cdr w))) ((<= n 0) w) (unless (consp w) (return-from butlast nil))))))) (do (r rp (x x (cdr x)) (w w (cdr w))) ((atom w) r) (let ((tmp (cons (car x) nil))) (collect r rp tmp))))) (defun nbutlast (x &optional (n 1));FIXME check for circle (declare (optimize (safety 2))) (check-type x list) (check-type n (integer 0)) (let* ((n (min array-dimension-limit n)) (w (cond ((= n 1) (cdr x)) ((do ((n n (1- n))(w x (cdr w))) ((<= n 0) w) (unless (consp w) (return-from nbutlast nil))))))) (do ((r x) (rp nil x) (x x (cdr x)) (w w (cdr w))) ((atom w) (when rp (rplacd rp nil) r))))) (defun ldiff (l tl &aux r rp) (declare (optimize (safety 1))) (check-type l list) (labels ((srch (x) (cond ((eql x tl) (when rp (rplacd rp nil)) r) ((atom x) (when rp (rplacd rp x)) r) (t (let ((tmp (cons (car x) (cdr x)))) (setq rp (if rp (cdr (rplacd rp tmp)) (setq r tmp))) (srch (cdr x))))))) (srch l))) (defun tailp (tl l) (declare (optimize (safety 1))) (check-type l list) (labels ((srch (x) (or (eql x tl) (unless (atom x) (srch (cdr x)))))) (srch l))) (defun list-length (l) (declare (optimize (safety 2))) (check-type l list) (cond ((endp l) 0) ((endp (setq l (cdr l))) 1) ((endp (setq l (cdr l))) 2) ((endp (setq l (cdr l))) 3) ((endp (setq l (cdr l))) 4) ((let ((x (cons-length l))) (when (<= x 0) (+ 4 (- x))))))) (defun make-list (n &key initial-element) (declare (optimize (safety 2))) (check-type n seqind) (do (r (n n (1- n))) ((<= n 0) r) (push initial-element r))) (defun rest (l) (declare (optimize (safety 2))) (check-type l list) (cdr l)) (defun acons (key datum alist) (declare (optimize (safety 2))) (cons (cons key datum) alist)) (defun pairlis (k d &optional a) (declare (optimize (safety 1))) (check-type k proper-list) (check-type d proper-list) (mapc (lambda (x y) (setq a (acons x y a))) k d) a) (defun copy-list (l) (declare (optimize (safety 2))) (check-type l list) (do (r rp (l l (cdr l))) ((atom l) (when rp (rplacd rp l)) r) (let ((tmp (cons (car l) nil))) (collect r rp tmp)))) (defun copy-alist (l) (declare (optimize (safety 1))) (check-type l proper-list) (maplist (lambda (x &aux (e (car x))) (if (consp e) (cons (car e) (cdr e)) e)) l)) (defun nconc (&rest l) (declare (optimize (safety 1))(dynamic-extent l)) (if (cdr l) (let ((x (pop l))(y (apply 'nconc l))) (etypecase x (cons (rplacd (last x) y) x)(null y))) (car l))) (defun nreconc (list tail &aux r) (declare (optimize (safety 1))) (check-type list proper-list) (mapl (lambda (x) (when r (setq tail (rplacd r tail))) (setq r x)) list) (if r (rplacd r tail) tail)) (defun nth (n x) (declare (optimize (safety 2))) (check-type n (integer 0)) (check-type x list) (car (nthcdr n x))) (defun first (x) (declare (optimize (safety 2))) (check-type x list) (car x)) (defun second (x) (declare (optimize (safety 2))) (check-type x list) (cadr x)) (defun third (x) (declare (optimize (safety 2))) (check-type x list) (caddr x)) (defun fourth (x) (declare (optimize (safety 2))) (check-type x list) (cadddr x)) (defun fifth (x) (declare (optimize (safety 2))) (check-type x list) (car (cddddr x))) (defun sixth (x) (declare (optimize (safety 2))) (check-type x list) (cadr (cddddr x))) (defun seventh (x) (declare (optimize (safety 2))) (check-type x list) (caddr (cddddr x))) (defun eighth (x) (declare (optimize (safety 2))) (check-type x list) (cadddr (cddddr x))) (defun ninth (x) (declare (optimize (safety 2))) (check-type x list) (car (cddddr (cddddr x)))) (defun tenth (x) (declare (optimize (safety 2))) (check-type x list) (cadr (cddddr (cddddr x)))) ; Courtesy Paul Dietz (defmacro nth-value (n expr) (declare (optimize (safety 2))) `(nth ,n (multiple-value-list ,expr))) (defun copy-tree (tr) (declare (optimize (safety 2))) (do (st cs a (g (sgen))) (nil) (declare (dynamic-extent st cs)) (cond ((atom tr) (do nil ((or (not cs) (eq g (car cs)))) (setq a (pop cs) st (cdr st) tr (cons a tr))) (unless cs (return tr)) (setf (car cs) tr tr (cdar st))) ((setq st (cons tr st) cs (cons g cs) tr (car tr)))))) (defun append (&rest l) (declare (optimize (safety 1))(dynamic-extent l)) (if (cdr l) (let ((x (pop l))(y (apply 'append l))) (check-type x proper-list) (if (typep y 'proper-list) (let (r rp) (mapc (lambda (x) (collect r rp (cons x nil))) x) (when rp (rplacd rp y)) (or r y)) (labels ((f (x) (if x (cons (car x) (f (cdr x))) y))) (f x)))) (car l))) (defun revappend (list tail) (declare (optimize (safety 1))) (check-type list proper-list) (mapc (lambda (x) (setq tail (cons x tail))) list) tail) (defun not (x) (if x nil t)) (defun null (x) (if x nil t)) (defun get-properties (p i &aux s) (declare (optimize (safety 1)));FIXME, safety 2 and no check-type loses signature info (check-type p proper-list) (check-type i proper-list) (cond ((endp p) (values nil nil nil)) ((member (setq s (car p)) i :test 'eq) (values s (cadr p) p)) (t (let ((p (cdr p))) (check-type p proper-cons);FIXME, cons loses proper in return (get-properties (cdr p) i))))) (defun rplaca (x y) (declare (optimize (safety 1))) (check-type x cons) (c-set-cons-car x y) x) (defun rplacd (x y) (declare (optimize (safety 1))) (check-type x cons) (c-set-cons-cdr x y) x) ;(defun listp (x) (typep x 'list));(typecase x (list t))) (defun consp (x) (when x (listp x))) (defun atom (x) (not (consp x))) (defun getf (l i &optional d) (declare (optimize (safety 1))) (check-type l proper-list) (cond ((endp l) d) ((eq (car l) i) (cadr l)) ((let ((l (cdr l))) (check-type l cons) (getf (cdr l) i d))))) (defun identity (x) x) #-pre-gcl (eval-when (compile) (load (merge-pathnames "gcl_defseq.lsp" *compile-file-pathname*))) (defseq member ((item) list :list t) (unless (mapl (lambda (x) (when (test item (car x)) (return-from member x))) list))) (defseq assoc ((item) list :list t) (unless (mapc (lambda (x);check-type dropped at safety 1 in assoc-if/not (unless (listp x) (error 'type-error :datum x :expected-type 'list)) (when (and x (test item (car x))) (return-from assoc x))) list))) (defseq rassoc ((item) list :list t) (unless (mapc (lambda (x) (unless (listp x) (error 'type-error :datum x :expected-type 'list)) (when (and x (test item (cdr x))) (return-from rassoc x))) list))) (defseq intersection (nil (l1 l2) :list t) (mapcan (lambda (x) (when (member (key x) l2 :test #'test) (cons x nil))) l1)) (defseq union (nil (l1 l2) :list t) (let (rp) (prog1 (or (mapcan (lambda (x) (unless (member (key x) l2 :test #'test) (setq rp (cons x nil)))) l1) l2) (when rp (rplacd rp l2))))) (defseq set-difference (nil (l1 l2) :list t) (mapcan (lambda (x) (unless (member (key x) l2 :test #'test) (cons x nil))) l1)) (defseq set-exclusive-or (nil (l1 l2) :list t) (let (rp (rr (copy-list l2))) (prog1 (or (mapcan (lambda (x &aux (k (key x))) (if (member k l2 :test #'test) (unless (setq rr (delete k rr :test #'test))) (setq rp (cons x nil)))) l1) rr) (when rp (rplacd rp rr))))) (defseq nintersection (nil (l1 l2) :list t) (let (r rp) (mapl (lambda (x) (when (member (key (car x)) l2 :test #'test) (if rp (rplacd rp x) (setq r x)) (setq rp x))) l1) (when rp (rplacd rp nil)) r)) (defseq nunion (nil (l1 l2) :list t) (let (r rp) (mapl (lambda (x) (unless (member (key (car x)) l2 :test #'test) (if rp (rplacd rp x) (setq r x))(setq rp x))) l1) (when rp (rplacd rp l2)) (or r l2))) (defseq nset-difference (nil (l1 l2) :list t) (let (r rp) (mapl (lambda (x) (unless (member (key (car x)) l2 :test #'test) (if rp (rplacd rp x) (setq r x))(setq rp x))) l1) (when rp (rplacd rp nil)) r)) (defseq nset-exclusive-or (nil (l1 l2) :list t) (let (r rp (rr (copy-list l2))) (mapl (lambda (x &aux (k (key (car x)))) (if (member k l2 :test #'test) (unless (setq rr (delete k rr :test #'test))) (progn (if rp (rplacd rp x) (setq r x))(setq rp x)))) l1) (when rp (rplacd rp rr)) (or r rr))) (defseq subsetp (nil (l1 l2) :list t) (mapc (lambda (x) (unless (member (key x) l2 :test #'test) (return-from subsetp nil))) l1) t) (defseq subst ((n o) tr :list tree) (do (st cs a c rep (g (sgen))) (nil) (declare (dynamic-extent st cs)) (setq rep (test o tr)) (cond ((or rep (atom tr)) (setq tr (if rep n tr)) (do nil ((or (not cs) (eq g (car cs)))) (setq a (pop cs) c (pop st) tr (if (and (eq a (car c)) (eq tr (cdr c))) c (cons a tr)))) (if cs (setf (car cs) tr tr (cdar st)) (return tr))) ((setq st (cons tr st) cs (cons g cs) tr (car tr)))))) (defseq nsubst ((n o) tr :list tree) (do (st cs rep (g (sgen))) (nil) (declare (dynamic-extent st cs)) (setq rep (test o tr)) (cond ((or rep (atom tr)) (setq tr (if rep n tr)) (do nil ((or (not cs) (eq g (car cs)))) (setf (caar st) (pop cs) (cdar st) tr tr (pop st))) (if cs (setf (car cs) tr tr (cdar st)) (return tr))) ((setq st (cons tr st) cs (cons g cs) tr (car tr)))))) (defseq sublis (nil (al tr) :list tree) (or (unless al tr) (do (st cs a c rep (g (sgen))) (nil) (declare (dynamic-extent st cs)) (setq rep (assoc (key tr) al :test #'test-no-key)) (cond ((or rep (atom tr)) (setq tr (if rep (cdr rep) tr)) (do nil ((or (not cs) (eq g (car cs)))) (setq a (pop cs) c (pop st) tr (if (and (eq a (car c)) (eq tr (cdr c))) c (cons a tr)))) (if cs (setf (car cs) tr tr (cdar st)) (return tr))) ((setq st (cons tr st) cs (cons g cs) tr (car tr))))))) (defseq nsublis (nil (al tr) :list tree) (or (unless al tr) (do (st cs rep (g (sgen))) (nil) (declare (dynamic-extent st cs)) (setq rep (assoc (key tr) al :test #'test-no-key)) (cond ((or rep (atom tr)) (setq tr (if rep (cdr rep) tr)) (do nil ((or (not cs) (eq g (car cs)))) (setf (caar st) (pop cs) (cdar st) tr tr (pop st))) (if cs (setf (car cs) tr tr (cdar st)) (return tr))) ((setq st (cons tr st) cs (cons g cs) tr (car tr))))))) (defseq adjoin ((item) list :list t :+ifnot nil) (if (member (key item) list :test #'test) list (cons item list))) (defseq tree-equal (nil (tr1 tr2) :list tree2 :nokey t) (do (st1 cs1 st2 (g (sgen))) (nil) (declare (dynamic-extent st1 cs1 st2)) (cond ((and (atom tr1) (consp tr2)) (return nil)) ((and (consp tr1) (atom tr2)) (return nil)) ((atom tr1) (unless (test tr1 tr2) (return nil)) (do nil ((or (not cs1) (eq g (car cs1)))) (setq cs1 (cdr cs1) tr1 (pop st1) tr2 (pop st2))) (unless cs1 (return t)) (setf (car cs1) tr1 tr1 (cdar st1) tr2 (cdar st2))) ((setq st1 (cons tr1 st1) cs1 (cons g cs1) tr1 (car tr1) st2 (cons tr2 st2) tr2 (car tr2)))))) gcl-2.7.1/lsp/PaxHeaders/gcl_bit.lsp0000644000000000000000000000013214774225145014300 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.344938378 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_bit.lsp0000644000175000017500000001065514774225145013705 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defun mask (nbits &optional (off 0)) (if (eql nbits fixnum-length) -1 (<< (~ (<< -1 nbits)) (end-shft off nbits)))) (setf (get 'mask 'compiler::cmp-inline) t) (defun b<< (x y) #+clx-little-endian (<< x y) #-clx-little-endian (>> x y)) (setf (get 'b<< 'compiler::cmp-inline) t) (defun b>> (x y) #+clx-little-endian (>> x y) #-clx-little-endian (<< x y)) (setf (get 'b>> 'compiler::cmp-inline) t) (defun merge-word (x y m) (\| (& x m) (& y (~ m)))) (setf (get 'merge-word 'compiler::cmp-inline) t) (defun bit-array-fixnum (a i n) (if (<= 0 i n) (*fixnum (c-array-self a) i nil 0) 0)) (setf (get 'bit-array-fixnum 'compiler::cmp-inline) t) (defun set-bit-array-fixnum (a i v);(a i n v) ; (assert (<= 0 i n)) (*fixnum (c-array-self a) i t v)) (setf (get 'set-bit-array-fixnum 'compiler::cmp-inline) t) (defun gw (a i n od) (cond ((zerop od) (bit-array-fixnum a i n)) ((plusp od) (merge-word (b>> (bit-array-fixnum a i n) od) (b<< (bit-array-fixnum a (1+ i) n) (- fixnum-length od)) (mask (- fixnum-length od)))) ((merge-word (b>> (bit-array-fixnum a (1- i) n) (+ fixnum-length od)) (b<< (bit-array-fixnum a i n) (- od)) (mask (- od)))))) (setf (get 'gw 'compiler::cmp-inline) t) (defun bit-array-op (fn ba1 ba2 &optional rba (so1 0) (so2 0) (so3 0) n &aux (rba (case rba ((t) ba1) ((nil) (make-array (array-dimensions ba1) :element-type 'bit)) (otherwise rba)))) (let* ((o3 (+ so3 (array-offset rba))) (y (or n (array-total-size rba)));min (o1 (+ so1 (array-offset ba1))) (n1 (ceiling (+ o1 (array-total-size ba1)) fixnum-length)) (o1 (- o1 o3)) (o2 (+ so2 (array-offset ba2))) (n2 (ceiling (+ o2 (array-total-size ba2)) fixnum-length)) (o2 (- o2 o3))) (multiple-value-bind (nw rem) (floor (+ o3 y) fixnum-length) (let ((i 0)(n3 (if (zerop rem) nw (1+ nw)))) (when (plusp o3) (set-bit-array-fixnum rba i (merge-word (funcall fn (gw ba1 i n1 o1) (gw ba2 i n2 o2)) (bit-array-fixnum rba i n3) (mask (min y (- fixnum-length o3)) o3))) (incf i)) (do nil ((>= i nw)) (set-bit-array-fixnum rba i (funcall fn (gw ba1 i n1 o1) (gw ba2 i n2 o2))) (incf i)) (when (and (plusp rem) (eql i nw)) (set-bit-array-fixnum rba i (merge-word (funcall fn (gw ba1 i n1 o1) (gw ba2 i n2 o2)) (bit-array-fixnum rba i n3) (mask rem)))) rba)))) (setf (get 'bit-array-op 'compiler::cmp-inline) t) (defun copy-bit-vector (a i b j n) (bit-array-op (lambda (x y) (declare (ignore x)) y) a b t i j i n)) ;FIXME array-dimensions allocates.... (defvar *bit-array-dimension-check-ref* nil) (defun bit-array-dimension-check (y &aux (r (array-rank *bit-array-dimension-check-ref*))) (when (eql r (array-rank y)) (dotimes (i r t) (unless (eql (array-dimension *bit-array-dimension-check-ref* i) (array-dimension y i)) (return nil))))) (setf (get 'bit-array-dimension-check 'compiler::cmp-inline) t) (eval-when (compile eval) (defmacro defbitfn (f fn &aux (n (eq f 'bit-not))) `(defun ,f (x ,@(unless n `(y)) &optional rz) (declare (optimize (safety 1))) (check-type x (array bit)) ,@(unless n `((check-type y (array bit)))) (check-type rz (or boolean (array bit))) (let ((*bit-array-dimension-check-ref* x),@(unless n '((y y)))(rz rz)) ,@(unless n '((check-type y (and (array bit) (satisfies bit-array-dimension-check))))) (check-type rz (or boolean (and (array bit) (satisfies bit-array-dimension-check)))) (bit-array-op ,fn x ,(if n 'x 'y) rz))))) (defbitfn bit-and #'&) (defbitfn bit-ior #'\|) (defbitfn bit-xor #'^) (defbitfn bit-eqv (lambda (x y) (~ (^ x y)))) (defbitfn bit-nand (lambda (x y) (~ (& x y)))) (defbitfn bit-nor (lambda (x y) (~ (\| x y)))) (defbitfn bit-andc1 (lambda (x y) (& (~ x) y))) (defbitfn bit-andc2 (lambda (x y) (& x (~ y)))) (defbitfn bit-orc1 (lambda (x y) (\| (~ x) y))) (defbitfn bit-orc2 (lambda (x y) (\| x (~ y)))) (defbitfn bit-not (lambda (x y) (declare (ignore y)) (~ x))) (defun baset (v x &rest r) (declare (optimize (safety 1))(dynamic-extent r)) (check-type x (array bit)) (apply 'aset v x r)) (setf (get 'baset 'compiler::cmp-inline) t) (defun sbaset (v x &rest r) (declare (optimize (safety 1))(dynamic-extent r)) (check-type x (simple-array bit)) (apply 'aset v x r)) (setf (get 'sbaset 'compiler::cmp-inline) t) gcl-2.7.1/lsp/PaxHeaders/gcl_fpe_test.lsp0000644000000000000000000000013214774225145015333 xustar0030 mtime=1743858277.045814259 30 atime=1744295000.417964192 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_fpe_test.lsp0000644000175000017500000002747714774225145014752 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) #.`(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 "static " (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 fsqrt object ((object x)) "{volatile double a=lf(x),c;" "__asm__ __volatile__ (\"fldl %0;fsqrt ;fstpl %1;fwait\" " ": \"=m\" (a): \"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-nf 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)) (lit :double "sqrt(" (:double x) ")"));(the long-float (|libm|:|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 'fsqrt (list 4.0) 2.0 t) (test-fpe 'fsqrt (list -1.0) :floating-point-invalid-operation t) ;(test-fpe 'lsqrt (list -1.0) :floating-point-invalid-operation t) ;(test-fpe '|libm|:|sqrt| (list -1.0) :floating-point-invalid-operation t) (test-fpe 'fsqrt (list 1.2) :floating-point-inexact t) gcl-2.7.1/lsp/PaxHeaders/gcl_predlib.lsp0000644000000000000000000000013114774225145015142 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_predlib.lsp0000644000175000017500000003446614774225145014556 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :system) (export '(int void static non-standard-object-compiled-function interpreted-function non-logical-pathname non-standard-base-char true gsym std-instance funcallable-std-instance hash-table-eq hash-table-eql hash-table-equal hash-table-equalp +type-alist+ sequencep ratiop short-float-p long-float-p eql-is-eq equal-is-eq equalp-is-eq eql-is-eq-tp equal-is-eq-tp equalp-is-eq-tp +array-types+ +aet-type-object+ returns-exactly immfix file-input-stream file-output-stream file-io-stream file-probe-stream string-input-stream string-output-stream proper-sequence proper-sequencep proper-cons proper-consp fcomplex dcomplex cnum-type spice resolve-type ldiff-nf)) (defun ldiff-nf-with-last (l tl &aux r rp) (declare (optimize (safety 1))) (check-type l proper-list) (labels ((srch (x) (if (eq x tl) (values r rp) (let ((tmp (cons (car x) nil))) (setq rp (if rp (cdr (rplacd rp tmp)) (setq r tmp))) (srch (cdr x)))))) (if tl (srch l) (values l nil)))) (setf (get 'ldiff-nf-with-last 'cmp-inline) t) (defun ldiff-nf (l tl) (values (ldiff-nf-with-last l tl))) (setf (get 'ldiff-nf 'cmp-inline) t) (setf (get 'ldiff-nf 'cmp-inline) t) ;(declaim (inline ldiff-nf)) (defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "ARRAY-" (string x))))) +array-types+)) #+(and pre-gcl raw-image) (defun array-offset (x) (c-array-offset x)) #+(and pre-gcl raw-image) (defmacro check-type (&rest r) nil) #+(and pre-gcl raw-image) (defmacro assert (&rest r) nil) (defun ratiop (x) (and (rationalp x) (not (integerp x)))) (defun upgraded-complex-part-type (type &optional environment) (declare (ignore environment) (optimize (safety 2))) type) (defmacro check-type-eval (place type) `(values (assert (typep ,place ,type) (,place) 'type-error :datum ,place :expected-type ,type)));fixme ;;; COERCE function. ;(defconstant +coerce-list+ '(list vector string array character short-float ; long-float float complex function null cons)) (defconstant +objnull+ (objnull)) (defun coerce (object type &aux ntype (atp (listp type)) (ctp (if atp (car type) type)) (tp (when atp (cdr type)))) (declare (optimize (safety 2))) ;(print (list 'coerce object type)) ; (check-type type (or (member function) type-spec));FIXME (case ctp (function (let ((object object)) ; (check-type object (or function (and symbol (not boolean)) (cons (member lambda) t))) (typecase object (function object) (symbol (let* ((f (c-symbol-gfdef object))(fi (address f))(m (c-symbol-mflag object))) (check-type fi (and fixnum (not (integer #.+objnull+ #.+objnull+)))) (check-type m (integer 0 0)) f)) (cons (the function (eval object)))))) ;FIXME member ((list cons vector string array member simple-array non-simple-array) (if (typep object type) object (replace (make-sequence type (length object)) object))) (character (character object)) (short-float (float object 0.0S0)) (long-float (float object 0.0L0)) (float (float object)) (complex (if (typep object type) object (let ((rtp (or (car tp) t))) (complex (coerce (realpart object) rtp) (coerce (imagpart object) rtp))))) (otherwise (cond ((typep object type) object) ((setq ntype (expand-deftype type)) (coerce object ntype)) ((check-type-eval object type)))))) (defconstant +ifb+ (- (car (last (multiple-value-list (si::heap-report)))))) (defconstant +ifr+ (ash (- +ifb+) -1)) (defconstant +ift+ (when (> #.+ifr+ 0) '(integer #.(- +ifr+) #.(1- +ifr+)))) (defun eql-is-eq (x) (typecase x (immfix t) (number nil) (otherwise t))) (setf (get 'eql-is-eq 'cmp-inline) t) ;To pevent typep/predicate loops ;(defun eql-is-eq (x) (typep x (funcall (get 'eql-is-eq-tp 'deftype-definition)))) (defun equal-is-eq (x) (typep x (funcall (macro-function (get 'equal-is-eq-tp 'deftype-definition)) nil nil)));FIXME (defun equalp-is-eq (x) (typep x (funcall (macro-function (get 'equalp-is-eq-tp 'deftype-definition)) nil nil))) (defun seqindp (x) (and (fixnump x) (>= x 0) (< x array-dimension-limit))) (si::putprop 'seqindp t 'cmp-inline) (defun standard-charp (x) (when (characterp x) (standard-char-p x))) (defun non-standard-base-char-p (x) (and (characterp x) (not (standard-char-p x)))) (defun improper-consp (s &optional (f nil fp) (z (if fp f s))) (cond ((atom z) (when fp (when z t))) ((atom (cdr z)) (when (cdr z) t)) ((eq s f)) ((improper-consp (cdr s) (cddr z))))) (defconstant most-negative-immfix (or (cadr +ift+) 1)) (defconstant most-positive-immfix (or (caddr +ift+) -1)) (defun gsym-p (x) (when x (unless (eq x t) (unless (keywordp x) (symbolp x))))) (defun sequencep (x) (or (listp x) (vectorp x))) (defun short-float-p (x) (= (c-type x) #.(c-type 0.0s0))) ; (and (floatp x) (eql x (float x 0.0s0)))) (defun long-float-p (x) (= (c-type x) #.(c-type 0.0))) ; (and (floatp x) (eql x (float x 0.0)))) (defun fcomplexp (x) (and (complexp x) (short-float-p (realpart x)) (short-float-p (imagpart x)))) (defun dcomplexp (x) (and (complexp x) (long-float-p (realpart x)) (long-float-p (imagpart x)))) (defun proper-consp (x) (and (consp x) (not (improper-consp x)))) (defun proper-listp (x) (or (null x) (proper-consp x))) (defun proper-sequencep (x) (or (vectorp x) (proper-listp x))) (defun type-list-p (spec r &aux s) (not (member-if-not (lambda (x &aux (q (member x r))) (or (when q (setq s (car q) r (cdr q)) q) (unless (eq s '&allow-other-keys) (when (typep x (if (eq s '&key) '(cons keyword (cons type-spec null)) 'type-spec)) (if (eq s '&rest) (setq s '&allow-other-keys) t))))) spec))) (defun arg-list-type-p (x) (type-list-p x '(&optional &rest &key))) (defun values-list-type-p (x) (if (when (listp x) (eq (car x) 'values)) (type-list-p (cdr x) '(&optional &rest &allow-other-keys)) (typep x 'type-spec))) (defun structurep (x) (typecase x (structure t))) (defconstant +type-alist+ '((null . null) (not-type . not) (symbol . symbolp) (eql-is-eq-tp . eql-is-eq) (equal-is-eq-tp . equal-is-eq) (equalp-is-eq-tp . equalp-is-eq) (keyword . keywordp) ;; (non-logical-pathname . non-logical-pathname-p) (logical-pathname . logical-pathname-p) (proper-cons . proper-consp) (proper-list . proper-listp) (proper-sequence . proper-sequencep) ; (non-keyword-symbol . non-keyword-symbol-p) (gsym . gsym-p) (standard-char . standard-charp) (non-standard-base-char . non-standard-base-char-p) ; (interpreted-function . interpreted-function-p) (real . realp) (float . floatp) (short-float . short-float-p) (long-float . long-float-p) (fcomplex . fcomplexp) (dcomplex . dcomplexp) (array . arrayp) (vector . vectorp) (bit-vector . bit-vector-p) (string . stringp) (complex . complexp) (ratio . ratiop) (sequence . sequencep) (atom . atom) (cons . consp) (list . listp) (seqind . seqindp) (fixnum . fixnump) (integer . integerp) (rational . rationalp) (number . numberp) (character . characterp) (package . packagep) (stream . streamp) (pathname . pathnamep) (readtable . readtablep) (hash-table . hash-table-p) (hash-table-eq . hash-table-eq-p) (hash-table-eql . hash-table-eql-p) (hash-table-equal . hash-table-equal-p) (hash-table-equalp . hash-table-equalp-p) (random-state . random-state-p) (structure . structurep) (function . functionp) (immfix . immfixp) (improper-cons . improper-consp) ;; (compiled-function . compiled-function-p) ;; (non-generic-compiled-function . non-generic-compiled-function-p) ;; (generic-function . generic-function-p) )) (dolist (l +type-alist+) (when (symbolp (cdr l)) (putprop (cdr l) (car l) 'predicate-type))) (defconstant +singleton-types+ '(null true gsym keyword standard-char non-standard-base-char package broadcast-stream concatenated-stream echo-stream file-input-stream file-output-stream file-io-stream file-probe-stream string-input-stream string-output-stream file-synonym-stream non-file-synonym-stream two-way-stream non-logical-pathname logical-pathname readtable hash-table-eq hash-table-eql hash-table-equal hash-table-equalp random-state interpreted-function non-standard-object-compiled-function spice)) (defconstant +range-types+ `(integer ratio short-float long-float)) (defconstant +complex-types+ `(integer ratio short-float long-float)) (mapc (lambda (x) (setf (get x 'cmp-inline) t)) '(lremove lremove-if lremove-if-not lremove-duplicates lreduce)) (defun lremove (q l &key (key #'identity) (test #'eql) &aux r rp (p l)) (declare (proper-list l));FIXME (mapl (lambda (x) (when (funcall test q (funcall key (car x))) (let ((y (ldiff-nf p x))) (setq rp (last (if rp (rplacd rp y) (setq r y))) p (cdr x))))) l) (cond (rp (rplacd rp p) r) (p))) (defun lremove-if (f l) (lremove f l :test 'funcall)) (defun lremove-if-not (f l) (lremove (lambda (x) (not (funcall f x))) l :test 'funcall)) (defun lremove-duplicates (l &key (test #'eql)) (lremove-if (lambda (x) (member x (setq l (cdr l)) :test test)) l)) (defun lreduce (f l &key (key #'identity) (initial-value nil ivp)) (labels ((rl (s &optional (res initial-value)(ft ivp)) (if s (rl (cdr s) (let ((k (funcall key (car s)))) (if ft (funcall f res k) k)) t) (if ft res (values (funcall f)))))) (rl l))) (defun rational (x) (declare (optimize (safety 1))) (check-type x real) (if (rationalp x) x ;too early for typecase (multiple-value-bind (i e s) (integer-decode-float x) (let ((x (if (>= e 0) (ash i e) (/ i (ash 1 (- e)))))) (if (>= s 0) x (- x)))))) (defun ordered-intersection-eq (l1 l2) (let (z zt) (do ((l l1 (cdr l))) ((not l)) (when (memq (car l) l2) (setf zt (let ((p (cons (car l) nil))) (if zt (cdr (rplacd zt p)) (setf z p)))))) z)) (defun ordered-intersection (l1 l2) (let (z zt) (do ((l l1 (cdr l))) ((not l)) (when (member (car l) l2) (setf zt (let ((p (cons (car l) nil))) (if zt (cdr (rplacd zt p)) (setf z p)))))) z)) (defun expand-array-element-type (type) (or (car (member type +array-types+ :test (lambda (x y) (unless (eq y t) (subtypep x y))))) t)) #.`(defun upgraded-array-element-type (type &optional environment) (declare (ignore environment) (optimize (safety 1))) (case type ((nil t) type) ,@(mapcar (lambda (x) `(,x type)) (cons '* (lremove t +array-types+))) (otherwise (expand-array-element-type type)))) ;; CLASS HACKS (eval-when (compile eval) (defmacro clh nil `(progn ,@(mapcar (lambda (x &aux (f (when (eq x 'find-class) `(&optional ep))) (z (intern (string-concatenate "SI-" (symbol-name x))))) `(defun ,z (o ,@f &aux e (x ',x) (fn (load-time-value nil))) (declare (notinline find-class));to enable recompile file in ansi image (setq fn (or fn (and (fboundp 'classp) (fboundp x) x))) (cond (fn (values (funcall fn o ,@(cdr f)))) ((setq e (get ',z 'early)) (values (funcall e o ,@(cdr f))))))) '(classp class-precedence-list find-class class-name class-of class-direct-subclasses)) (let (fun) (defun si-class-finalized-p (x) (unless fun (let* ((p (find-package "PCL"))(sym (when p (find-symbol "CLASS-FINALIZED-P" p)))) (when (and sym (fboundp sym) (fboundp 'classp)) (setq fun (symbol-function sym))))) (when (and fun (funcall fun x)) t))) ))) (clh) (let ((h (make-hash-table :test 'eq))) (defun si-cpl-or-nil (x) (or (gethash x h) (let ((y (when (si-class-finalized-p x) (si-class-precedence-list x)))) (when y (setf (gethash x h) y)))))) ;(defun si-cpl-or-nil (x) (when (si-class-finalized-p x) (si-class-precedence-list x))) (defun is-standard-class (object &aux (o (load-time-value nil))) (and (si-classp object) (member (or o (setq o (si-find-class 'standard-object))) (si-cpl-or-nil object)) object)) (defun find-standard-class (object) (when (symbolp object) (is-standard-class (si-find-class object nil)))) (defun coerce-to-standard-class (object) (is-standard-class (if (symbolp object) (si-find-class object nil) object))) (defun get-included (name) (cons name (mapcan 'get-included (sdata-included (get name 's-data))))) ;; 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))) (defconstant +array-typep-alist+ (mapcar (lambda (x) (cons x (mapcar (lambda (y &aux (q (intern (string-concatenate (string x) "-" (string y)))) (f (intern (string-concatenate (string q) "-SIMPLE-TYPEP-FN")))) (list* y q f)) (list* '* nil +array-types+)))) '(array simple-array non-simple-array matrix vector))) gcl-2.7.1/lsp/PaxHeaders/gcl_export.lsp0000644000000000000000000000013214774225145015043 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_export.lsp0000644000175000017500000007743714774225145014463 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :cl) (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.7.1/lsp/PaxHeaders/gcl_type.lsp0000644000000000000000000000013114774225145014502 xustar0030 mtime=1743858277.049814274 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_type.lsp0000644000175000017500000005721114774225145014107 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (export '(cmp-norm-tp tp-p cmp-unnorm-tp ; type-and type-or1 type>= type<= tp-not tp-and tp-or tp<= tp>= tp= uniq-tp tsrch uniq-sig atomic-tp tp-bnds object-tp cmpt t-to-nil returs-exactly funcallable-symbol-function infer-tp cnum creal long sharp-t-reader +useful-types-alist+ +useful-type-list+ *useful-type-tree*)) (defun sharp-t-reader (stream subchar arg) (declare (ignore subchar arg)) (let ((tp (cmp-norm-tp (read stream)))) (if (constantp tp) tp `',tp))) (set-dispatch-macro-character #\# #\t 'sharp-t-reader) (defmacro cmpt (tp) `(and (consp ,tp) (member (car ,tp) '(returns-exactly values)))) (defun t-to-nil (x) (unless (eq x t) x)) (setf (get 't-to-nil 'cmp-inline) t) (let ((f (car (resolve-type `(or (array nil) ,@(mapcar 'car +r+)))))) (unless (eq t f) (print (list "Representative types ill-defined" f)))) (progn . #.(let (y) (flet ((orthogonalize (x &aux (z y)) (setq y (car (resolve-type (list 'or x y)))) (car (resolve-type `(and ,x (not ,z)))))) (let* ((q1 (lremove nil (mapcar #'orthogonalize `((unsigned-byte 0) ,@(mapcan (lambda (n &aux (m (1- n))) (list `(unsigned-byte ,m) `(signed-byte ,n) `(unsigned-byte ,n))) '(2 4)) rnkind ,@(mapcan (lambda (n &aux (m (1- n))) (list `(unsigned-byte ,m) `(signed-byte ,n) `(unsigned-byte ,n))) '(8 16)) seqind ,@(butlast (mapcan (lambda (n &aux (m (1- n))) (list `(unsigned-byte ,m) `(signed-byte ,n) `(unsigned-byte ,n))) '(29 32 62 64))) (and bignum (integer * -1)) (and bignum (integer 0)) ,@(mapcan (lambda (x) (mapcar (lambda (y) (cons x y)) '((* (-1))(-1 -1) ((-1) (0)) (0 0) ((0) (1)) (1 1) ((1) *)))) '(ratio short-float long-float)) short-float long-float proper-cons improper-cons (vector nil) (array nil);FIXME ,@(lremove 'gsym (mapcar 'car +r+)))))) (q2 (mapcar #'orthogonalize (multiple-value-bind (x y) (ceiling (1+ (length q1)) fixnum-length) (let ((r '(gsym))) (dotimes (i (- y) r) (push `(member ,(gensym)) r))))))) (unless (eq y t) (print (list "Types ill-defined" y))) `((defconstant +btp-types1+ ',q1) (defconstant +btp-types+ ',(append q1 q2)))))));; pad to fixnum-length with gensym (defconstant +btp-length+ (length +btp-types+)) (defun make-btp (&optional (i 0)) (make-vector 'bit +btp-length+ nil nil nil 0 nil i)) (eval-when (compile eval) (defmacro mbtp-ltv nil `(load-time-value (make-btp)))) (deftype btp nil '(simple-array bit (#.+btp-length+))) (defun btp-and (x y z) (declare (btp x y z));check-type? (bit-and x y z)) (defun btp-ior (x y z) (declare (btp x y z)) (bit-ior x y z)) (defun btp-xor (x y z) (declare (btp x y z)) (bit-xor x y z)) (defun btp-andc2 (x y z) (declare (btp x y z)) (bit-andc2 x y z)) (defun btp-orc2 (x y z) (declare (btp x y z)) (bit-orc2 x y z)) (defun btp-not (x y) (declare (btp x y)) (bit-not x y)) (defvar *btps* (let ((i -1)) (mapcar (lambda (x &aux (z (make-btp))) (setf (sbit z (incf i)) 1) (list x (nprocess-type (normalize-type x)) z)) +btp-types+))) (defvar *btpa* (let ((i -1)(z (make-vector t +btp-length+ nil nil nil 0 nil nil))) (mapc (lambda (x) (setf (aref z (incf i)) x)) *btps*) z)) (defvar *k-bv* (let ((i -1)) (lreduce (lambda (xx x &aux (z (assoc (caaar (cadr x)) xx))) (unless z (push (setq z (cons (caaar (cadr x)) (make-btp))) xx)) (setf (sbit (cdr z) (incf i)) 1) xx) *btps* :initial-value nil))) (defvar *nil-tp* (make-btp)) (defvar *t-tp* (make-btp 1)) (defconstant +bit-words+ (ceiling +btp-length+ fixnum-length)) (defun copy-btp (tp &aux (n (make-btp))(ns (c-array-self n))(ts (c-array-self tp))) (dotimes (i +bit-words+ n) (*fixnum ns i t (*fixnum ts i nil nil)))) (defun btp-equal (x y &aux (xs (c-array-self x))(ys (c-array-self y)));FIXME inline? (dotimes (i +bit-words+ t) (unless (eql (*fixnum xs i nil nil) (*fixnum ys i nil nil)) (return-from btp-equal nil)))) (defun copy-tp (x m tp d) (cond (tp (list* (copy-btp x) (copy-btp m) tp (let ((a (atomic-ntp tp))) (when a (list a))))) ((unless (eql d 1) (btp-equal x *nil-tp*)) nil) ((unless (eql d -1) (btp-equal m *t-tp*)) t) ((copy-btp x)))) (defun new-tp4 (k x m d z &aux (nz (unless (eql d -1) (ntp-not z)))) (dotimes (i +btp-length+ (unless (btp-equal x m) z)) (unless (zerop (sbit k i)) (let ((a (aref *btpa* i))) (cond ((unless (eql d 1) (ntp-and?c2-nil-p (cadr a) z nil)) (setf (sbit x i) 0)) ((unless (eql d -1) (ntp-and?c2-nil-p (cadr a) nz nil)) (setf (sbit m i) 1))))))) (defun tp-mask (m1 x1 &optional m2 (x2 nil x2p) &aux (p1 (mbtp-ltv))(p2 (mbtp-ltv))) (btp-xor m1 x1 p1) (if x2p (btp-and p1 (btp-xor m2 x2 p2) p1) p1)) (defun atomic-type (tp) (when (consp tp) (case (car tp) (#.+range-types+ (let* ((d (cdr tp))(dd (cadr d))(da (car d))) (and (numberp da) (numberp dd) (eql da dd) d))) ((member eql) (let ((d (cdr tp))) (unless (cdr d) d)))))) (defun singleton-listp (x) (unless (cdr x) (unless (eq t (car x)) x))) (defun singleton-rangep (x) (when (singleton-listp x) (when (eql (caar x) (cdar x)) (car x)))) (defun singleton-kingdomp (x);sync with member-ld (case (car x) ((proper-cons improper-cons) (let ((x (cddar (singleton-listp (cdr x))))) (when (car x) x))) (#.+range-types+ (singleton-rangep (cdr x))) (null '(nil));impossible if in +btp-types+ (true (cdr x));impossible if in +btp-types+ ((structure std-instance funcallable-std-instance) (when (singleton-listp (cdr x)) (unless (listp (cadr x)) (unless (s-class-p (cadr x)) (cdr x))))) (#.(mapcar 'cdr *all-array-types*) (when (singleton-listp (cdr x)) (when (arrayp (cadr x)) (cdr x)))) (otherwise (when (singleton-listp (cdr x)) (unless (listp (cadr x)) (cdr x)))))) (defun atomic-ntp-array-dimensions (ntp) (unless (or (cadr ntp) (caddr ntp)) (when (car ntp) (lreduce (lambda (&rest xy) (when (equal (car xy) (cadr xy)) (car xy))) (car ntp) :key (lambda (x) (case (car x) (#.(mapcar 'cdr *all-array-types*) (when (singleton-listp (cdr x)) (cond ((consp (cadr x)) (unless (eq 'rank (caadr x));(improper-consp (cadr x)) (unless (member-if 'symbolp (cadr x)) (cdr x)))) ((arrayp (cadr x)) (list (array-dimensions (cadr x))))))))))))) (defun atomic-tp-array-dimensions (tp) (when (consp tp) (atomic-ntp-array-dimensions (caddr tp)))) (defun atomic-ntp-array-rank (ntp) (unless (or (cadr ntp) (caddr ntp)) (when (car ntp) (lreduce (lambda (&rest xy) (when (equal (car xy) (cadr xy)) (car xy))) (car ntp) :key (lambda (x) (case (car x) (#.(mapcar 'cdr *all-array-types*) (when (singleton-listp (cdr x)) (cond ((consp (cadr x)) (if (eq 'rank (caadr x)) (cdadr x) (unless (member-if 'symbolp (cadr x)) (length (cadr x))))) ((arrayp (cadr x)) (array-rank (cadr x)))))))))))) (defun atomic-tp-array-rank (tp) (when (consp tp) (atomic-ntp-array-rank (caddr tp)))) (defun atomic-ntp (ntp) (unless (cadr ntp) (when (singleton-listp (car ntp)) (singleton-kingdomp (caar ntp))))) (defun one-bit-btp (x &aux n) (dotimes (i +bit-words+ n) (let* ((y (*fixnum (c-array-self x) i nil nil)) . #.(let* ((m (mod +btp-length+ fixnum-length))(z (~ (<< -1 m)))) (unless (zerop m) `((y (if (< i ,(1- +bit-words+)) y (& y ,z))))))) (unless (zerop y) (let* ((l (1- (integer-length y)))(l (if (minusp y) (1+ l) l))) (if (unless n (eql y (<< 1 l))) (setq n (+ (* i fixnum-length) (end-shft l))) (return nil))))))) (defun atomic-tp (tp) (unless (or (eq tp '*) (when (listp tp) (member (car tp) '(returns-exactly values))));FIXME (unless (eq tp t) (if (listp tp) (fourth tp) (let ((i (one-bit-btp (xtp tp)))) (when i (cadr (assoc i *atomic-btp-alist*)))))))) (defun object-index (x) (etypecase x (gsym #.(1- (length +btp-types+))) . #.(let ((i -1)) (mapcar (lambda (x) `(,x ,(incf i))) +btp-types1+)))) (defvar *cmp-verbose* nil) (defvar *atomic-btp-alist* (let ((i -1)) (mapcan (lambda (x &aux (z (incf i))) (when (atomic-type x) (list (list z (cons (cadr x) (caddr x)))))) +btp-types+))) (defun object-tp1 (x) (when *cmp-verbose* (print (list 'object-type x))) (let* ((i (object-index x))(z (caddr (svref *btpa* i)))) (if (assoc i *atomic-btp-alist*) z (copy-tp z *nil-tp* (nprocess-type (normalize-type `(member ,x))) 0)))) (defvar *atomic-type-hash* (make-hash-table :test 'eql)) (defun hashable-atomp (thing &aux (pl (load-time-value (mapcar 'find-package '(:si :cl :keyword))))) (cond ((fixnump thing)) ((symbolp thing) (member (symbol-package thing) pl)))) (defun object-tp (x &aux (h (hashable-atomp x))) (multiple-value-bind (f r) (when h (gethash x *atomic-type-hash*)) (if r f (let ((z (object-tp1 x))) (when h (setf (gethash x *atomic-type-hash*) z)) z)))) (defun comp-tp0 (type &aux (z (nprocess-type (normalize-type type))) (m (mbtp-ltv))(x (mbtp-ltv))) (when *cmp-verbose* (print (list 'computing type))) (btp-xor m m m) (btp-xor x x x) (when (cadr z) (btp-not m m) (btp-not x x)) (if (caddr z) (if (cadr z) (btp-not m m) (btp-not x x)) (dolist (k (car z)) (let ((a (cdr (assoc (car k) *k-bv*)))) (if (cadr z) (btp-andc2 m a m) (btp-ior x a x))))) (copy-tp x m (new-tp4 (tp-mask m x) x m 0 z) 0)) (defvar *typep-defined* nil) (defun comp-tp (type) (if (when *typep-defined* (atomic-type type));FIXME bootstrap NULL (object-tp (car (atomic-type (normalize-type type))));e.g. FLOAT coercion (comp-tp0 type))) (defun btp-count (x &aux (j 0)) (dotimes (i +bit-words+ j) (let* ((y (*fixnum (c-array-self x) i nil nil)) (q (logcount y))) (incf j (if (minusp y) (- fixnum-length q) q))))) ;(defun btp-count (x) (count-if-not 'zerop x)) (defun btp-type2 (x &aux (z +tp-t+)) (dotimes (i +btp-length+ (ntp-not z)) (unless (zerop (sbit x i)) (setq z (ntp-and (ntp-not (cadr (aref *btpa* i))) z))))) (defun btp-type1 (x) (car (nreconstruct-type (btp-type2 x)))) (defun btp-type (x &aux (n (>= (btp-count x) #.(ash +btp-length+ -1))) (nn (mbtp-ltv))) (if n `(not ,(btp-type1 (btp-not x nn))) (btp-type1 x))) ;(defun btp-type (x) (btp-type1 x)) (defun tp-type (x) (when x (cond ((eq x t)) ((atom x) (btp-type x)) ((car (nreconstruct-type (caddr x))))))) (defun num-bnd (x) (if (listp x) (car x) x)) (defun max-bnd (x y op &aux (nx (num-bnd x)) (ny (num-bnd y))) (cond ((or (eq x '*) (eq y '*)) '*) ((eql nx ny) (if (atom x) x y)) ((funcall op nx ny) x) (y))) (defun rng-bnd2 (y x &aux (mx (car x))(xx (cdr x))(my (car y))(xy (cdr y))) (let ((rm (max-bnd mx my '<))(rx (max-bnd xx xy '>))) (cond ((and (eql rm mx) (eql rx xx)) x) ((and (eql rm my) (eql rx xy)) y) ((cons rm rx))))) (defun rng-bnd (y x) (if (cdr x) (if y (rng-bnd2 y x) x) y)) (defvar *btp-bnds* (let ((i -1)) (mapcan (lambda (x) (incf i) (when (and (member (when (listp x) (car x)) +range-types+) (caddr x));unordered `((,i ,(cons (cadr x) (caddr x)))))) +btp-types+))) (defun list-merge-sort (l pred key) (labels ((ky (x) (if key (funcall key x) x))) (let* ((ll (length l))) (if (< ll 2) l (let* ((i (ash ll -1)) (lf l) (l1 (nthcdr (1- i) l)) (rt (prog1 (cdr l1) (rplacd l1 nil))) (lf (list-merge-sort lf pred key)) (rt (list-merge-sort rt pred key))) (do (l0 l1) ((not (and lf rt)) l0) (cond ((funcall pred (ky (car rt)) (ky (car lf))) (setq l1 (if l1 (cdr (rplacd l1 rt)) (setq l0 rt)) rt (cdr rt)) (unless rt (rplacd l1 lf))) (t (setq l1 (if l1 (cdr (rplacd l1 lf)) (setq l0 lf)) lf (cdr lf)) (unless lf (rplacd l1 rt)))))))))) (defvar *btp-bnds<* (list-merge-sort (copy-list *btp-bnds*) (lambda (x y) (eq (max-bnd x y '<) x)) #'caadr)) (defvar *btp-bnds>* (list-merge-sort (copy-list *btp-bnds*) (lambda (x y) (eq (max-bnd x y '>) x)) #'cdadr)) (defun btp-bnds< (x) (dolist (l *btp-bnds<*) (unless (zerop (sbit x (car l))) (return (caadr l))))) (defun btp-bnds> (x) (dolist (l *btp-bnds>*) (unless (zerop (sbit x (car l))) (return (cdadr l))))) (defun btp-bnds (z) (let ((m (btp-bnds< z))(x (btp-bnds> z))) (when (and m x) (cons m x)))) (defun ntp-bnds (x) (lreduce (lambda (y x) (lreduce 'rng-bnd (when (member (car x) +range-types+) (if (eq (cadr x) t) (return-from ntp-bnds '(* . *)) (cdr x))) :initial-value y)) (lreduce (lambda (y z) (when (cadr x) (unless (assoc z y) (push (list z t) y))) y) +range-types+ :initial-value (car x)) :initial-value nil)) (defun tp-bnds (x) (when x (if (eq x t) '(* . *) (if (atom x) (btp-bnds x) (ntp-bnds (caddr x)))))) (defun xtp (tp) (if (listp tp) (car tp) tp)) (setf (get 'xtp 'cmp-inline) t) (defun mtp (tp) (if (listp tp) (cadr tp) tp)) (setf (get 'mtp 'cmp-inline) t) (defun ntp-op (op t1 t2) (ecase op (and (ntp-and t1 t2)) (or (ntp-or t1 t2)))) (defun min-btp-type2 (x) (if (< (btp-count x) #.(ash +btp-length+ -1)) (btp-type2 x) (ntp-not (btp-type2 (btp-not x x))))) (defun new-tp1 (op t1 t2 xp mp &aux (tmp (mbtp-ltv))) (cond ((atom t1) (unless (btp-equal xp mp) (if (eq op 'and) (ntp-and (caddr t2) (min-btp-type2 (btp-orc2 t1 (xtp t2) tmp))) (ntp-or (caddr t2) (min-btp-type2 (btp-andc2 t1 (mtp t2) tmp)))))) ((atom t2) (new-tp1 op t2 t1 xp mp)) ((new-tp4 (tp-mask (pop t1) (pop t1) (pop t2) (pop t2)) xp mp (if (eq op 'and) -1 1) (ntp-op op (car t1) (car t2)))))) (defun cmp-tp-and (t1 t2 &aux (xp (mbtp-ltv))(mp (mbtp-ltv))) (btp-and (xtp t1) (xtp t2) xp) (cond ((when (atom t1) (btp-equal xp (xtp t2))) t2) ((when (atom t2) (btp-equal xp (xtp t1))) t1) ((and (atom t1) (atom t2)) (copy-tp xp xp nil -1)) ((btp-and (mtp t1) (mtp t2) mp) (cond ((when (atom t1) (btp-equal mp t1)) t1) ((when (atom t2) (btp-equal mp t2)) t2) ((copy-tp xp mp (new-tp1 'and t1 t2 xp mp) -1)))))) (defun tp-and (t1 t2) (when (and t1 t2) (cond ((eq t1 t) t2)((eq t2 t) t1) ((cmp-tp-and t1 t2))))) (defun cmp-tp-or (t1 t2 &aux (xp (mbtp-ltv))(mp (mbtp-ltv))) (btp-ior (mtp t1) (mtp t2) mp) (cond ((when (atom t1) (btp-equal mp (mtp t2))) t2) ((when (atom t2) (btp-equal mp (mtp t1))) t1) ((and (atom t1) (atom t2)) (copy-tp mp mp nil 1)) ((btp-ior (xtp t1) (xtp t2) xp) (cond ((when (atom t1) (btp-equal xp t1)) t1) ((when (atom t2) (btp-equal xp t2)) t2) ((copy-tp xp mp (new-tp1 'or t1 t2 xp mp) 1)))))) (defun tp-or (t1 t2) (cond ((eq t1 t)) ((eq t2 t)) ((not t1) t2) ((not t2) t1) ((cmp-tp-or t1 t2)))) (defun cmp-tp-not (tp) (if (atom tp) (btp-not tp (make-btp)) (list (btp-not (cadr tp) (make-btp)) (btp-not (car tp) (make-btp)) (ntp-not (caddr tp))))) (defun tp-not (tp) (unless (eq tp t) (or (not tp) (cmp-tp-not tp)))) (defun tp<= (t1 t2 &aux (p1 (mbtp-ltv))(p2 (mbtp-ltv))) (cond ((eq t2 t)) ((not t1)) ((or (not t2) (eq t1 t)) nil) ((btp-equal *nil-tp* (btp-andc2 (xtp t1) (mtp t2) p1))) ((btp-equal *nil-tp* (btp-andc2 p1 (btp-andc2 (xtp t2) (mtp t1) p2) p1)) (ntp-subtp (caddr t1) (caddr t2))))) (defun tp>= (t1 t2) (tp<= t2 t1)) (defun tp= (t1 t2);(when (tp<= t1 t2) (tp<= t2 t1))) (cond ((or (if t1 (eq t1 t) t) (if t2 (eq t2 t) t)) (eq t1 t2)) ((and (atom t1) (atom t2)) (btp-equal t1 t2)) ((or (atom t1) (atom t2)) nil) ((and (btp-equal (car t1) (car t2)) (btp-equal (cadr t1) (cadr t2)) (ntp-subtp (caddr t1) (caddr t2)) (ntp-subtp (caddr t2) (caddr t1)))))) (defun tp-p (x) (or (null x) (eq x t) (bit-vector-p x) (when (listp x) (and (bit-vector-p (car x)) (bit-vector-p (cadr x)) (consp (caddr x))))));FIXME (defvar *nrm-hash* (make-hash-table :test 'eq)) (defvar *unnrm-hash* (make-hash-table :test 'eq)) (defvar *uniq-hash* (make-hash-table :test 'equal));FIXME type=? (defvar *intindiv-hash* (make-hash-table :test 'equal)) (defun uniq-integer-individuals-type (type) (let ((type `(,(car type) ,@(list-merge-sort (copy-list (cdr type)) #'< nil)))) (or (gethash type *intindiv-hash*) (setf (gethash type *intindiv-hash*) type)))) (defun hashable-typep (x) (or (when (symbolp x) (unless (is-standard-class (si-find-class x nil)) (let ((z (get x 's-data))) (if z (when (s-data-frozen z) x) x)))) (when (listp x) (when (eq (car x) 'member) (unless (member-if-not 'integerp (cdr x)) (uniq-integer-individuals-type x)))))) (defun comp-tp1 (x &aux (s (hashable-typep x))) (multiple-value-bind (r f) (when s (gethash s *nrm-hash*)) (if f r (let* ((y (comp-tp x))) (when (and s (unless (eq y t) y)) (setq y (or (gethash y *uniq-hash*) (setf (gethash y *uniq-hash*) y))) (unless (gethash y *unnrm-hash*) (setf (gethash y *unnrm-hash*) s));e.g. first (setf (gethash s *nrm-hash*) y)) y)))) (defun cmp-norm-tp (x) (cond ((if x (eq x t) t) x) ((eq x '*) x) ((when (listp x) (case (car x) ((returns-exactly values) (cons (car x) (mapcar 'cmp-norm-tp (cdr x)))))));FIXME ((comp-tp1 x)))) (defun tp-type1 (x) (multiple-value-bind (r f) (gethash x *unnrm-hash*) (if f r (multiple-value-bind (r f) (gethash (gethash x *uniq-hash*) *unnrm-hash*) (if f r (tp-type x)))))) (defun cmp-unnorm-tp (x) (cond ((tp-p x) (tp-type1 x)) ((when (listp x) (case (car x) ((not returns-exactly values) (cons (car x) (mapcar 'cmp-unnorm-tp (cdr x))))))) (x))) (defconstant +rn+ '#.(mapcar (lambda (x) (cons (cmp-norm-tp (car x)) (cadr x))) +r+)) (defconstant +tfns1+ '(tp0 tp1 tp2 tp3 tp4 tp5 tp6 tp7 tp8)) (defconstant +rs+ (mapcar (lambda (x) (cons x (mapcar (lambda (y) (cons (car y) (funcall x (eval (cdr y))))) +rn+))) +tfns1+)) (defconstant +kt+ (mapcar 'car +rn+)) (defun tps-ints (a rl) (lremove-duplicates (mapcar (lambda (x) (cdr (assoc (cadr x) rl))) a))) (defun ints-tps (a rl) (lreduce (lambda (y x) (if (member (cdr x) a) (tp-or y (car x)) y)) rl :initial-value nil)) (eval-when (compile eval) (defun msym (x) (intern (string-concatenate (string x) "-TYPE-PROPAGATOR") :si))) (defconstant +ktn+ (mapcar (lambda (x) (cons x (tp-not x))) +kt+)) (defun decidable-type-p (x) (or (atom x) (not (third (third x))))) (defun type-and-list (tps) (mapcan (lambda (x &aux (q x)) (mapcan (lambda (y) (unless (tp<= q (cdr y)) `((,x ,(car y) ,(cond ((tp<= (car y) x) (car y)) ((let ((x (tp-and (car y) x))) (when (decidable-type-p x) x))) (x)))))) +ktn+)) tps)) (defconstant +rq1+ (mapcar (lambda (x) (cons (pop x) (lreduce (lambda (y x &aux (nx (tp-not (car x)))) (let ((z (rassoc (cdr x) y))) (if z (setf (car z) (tp-and nx (car z)) y y) (cons (cons nx (cdr x)) y)))) x :initial-value nil))) +rs+)) (defun norm-tp-ints (tp rl) (cmp-norm-tp (cons 'member (lreduce (lambda (y x) (if (tp<= tp (car x)) y (cons (cdr x) y))) rl :initial-value nil)))) (progn;FIXME macrolet norm-tp-ints can only compile-file, not compile . #.(mapcar (lambda (x &aux (s (msym x))) `(let* ((rl (cdr (assoc ',x +rq1+)))) (defun ,s (f x) (declare (ignore f)) (norm-tp-ints x rl)) (setf (get ',x 'type-propagator) ',s) (setf (get ',x 'c1no-side-effects) t))) +tfns1+)) (defun best-type-of (c) (let* ((r (lreduce 'set-difference c :key 'car :initial-value +kt+)) (tps (nconc (mapcar 'car c) (list r))) (rs +rs+)) (declare (special rs));FIXME to prevent unroll of +rs+ (or (caar (member-if (lambda (x) (let* ((x (cdr x)) (z (mapcan (lambda (y) (lremove-duplicates (mapcar (lambda (z) (cdr (assoc z x))) y))) tps))) (eq z (lremove-duplicates z)))) rs)) (caar rs)))) (defun calist2 (a) (lreduce (lambda (y x &aux (z (rassoc (cdr x) y :test 'equal)));;aggregate identical subtypes, e.g. undecidable (if z (setf (car z) (cons (caar x) (car z)) y y) (setf y (cons x y)))) (mapcar (lambda (x) (cons (list x);; collect specified types intersecting with this tps (mapcan (lambda (y &aux (q (caddr y))) (when (eq x (cadr y)) (list (cons (car y) (unless (eq q x) q)))));;only subtypes smaller than tps a))) (lreduce (lambda (y x) (adjoin (cadr x) y)) a :initial-value nil));;unique tps :initial-value nil)) (defconstant +useful-type-list+ `(nil null boolean keyword symbol proper-cons cons proper-list list simple-vector simple-string simple-bit-vector string vector array proper-sequence sequence zero one bit rnkind non-negative-char unsigned-char signed-char non-negative-short unsigned-short signed-short seqind seqbnd non-negative-immfix immfix non-negative-fixnum non-negative-bignum non-negative-integer tractable-fixnum fixnum bignum integer rational negative-short-float positive-short-float non-negative-short-float non-positive-short-float short-float negative-long-float positive-long-float non-negative-long-float non-positive-long-float long-float negative-float positive-float non-negative-float non-positive-float float negative-real positive-real non-negative-real non-positive-real real fcomplex dcomplex complex-integer complex-ratio complex-ratio-integer complex-integer-ratio complex number character structure package hash-table function t)) ;; (defconstant +useful-types+ (mapcar 'cmp-norm-tp +useful-type-list+)) (defconstant +useful-types-alist+ (mapcar (lambda (x) (cons x (cmp-norm-tp x))) +useful-type-list+)) (defvar *useful-type-tree* (labels ((cons-count (f) (cond ((atom f) 0) ((+ 1 (cons-count (car f)) (cons-count (cdr f)))))) (group-useful-types (tp y) (cons tp (list-merge-sort (mapcar (lambda (z) (group-useful-types (car z) (cdr z))) (lreduce (lambda (y x) (if (member-if (lambda (z) (member (car x) (cdr z))) y) y (cons x y))) (list-merge-sort (mapcar (lambda (z) (cons z (lremove z (lremove-if-not (lambda (x) (tp>= z x)) y)))) y) #'> #'length) :initial-value nil)) #'> #'cons-count)))) (cdr (group-useful-types t (mapcan (lambda (x &aux (x (cdr x))) (when x (unless (eq x t) (list x)))) +useful-types-alist+))))) (defun tsrch (tp &optional (y *useful-type-tree*)) (let ((x (member tp y :test 'tp<= :key 'car))) (when x (or (tsrch tp (cdar x)) (caar x))))) (defvar *uniq-tp* (make-hash-table :test 'eq)) (defun uniq-tp (tp) (when tp (or (eq tp t) (let ((x (or (tsrch tp) t))) (if (tp<= x tp) x (let ((y (gethash x *uniq-tp*))) (car (or (member tp y :test 'tp=) (setf (gethash x *uniq-tp*) (cons tp y)))))))))) (defvar *uniq-sig* (make-hash-table :test 'equal)) (defun uniq-sig (sig) (let ((x (list (mapcar (lambda (x) (if (eq x '*) x (uniq-tp x))) (car sig)) (cond ((cmpt (cadr sig)) (cons (caadr sig) (mapcar 'uniq-tp (cdadr sig)))) ((eq (cadr sig) '*) (cadr sig)) ((uniq-tp (cadr sig))))))) (or (gethash x *uniq-sig*) (setf (gethash x *uniq-sig*) x)))) (defun sig= (s1 s2) (labels ((s= (l1 l2) (and (eql (length l1) (length l2)) (every (lambda (x y) (or (eq x y) (unless (or (symbolp x) (symbolp y)) (tp= x y)))) l1 l2)))) (or (eq s1 s2) (and (s= (car s1) (car s2)) (if (or (cmpt (cadr s1)) (cmpt (cadr s2))) (and (cmpt (cadr s1)) (cmpt (cadr s2)) (s= (cadr s1) (cadr s2))) (s= (cdr s1) (cdr s2))))))) gcl-2.7.1/lsp/PaxHeaders/gcl_sloop.lsp0000644000000000000000000000013114774225145014655 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_sloop.lsp0000644000175000017500000012122014774225145014252 0ustar00cammcamm;;; -*- Mode:LISP; Package:(SLOOP LISP);Syntax:COMMON-LISP;Base:10 -*- ;;;;; ;;; ;;;;; ;;; Copyright (c) 1985,86 by William Schelter, ;;;;; ;;; Copyright (c) 2024 Camm Maguire ;;; 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 sloop-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) (sloop-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))))) (sloop-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.7.1/lsp/PaxHeaders/gcl_logical_pathname_translations.lsp0000644000000000000000000000013114774225145021611 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_logical_pathname_translations.lsp0000644000175000017500000000172214774225145021212 0ustar00cammcamm(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.7.1/lsp/PaxHeaders/gcl_defmacro.lsp0000644000000000000000000000013214774225145015302 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.344938378 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_defmacro.lsp0000644000175000017500000003054514774225145014707 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :lisp) ;; (export '(lambda defvar import &whole &environment &body)) (in-package :system) ;;; 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-nf vl env-m) (cddr env-m))))) (values vl env))) (defun gensym (&optional (x nil xp)) (cond ((not xp) (gensym0)) ((stringp x) (gensym1s x)) ((gensym1ig x)))) (let* ((gsyms (mapl #'(lambda (x) (setf (car x) (gensym))) (make-list 100)))(syms gsyms)) (defun tsym (&optional r) (cond (r (setq syms gsyms) nil) ((or (pop syms) (gensym)))))); FIXME print? (error 'program-error :format-control "Out of symbols when binding lambda list" :format-arguments nil) (defun unbnd (k l &aux (lc (when (or (eq k '&optional) (eq k '&key)) (consp l))) (ln (if lc (pop l) l)) (ld (when lc (pop l))) (lp (when lc (car l))) (lc (when (eq k '&key) (consp ln))) (lnn (if lc (pop ln) ln)) (lb (if lc (car ln) ln))) (values lnn lb ld lp)) (defun make-state (n nr f a last) (list (list n nr f) a last nil nil nil)) (defun n (s) (caar s)) (defun nr (s) (cadar s)) (defun fst (s) (caddar s)) (defun a (s) (cadr s)) (defun set-a (s v) (setf (cadr s) v)) (defun pop-a (s) (pop (cadr s))) (defun lst (s) (caddr s)) (defun np (s) (cadddr s)) (defun set-np (s v &aux (s (cdddr s))) (setf (car s) v)) (defun lv (s) (fifth s)) (defun set-lv (s v &aux (s (cddddr s))) (setf (car s) v)) (defun r (s) (sixth s)) (defun push-r (s v &aux (s (cdr (cddddr s)))) (setf (car s) (cons v (car s)))) (defun nreconc-r (s v &aux (s (cdr (cddddr s)))) (setf (car s) (nreconc v (car s)))) (*make-special '*rv*) (*make-constant '+kev+ (gensym "KE")) (*make-constant '+np+ (gensym "NP")) (*make-constant '+negp+ (gensym "NEGP")) (*make-constant '+ff+ (gensym "FF")) (*make-constant '+lvpv+ (gensym "LVP")) (setq *rv* nil) (defun rpop (s rv negp &aux (np (np s))) `(do (vp val (lv ,(lv s)));FIXME just to use previous lv binding ((>= 0 ,np) lv) (declare (proper-list val) ,@(when (cdr rv) `((dynamic-extent val)))) (setq val ,(vp s) val (if (and ,negp (= ,np 0)) val (cons val nil)) vp (cond (vp (rplacd vp val) val) ((setq lv val)))))) (defun bind (s targ &optional (src nil srcp) defp &aux (sp (when (listp targ) srcp)) (v (if sp (tsym) targ))) (push-r s (if srcp (list v (if defp (na s src) src)) v)) (when sp (nreconc-r s (cadr (blla targ nil v nil nil nil nil t)))) v) (defun badll (x) (error 'program-error :format-control "Bad lambda list ~s" :format-arguments (list x))) (defun insuf (x) `(error 'program-error :format-control "Insufficient arguments when binding ~s" :format-arguments (list ',x))) (defun extra (x) `(error 'program-error :format-control "Extra argument ~s" :format-arguments (list ,x))) (defun nokv (x) `(error 'program-error :format-control "Key ~s missing value" :format-arguments (list ,x))) (defun badk (x v) `(error 'program-error :format-control "Key ~s ~s not permitted" :format-arguments (list ,x ,v))) (defun wcr (x) (when (cdr x) x)) (defun vp (s &aux (v `(va-pop))(np (np s))(f (fst s))) `(progn (setq ,np (number-minus ,np 1)) ,(if f `(cond (,+ff+ (setq ,+ff+ nil) ,f)(,v)) v))) (defun la (s def &optional k p &aux (v (lvp s))(vp (vp s))(np (np s))) (wcr `(cond ,@(when np `(((and ,+negp+ (= ,np 1) (setq ,v ,vp) ,@(unless p `(nil))))));FIXME efficiency ,@(when np `(((> ,np 0) ,@(unless p `(,vp))))) ,@(when v `((,v ,@(unless p `((pop ,v)))))) ,@(when def `((,def))) ,@(when k `((,(nokv k))))))) (defun na (s &optional def) (if (a s) (pop-a s) (la s def))) (defun nap (s) (if (a s) t (la s nil nil t))) (defun bind-a (s) (set-a s (mapcar #'(lambda (x) (bind s (tsym) x)) (a s)))) (defun lvp (s &optional rv) (cond (rv (lvp s) (if (np s) (bind s (lv s) (rpop s rv +negp+)) (lv s))) ((lv s)) ((lst s) (bind s (set-lv s (tsym)) (lst s)));+lvpv+ ((n s) (when (fst s) (bind s +ff+ t)) (bind s (set-np s +np+) (n s)) (bind s +negp+ `(< ,(np s) 0)) (bind s (np s) `(if ,+negp+ (number-minus 0 ,(np s)) ,(np s))) (bind s (np s) `(number-minus ,(np s) ,(nr s))) (bind s (set-lv s (tsym))))));+lvpv+ (defun post (s post nkys &aux (nkys (nreverse nkys))) (do ((ex (a s))) ((not ex));FIXME this is fragile as the binding must be visible to mvars/inls (bind s 'k (pop ex)) (bind s 'v (if ex (pop ex) (la s nil 'k))) (bind s +kev+ `(case k ,@nkys))) (cond ((n s) (bind s +kev+ `(do (k v) ((not ,(nap s))) (setq k ,(la s nil) v ,(la s nil 'k)) (case k ,@nkys)))) ((lvp s) (bind s +kev+ `(labels ((kb (k v) (case k ,@nkys)) (kbb (x) (when x (kb (car x) (if (cdr x) (cadr x) ,(nokv '(car x))))(kbb (cddr x))))) (kbb ,(lv s)))))) (mapc #'(lambda (x) (apply 'bind s x)) (nreverse post))) (defun sdde (rv decls) (mapc #'(lambda (decl) (mapc #'(lambda (clause) (case (pop clause) ((dynamic-extent :dynamic-extent) (when (member rv clause) (return-from sdde t))))) (cdr decl))) decls) nil) (defun blla (l a last body &optional n nr f (rcr (tsym t)) &aux rvd kk *rv* k tmp nkys post aux wv rv aok kev (s (make-state n nr f a last)) (l (subst '&rest '&body (let ((s (last l))) (if (cdr s) (append (butlast l) (list (car s) '&rest (cdr s))) l))));FIXME only macro + recursion (lo l)(llk '(&whole &optional &rest &key &allow-other-keys &aux))) (declare (optimize (safety 0))(ignore rcr)) ; (assert (not (and last n))) (multiple-value-bind (doc decls ctps body) (parse-body-header body) (declare (ignore doc)) (do ((l l)(lk llk))((not l)) (cond ((setq tmp (member (car l) lk)) (setq lk (cdr tmp) k (pop l) kk (if (eq k '&aux) kk k))) ((member (car l) llk) (badll lo)) ((case k (&whole (when (or wv (not (eq (cdr lo) l))) (badll lo)) (setq k nil) (bind s (setq wv (pop l)) (append a last))) ((nil &optional) (multiple-value-bind (ln lb ld lp) (unbnd k (pop l)) (declare (ignore lb)) (when lp (bind s lp t)) (let ((ld (if k ld (insuf ln)))) (bind s ln (if lp `(progn (setq ,lp nil) ,ld) ld) t)))) (&rest (when rv (badll lo)) (bind s (setq rv (pop l)) `(list* ,@(bind-a s) ,(lvp s (cons rv (setq rvd (sdde rv decls))))))) (&key (multiple-value-bind (ln lb ld lp) (unbnd k (pop l)) (let* ((lpt (tsym))(lbt (tsym))(ln (intern (string ln) 'keyword))) (when (eq ln :allow-other-keys) (setq aok lbt)) (bind s lpt)(bind s lbt) (push `(,ln (unless ,lpt (setq ,lbt v ,lpt t))) nkys) (push `(,lb (if ,lpt ,lbt ,ld)) post) (when lp (push `(,lp ,lpt) post))))) (&aux (setq aux l l nil)))))) (let ((nap (nap s))) (when nap (case kk ((nil &optional) (unless n (bind s +kev+ (let ((q (extra (na s)))) (if (eq nap t) q `(when ,nap ,q)))))) (&allow-other-keys (bind s +kev+ nap)) (&key (unless aok (let ((aop (tsym))) (bind s aop)(bind s (setq aok (tsym))) (push `(:allow-other-keys (unless ,aop (setq ,aok v ,aop t))) nkys))) (let ((lpt (tsym))(lbt (tsym))(bk (tsym))) (bind s lpt)(bind s lbt)(bind s bk) (push `(otherwise (unless ,lpt (setq ,lbt v ,lpt t ,bk k))) nkys) (push `(,+kev+ (unless ,aok (when ,lpt ,(badk bk lbt)))) post)))))) (when post (post s post nkys)) (setq kev (member +kev+ (r s) :key #'(lambda (x) (when (listp x) (car x))))) `(let* ,(nreconc (r s) aux) ,@(when rvd (when (lv s) `((declare (dynamic-extent ,(lv s)))))) ,@(when kev `((declare (ignore ,+kev+)))) ,@decls ,@ctps ,@body))) (export '(blocked-body-name parse-body-header blla va-pop)) (defun parse-body-header (x &optional doc decl ctps &aux (a (car x))) (declare (proper-list x));FIXME (cond ((unless (or doc ctps) (and (stringp a) (cdr x))) (parse-body-header (cdr x) a decl ctps)) ((unless ctps (when (consp a) (eq (car a) 'declare))) (parse-body-header (cdr x) doc (cons a decl) ctps)) ((when (consp a) (member (car a) '(check-type assert))) (parse-body-header (cdr x) doc decl (cons a ctps))) (t (values doc (nreverse decl) (nreverse ctps) x)))) (defun make-blocked-lambda (ll decls ctps body block) (let ((body (if (eq block (blocked-body-name body)) body `((block ,block ,@body))))) `(lambda ,ll ,@decls ,@ctps ,@body))) (defun blocked-body-name (body) (when (and (not (cdr body)) (consp (car body)) (eq (caar body) 'block)) (cadar body))) (defun block-body (name body ignore) (multiple-value-bind (doc decls ctps body) (parse-body-header body) `(,@(when doc `(,doc)) ,@decls ,@(when ignore `((declare (ignore ,ignore)))) ,@ctps ,@(if (eq name (blocked-body-name body)) body `((block ,name ,@body)))))) (defun defmacro-lambda (name vl body &aux n e (w (eq '&whole (car vl)))) (multiple-value-bind (vl env) (get-&environment vl) `(lambda (l ,(or env (setq e (gensym)))) ,@(unless env `((declare (ignore ,e)))) ,(blla (if w (list (list* (pop vl) (pop vl) (setq n (gensym)) vl)) vl) nil (if w `(list l) `(cdr l)) (block-body name body n))))) (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)))))))) (defmacro symbol-to-function (sym) (let* ((n (gensym)) (gf (find-symbol "C-SYMBOL-GFDEF" (find-package :cstruct)))) `(when (symbolp ,sym) ,(if (fboundp gf) `(let ((,n (address (,gf ,sym)))) (unless (= +objnull+ ,n) (nani ,n))) `(let* ((,n (when (fboundp ,sym) (symbol-function ,sym))) (,n (if (and (consp ,n) (eq (car ,n) 'macro)) (cdr ,n) ,n))) (unless (consp ,n) ,n)))))) (defmacro call (sym &optional f &rest keys) ;FIXME macro (let* ((fnf (gensym))(n (gensym))) `(let* ((,fnf (if (functionp ,sym) ,sym (symbol-to-function ,sym))));(coerce ,sym 'function) (or (when ,fnf (cfun-call ,fnf)) (when ,f (let ((,n (make-call ,@keys))) (when ,fnf (set-cfun-call ,n ,fnf)) ,n)))))) gcl-2.7.1/lsp/PaxHeaders/gcl_callhash.lsp0000644000000000000000000000013214776006046015300 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.294035039 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_callhash.lsp0000644000175000017500000002736414776006046014712 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;; -*-Lisp-*- (in-package :si);FIXME this belongs in :compiler (export '(*split-files* *sig-discovery* compress-fle)) (defstruct (call (:type list) (:constructor make-call)) sig callees src file props name) (defvar *cmr* nil) (defvar *keep-state* nil) (defvar *sig-discovery* nil) (defvar *split-files* nil) (defun break-state (sym x) (format t "Breaking state function ~s due to definition of ~s~%" x sym) (let ((o (old-src x))) (mapc (lambda (x) (remprop x 'state-function)) (car o)) (mapc (lambda (x y) (unless (eq sym x) (eval `(defun ,x ,@(cdr y))))) (car o) (cadr o)) (mapc (lambda (y) (push y *cmr*) (add-recompile y 'state-function (sig x) nil)) (car o)) (fmakunbound x) (unintern x))) (defconstant +et+ (mapcar (lambda (x) (cons (cmp-norm-tp x) x)) '(list cons proper-list proper-sequence sequence boolean null true array vector number immfix bfix bignum integer function-designator ratio short-float long-float float real number pathname hash-table function))) (defvar *sig-discovery-props* nil) (defun symbol-function-plist (sym &aux (fun (symbol-to-function sym))) (when fun (c-function-plist fun))) (defun sym-plist (sym &aux (pl (symbol-function-plist sym))) (when pl (or (cdr (assoc sym *sig-discovery-props*)) pl))) (defun needs-recompile (sym) (let* ((plist (sym-plist sym)) (callees (cadr plist))) (mapc (lambda (x &aux (s (car x)) (cmp-sig (cdr x))(act-sig (car (sym-plist s)))) (unless (eq sym s) (when act-sig (unless (sig= cmp-sig act-sig);Can be sig= if we don't hash, or eq (return-from needs-recompile (list (list sym s cmp-sig act-sig))))))) callees) nil)) (defun all-conflicts (&aux r q) (do-all-symbols (sym (sort q (lambda (x y) (cond ((member (caar x) (cadr y)) 1) ((member (caar y) (cadr x)) -1) (0))))) (let* ((plist (sym-plist sym))(callees (cadr plist))) (mapc (lambda (x &aux (s (car x)) (cmp-sig (cdr x))(act-sig (car (sym-plist s)))) (unless (eq sym s) (when act-sig (unless (sig= cmp-sig act-sig);Can be sig= if we don't hash, or eq (pushnew sym (cadar (pushnew (list (car (pushnew (list s cmp-sig act-sig) r :test 'equal)) nil) q :key 'car :test 'equal))))))) callees) nil))) (defun same-file-all-callees (x y fn) ; (let ((z (remove-if-not (lambda (x) (equal (file x) fn)) (callees x)))) ;FIXME remove inline (let (z) (dolist (l (callees x)) (when (equal fn (file l));FIXME eq (push l z))) (do ((l (set-difference z y) (cdr l)) (r (union z y) (same-file-all-callees (car l) r fn))) ((endp l) r)))) (defun same-file-all-callers (x y fn) ; (let ((z (remove-if-not (lambda (x) (equal (file x) fn)) (callers x))));FIXME remove inline (let (z) (dolist (l (callers x)) (when (equal fn (file l));FIXME eq (push l z))) (do ((l (set-difference z y) (cdr l)) (r (union z y) (same-file-all-callers (car l) r fn))) ((endp l) r)))) ;; (defun all-callees (x y) ;; (let ((z (gethash x *ach*))) ;; (if z (union z y) ;; (let ((z (call-callees (gethash x *call-hash-table*)))) ;; (do ((l (set-difference z y) (cdr l)) ;; (r (union z y) (all-callees (car l) r))) ;; ((endp l) ;; (unless (intersection z y) (setf (gethash x *ach*) (set-difference r y))) ;; r)))))) ;; (defun all-callers (x y) ;; (let ((z (gethash x *acr*))) ;; (if z (union z y) ;; (let ((z (call-callers (gethash x *call-hash-table*)))) ;; (do ((l (set-difference z y) (cdr l)) ;; (r (union z y) (all-callers (car l) r))) ;; ((endp l) ;; (unless (intersection z y) (setf (gethash x *acr*) (set-difference r y))) ;; r)))))) (defun nsyms (n &optional syms) (declare (seqind n)) (cond ((= n 0) (nreverse syms)) ((nsyms (1- n) (cons (gensym) syms))))) (defun max-types (sigs &optional res) (cond ((not res) (max-types (cdr sigs) (ldiff-nf (caar sigs) (member '* (caar sigs))))) ((not sigs) res) ((max-types (cdr sigs) (let ((z (ldiff-nf (caar sigs) (member '* (caar sigs))))) (append (mapcar (lambda (x y) (or (not (equal x y)) x)) z res) (early-nthcdr (length z) res))))))) (defun early-nthcdr (i x) (declare (seqind i)) (cond ((= 0 i) x) ((early-nthcdr (1- i) (cdr x))))) (defun old-src (stfn &optional src syms sts srcs) (cond (stfn (old-src nil (function-src stfn) syms sts srcs)) ((atom src) nil) ((eq (car src) 'labels) (list (mapcar 'car (cadr src)) (mapcar (lambda (x) (if (eq (caadr x) 'funcall) (cadadr x) (caadr x))) (cddr (caddr src))))) ((or (old-src stfn (car src) syms sts srcs) (old-src stfn (cdr src) syms sts srcs))))) (defun lambda-vars (ll) (remove '&optional (mapcar (lambda (x) (if (consp x) (car x) x)) ll))) (defun inlinef (n syms sts fns) (unless (member-if (lambda (x) (intersection '(&rest &key &aux &allow-other-keys) (cadr x))) fns) (let* ((lsst (1- (length sts))) (tps (max-types (mapcar 'sig syms))) (min (reduce 'min (mapcar (lambda (x) (length (ldiff-nf (cadr x) (member '&optional (cadr x))))) fns) :initial-value 64));FIXME (max (reduce 'max (mapcar (lambda (x) (length (lambda-vars (cadr x)))) fns) :initial-value 0)) (reqs (nsyms min)) (opts (nsyms (- max min))) (ll (append reqs (when (> max min) (cons '&optional opts)))) (all (reverse (append reqs opts)))) `(defun ,n ,(cons 'state ll) (declare (fixnum state) ,@(mapcar 'list tps reqs)) ,@(let (d (z (cddr (car fns)))) (when (stringp (car z)) (pop z)) (do nil ((or (not z) (not (consp (car z))) (not (eq (caar z) 'declare))) (nreverse d)) (let ((q (pop z))) (when (and (consp (cadr q)) (eq 'optimize (caadr q))) (push q d))))) (labels ,(mapcan (lambda (x y z) `((,x ,(cadr y) (,n ,z ,@(lambda-vars (cadr y)))))) syms fns sts) (case state ,@(mapcar (lambda (x y) `(,(if (= x lsst) 'otherwise x) (funcall ,y ,@(reverse (early-nthcdr (- max (length (lambda-vars (cadr y)))) all))))) sts fns))))))) (defun sig (x) (let ((h (call x))) (when h (call-sig h)))) (defun signature (x) (readable-sig (sig x))) (defun props (x) (let ((h (call x))) (when h (call-props h)))) (defun src (x) (let ((h (call x))) (when h (call-src h)))) (defun file (x) (let ((h (call x))) (when h (call-file h)))) ;; (defun file (x) (let* ((f (if (functionp x) x (symbol-to-function x))) ;; (d (when f (address (c-function-data f))))) ;; (when d ;; (unless (eql d +objnull+) ;; (c-cfdata-name (nani d)))))) (defun name (x) (let ((h (call x))) (when h (call-name h)))) (defun callees (x) (let ((h (call x))) (when h (call-callees h)))) ;(defun callers (x) (get x 'callers)) ;; (defun *s (x) ;; (let ((p (find-package x))) ;; (remove-if-not ;; (lambda (y) (eq (symbol-package y) p)) ;; (let (r) ;; (maphash (lambda (x y) (when (eq '* (cadr (call-sig y))) (push x r))) *call-hash-table*) ;; r)))) (defun mutual-recursion-peers (sym) (unless (or (get sym 'state-function) (get sym 'mutual-recursion-group)) (let ((y (sig sym))) (when (eq '* (cadr y)) (let ((e (same-file-all-callees sym nil (file sym))) (r (same-file-all-callers sym nil (file sym)))) (remove-if-not (lambda (x) (and (eq (symbol-package x) (symbol-package sym)) (let ((h (call x))) (when h (eq '* (cadr (call-sig h))))))) (intersection e r))))))) ;(defun mutual-recursion-peers (sym) ; (unless (or (get sym 'state-function) (get sym 'mutual-recursion-group)) ; (let ((y (sig sym))) ; (when (eq '* (cadr y)) ; (let* ((e (same-file-all-callees sym nil (file sym))) ; (r (same-file-all-callers sym nil (file sym))) ; (i (intersection e r)) ; (i1 (remove-if-not (lambda (x) (get x 'mutual-recursion-group)) i)) ; (i2 (set-difference i i1)) ; (i (remove-duplicates (union (mapcan (lambda (x) (list (get x 'mutual-recursion-group))) i1) i2)))) ; (mapc (lambda (x) (break-state x x)) i1) ; (remove-if-not (lambda (x) (eq '* (cadr (sig x)))) i)))))) ; (remove-if (lambda (x) (get x 'mutual-recursion-group)) ; (remove-if-not (lambda (x) (eq '* (cadr (sig x)))) i))))))) (defun convert-to-state (sym) (let ((syms (mutual-recursion-peers sym))) (when (and (remove sym syms) (member sym syms)) (let* ((fns (mapcar 'function-src syms)) (n (intern (symbol-name (gensym (symbol-name sym))) (symbol-package sym))) (*keep-state* n) (sts (let (sts) (dotimes (i (length syms) (nreverse sts)) (push i sts)))) (ns (inlinef n syms sts fns))) (when ns (eval ns) (mapc (lambda (x y z) (let ((z (cadr z))) (eval `(defun ,x ,z (,n ,y ,@(lambda-vars z)))))) syms sts fns) (mapc (lambda (x) (putprop x n 'state-function)) syms) ; (dolist (l syms) (add-hash l nil (list (list n)) nil nil)) (putprop n syms 'mutual-recursion-group) (add-recompile n 'mutual-recursion nil nil) n))))) (defun temp-prefix nil (concatenate 'string *tmp-dir* "gazonk_" (write-to-string (let ((p (getpid))) (if (>= p 0) p (- p)))) "_"));FIXME (defun compiler-state-fns nil (let ((p (find-package "COMPILER"))) (when p (do-symbols (s p) (when (member s *cmr*) (let* ((x (convert-to-state s))(*keep-state* x)) (when x (compile x) (mapc 'compile (get x 'mutual-recursion-group))))))))) (defun callers (sym &aux r) (do-all-symbols (s r) (when (member sym (callees s) :key 'car) (push s r)))) (defun callers-p (sym &aux (fn (or (macro-function sym)(symbol-function sym)))) (do-all-symbols (s) (when (member sym (callees s) :key 'car) (return-from callers-p t)) (when (member sym (symbol-plist s)) (return-from callers-p t)) (when (member fn (symbol-plist s)) (return-from callers-p t)) (when (member-if (lambda (x) (when (or (symbolp x)(functionp x)) (member sym (callees x) :key 'car))) (symbol-plist s)) (return-from callers-p t)))) (defun dead-code (ps &aux r) (let ((p (find-package ps))) (when p (do-symbols (s p r) (when (fboundp s) (unless (macro-function s) (multiple-value-bind (s k) (find-symbol (symbol-name s) p) (when (eq k :internal) (unless (callers-p s) (push s r)))))))))) (defun gen-discovery-props (&aux (*sig-discovery* t) q) (do-all-symbols (s) (let ((x (needs-recompile s))) (when x (pushnew (caar x) q)))) (when q (format t "~%Pass 1 signature discovery on ~s functions ..." (length q)) (mapc (lambda (x) (format t "~s~%" x) (compile x)) q) (gen-discovery-props))) (defun do-recomp2 (sp fl &aux *sig-discovery-props* *compile-verbose* r) (gen-discovery-props) (dolist (s (gen-all-ftype-symbols)) (let* ((f (or (file s) "")) (sig (car (sym-plist s)))) (when (and sig (member f fl :test 'string=));e.g. fns in o/, interpreted, wrong-file (push (list s sig) r)))) (write-sys-proclaims1 sp r)) (defvar *do-recomp-output-dir* nil) ;;FIXME not always idempotent (defun do-recomp (&optional cdebug &rest excl &aux *sig-discovery-props* *compile-verbose*) (gen-discovery-props) (let* ((fl (mapcar 'car *sig-discovery-props*)) (fl (remove-duplicates (mapcar (lambda (x &aux (f (file x))) (when f (namestring f))) fl) :test 'string=)) (fl (set-difference fl excl :test (lambda (x y) (search y x))))) (when cdebug (compiler::cdebug)) (format t "~%Recompiling original source files ...~%") (mapc (lambda (x) (format t "~s~%" x) (compile-file x :output-file (merge-pathnames (make-pathname :type "o" :name (pathname-name x)) (if *do-recomp-output-dir* (truename *do-recomp-output-dir*) x)))) (remove nil fl)))) (defun gen-all-ftype-symbols (&aux r) (do-all-symbols (s r) (when (fboundp s) (unless (or (macro-function s) (special-operator-p s)) (pushnew s r))))) gcl-2.7.1/lsp/PaxHeaders/gcl_autoload.lsp0000644000000000000000000000013214776006046015331 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.294035039 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_autoload.lsp0000644000175000017500000002025114776006046014727 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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)); defla (defun lisp-implementation-type nil "GNU Common Lisp (GCL)") (defun machine-type nil nil) (defun machine-version nil (machine-type)) (defun machine-instance nil (machine-type)) (defun software-version nil nil) (defun software-version nil (software-type)) (defun short-site-name nil nil) (defun long-site-name nil 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 nil (decode-universal-time (get-universal-time))) ; System dependent Temporary directory. (defun temp-dir nil "A system dependent path to a temporary storage directory as a string." (si::getenv "TEMP")) ; Set the default system editor to a fairly certain bet. (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 ;;; C Interface. (defmacro Clines (&rest r) (declare (ignore r)) nil) (defmacro defCfun (&rest r) (declare (ignore r)) nil) (defmacro defentry (&rest r) (declare (ignore r)) nil) (defmacro defla (&rest r) (cons 'defun r)) ;;; Help. (defun user::help (&optional (symbol nil s)) (if s (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. (XGCL-DEMO) will demo the xgcl interface if installed. (GCL-TK-DEMO) will demo the gcl-tk interface if installed. (BYE) or (BY) ends the current GCL session. Good luck! The GCL Development Team") (values)))) (defun user::help* (string &optional (package (find-package "LISP"))) (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-standard-io-syntax 'si:pretty-print-format) 1) ;; (setf (get 'with-output-to-string 'si:pretty-print-format) 1) (in-package :si) (defvar *lib-directory* (namestring (truename "../"))) (import '(*lib-directory* *load-path* *system-directory*) 'si::user) gcl-2.7.1/lsp/PaxHeaders/gcl_sym.lsp0000644000000000000000000000013114774225145014331 xustar0030 mtime=1743858277.045814259 30 atime=1744346652.093823691 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_sym.lsp0000644000175000017500000000602414774225145013732 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;; (in-package 'lisp) ;; (export '(macro-function)) (in-package :si) (defun macro-function (x &optional env &aux l) (declare (optimize (safety 2))) (check-type x symbol) (check-type env proper-list) (cond ((setq l (cdr (assoc x (cadr env)))) (when (eq (car l) 'macro) (cadr l))) ((unless (zerop (c-symbol-mflag x)) (c-symbol-gfdef x))))) (defun special-operator-p (x) (declare (optimize (safety 1))) (check-type x symbol) (if (member x '(locally symbol-macrolet)) t (/= (address nil) (c-symbol-sfdef x)))) (defun find-symbol (s &optional (p *package*) &aux r) (declare (optimize (safety 1))) (check-type s string) (check-type p (or package string symbol character)) (labels ((inb (h p) (package-internal p (mod h (c-package-internal_size p)))) (exb (h p) (package-external p (mod h (c-package-external_size p)))) (coerce-to-package (p) (cond ((packagep p) p) ((find-package p)) (t (cerror "Input new package" 'package-error :package p :format-control "~a is not a package" :format-arguments (list p)) (coerce-to-package (eval (read)))))) (cns (s b) (member-if (lambda (x) (declare (symbol x)) (string= x s)) b))) (let* ((p (coerce-to-package p)) (h (pack-hash s))) (cond ((setq r (cns s (inb h p))) (values (car r) :internal)) ((setq r (cns s (exb h p))) (values (car r) :external)) ((dolist (p (c-package-uselist p)) (when (setq r (cns s (exb h p))) (return r))) (values (car r) :inherited)) (t (values nil nil)))))) (defun symbol-value (s) (declare (optimize (safety 1))) (check-type s symbol) (if (boundp s) (c-symbol-dbind s) (error 'unbound-variable :name s))) (defun boundp (s) (declare (optimize (safety 1))) (check-type s symbol) (not (eq (nani +objnull+) (c-symbol-dbind s)))) (defun symbol-name (s) (declare (optimize (safety 1))) (check-type s symbol) (c-symbol-name s)) (defun symbol-function (s) (declare (optimize (safety 1))) (check-type s symbol) (or (let ((x (c-symbol-sfdef s))) (when (nani x) (cons 'special x))) (let ((x (c-symbol-gfdef s))) (when (eql (address x) +objnull+) (error 'undefined-function :name s)) (if (zerop (c-symbol-mflag s)) x (cons 'macro x))))) (defun remprop (s i) (declare (optimize (safety 1))) (check-type s symbol) (remf (symbol-plist s) i)) (defun makunbound (s) (declare (optimize (safety 1))) (check-type s symbol) (c-set-symbol-dbind s (nani +objnull+)) s) (defun set (s y) (declare (optimize (safety 1))) (check-type s symbol) (c-set-symbol-dbind s y)) #-pre-gcl (defun get (s y &optional d) (declare (optimize (safety 1))) (check-type s symbol) (getf (symbol-plist s) y d)) #-pre-gcl(defun symbolp (x) (if x (typecase x (symbol t)) t)) #+pre-gcl(defun symbolp (x) (typecase x (list (not x)) (symbol t))) (defun keywordp (x) (typecase x (keyword t))) (setf (symbol-function 'symbol-plist) (symbol-function 'c-symbol-plist)) (setf (symbol-function 'symbol-package) (symbol-function 'c-symbol-hpack)) gcl-2.7.1/lsp/PaxHeaders/gcl_module.lsp0000644000000000000000000000013114774225145015006 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_module.lsp0000644000175000017500000000571014774225145014410 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'lisp) ;; (export '(*modules* provide require)) ;; (export '(documentation variable function structure type setf compiler-macro)) (in-package :system) (defvar *modules* nil) (defun provide (module-name) (declare (optimize (safety 1))) (check-type module-name string-designator) (pushnew (string module-name) *modules* :test 'string=)) (defun list-of-pathname-designators-p (x) (not (member-if-not (lambda (x) (typep x 'pathname-designator)) x))) (defun default-module-pathlist (module-name) (list (make-pathname :name (string module-name) :directory (append (pathname-directory (pathname *system-directory*)) (list :up "modules"))))) (defun require (module-name &optional (pl (default-module-pathlist module-name)) &aux (*default-pathname-defaults* (make-pathname)) (pl1 (if (listp pl) pl (list pl))));FIXME ansi-test modules.7 (declare (optimize (safety 1))) (check-type module-name string-designator) (check-type pl1 (and proper-list (satisfies list-of-pathname-designators-p))) (unless (member (string module-name) *modules* :test 'string=) (mapc 'load pl1))) (defun software-type nil nil) (defun software-version nil nil) (defvar *doc-strings* (make-hash-table :test 'eq));FIXME weak (defun real-documentation (object doc-type) (declare (optimize (safety 1))) (check-type doc-type (member variable function structure type setf compiler-macro method-combination t)) (getf (gethash object *doc-strings*) doc-type)) (defun set-documentation (object doc-type value) (declare (optimize (safety 1))) (check-type doc-type (member variable function structure type setf compiler-macro method-combination t)) (setf (getf (gethash object *doc-strings*) doc-type) value)) (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))))) gcl-2.7.1/lsp/PaxHeaders/gcl_deftype.lsp0000644000000000000000000000013214774225145015162 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_deftype.lsp0000644000175000017500000004075514774225145014573 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (export '(zero one negative-integer non-negative-integer tractable-fixnum negative-short-float positive-short-float non-positive-short-float non-negative-short-float negative-long-float positive-long-float non-positive-long-float non-negative-long-float negative-float positive-float non-positive-float non-negative-float negative-real positive-real non-positive-real non-negative-real complex* complex-integer complex-integer-ratio complex-ratio-integer seqind seqbnd complex-ratio complex-short-float complex-long-float make-complex unordered));FIXME (defun default-to-* (x) (let* ((z (member-if (lambda (x) (member x lambda-list-keywords)) x)) (y (ldiff-nf x z))) (if (member-if 'atom y) (nconc (mapcar (lambda (x) (if (atom x) `(,x '*) x)) y) z) x))) (defun deftype-lambda-list (x) (let* ((y (cdr (member-if (lambda (x) (member x '(&optional &key))) x))) (z (when y (deftype-lambda-list (default-to-* y))))) (if (eq y z) x (append (ldiff-nf x y) z)))) (defun no-reg-vars-p (lambda-list) (case (car lambda-list) ((&whole &environment) (no-reg-vars-p (cddr lambda-list))) ((nil) t) (otherwise (member (car lambda-list) lambda-list-keywords)))) (defun maybe-clear-tp (sym &aux (z (find-symbol "*NRM-HASH*"))) (when z (when (boundp z) (multiple-value-bind (r f) (gethash sym (symbol-value z)) (declare (ignore r)) (when f (remhash sym (symbol-value z))))))) (defvar *deftype-simple-typep-fns* nil) (defmacro define-simple-typep-fn (name) (labels ((q (n) (intern (string-concatenate (string n) "-SIMPLE-TYPEP-FN"))) (f (n &aux (q (q n))) `(progn (defun ,q (o) (declare (ignorable o)) ,(simple-type-case 'o n)) (setf (get ',n 'simple-typep-fn) ',q (get ',q 'cmp-inline) t)))) (cond ((and (fboundp 'simple-type-case) (fboundp 'cmp-norm-tp)) `(progn ,@(mapcar #'f (nreverse *deftype-simple-typep-fns*)) ,@(setq *deftype-simple-typep-fns* nil) ,(f name))) ((setq *deftype-simple-typep-fns* (cons name *deftype-simple-typep-fns*)) nil)))) (defmacro deftype (name lambda-list &rest body &aux (lambda-list (deftype-lambda-list lambda-list)) (fun-name (gensym (string name)))) ;; Replace undefaultized optional parameter X by (X '*). (declare (optimize (safety 2))) (multiple-value-bind (doc decls ctps body) (parse-body-header body) `(progn (eval-when (compile eval load) (putprop ',name '(deftype ,name ,lambda-list ,@body) 'deftype-form) (defmacro ,fun-name ,lambda-list ,@decls ,@ctps (block ,name ,@body)) (putprop ',name ',fun-name 'deftype-definition) ;; (putprop ',name (defmacro ,fun-name ,lambda-list ,@decls ,@ctps (block ,name ,@body)) ;; 'deftype-definition) (maybe-clear-tp ',name) (putprop ',name ,doc 'type-documentation)) ,@(when (no-reg-vars-p lambda-list) `((define-simple-typep-fn ,name))) ',name))) ;;; Some DEFTYPE definitions. (deftype function-designator nil `(or (and symbol (not boolean)) function)) (deftype extended-function-designator nil `(or function-designator (cons (member setf) (cons symbol null)))) (deftype hash-table nil `(or hash-table-eq hash-table-eql hash-table-equal hash-table-equalp)) ;(deftype compiler::funcallable-symbol nil `(satisfies compiler::funcallable-symbol-p));FIXME (defconstant +ifb+ (- (car (last (multiple-value-list (si::heap-report)))))) (defconstant +ifr+ (ash (- +ifb+) -1)) (defconstant +ift+ (when (> #.+ifr+ 0) '(integer #.(- +ifr+) #.(1- +ifr+)))) ;(deftype immfix () +ift+) ;(deftype bfix nil `(and fixnum (not immfix))) (deftype eql-is-eq-tp nil `(or #.+ift+ (not number))) (deftype equal-is-eq-tp nil `(or #.+ift+ (not (or cons string bit-vector pathname number)))) (deftype equalp-is-eq-tp nil `(not (or array hash-table structure cons string bit-vector pathname number))) (deftype non-negative-byte (&optional s) `(unsigned-byte ,(if (eq s '*) s (1- s)))) (deftype negative-byte (&optional s) (normalize-type `(integer ,(if (eq s '*) s (- (ash 1 (1- s)))) -1))) (deftype signed-byte (&optional s &aux (n (if (eq s '*) 0 (ash 1 (1- s))))) (normalize-type `(integer ,(if (zerop n) s (- n)) ,(if (zerop n) s (1- n))))) (deftype unsigned-byte (&optional s) (normalize-type `(integer 0 ,(if (eq s '*) s (1- (ash 1 s)))))) (deftype non-negative-char nil `(non-negative-byte ,char-length)) (deftype negative-char nil `(negative-byte ,char-length)) (deftype signed-char nil `(signed-byte ,char-length)) (deftype unsigned-char nil `(unsigned-byte ,char-length)) (deftype char nil `(signed-char)) (deftype non-negative-short nil `(non-negative-byte ,short-length)) (deftype negative-short nil `(negative-byte ,short-length)) (deftype signed-short nil `(signed-byte ,short-length)) (deftype unsigned-short nil `(unsigned-byte ,short-length)) (deftype short nil `(signed-short)) (deftype non-negative-int nil `(non-negative-byte ,int-length)) (deftype negative-int nil `(negative-byte ,int-length)) (deftype signed-int nil `(signed-byte ,int-length)) (deftype unsigned-int nil `(unsigned-byte ,int-length)) (deftype int nil `(signed-int)) (deftype non-negative-fixnum nil `(non-negative-byte ,fixnum-length)) (deftype negative-fixnum nil `(negative-byte ,fixnum-length)) (deftype signed-fixnum nil `(signed-byte ,fixnum-length)) (deftype unsigned-fixnum nil `(unsigned-byte ,fixnum-length)) (deftype non-negative-lfixnum nil `(non-negative-byte ,lfixnum-length)) (deftype negative-lfixnum nil `(negative-byte ,lfixnum-length)) (deftype signed-lfixnum nil `(signed-byte ,lfixnum-length)) (deftype unsigned-lfixnum nil `(unsigned-byte ,lfixnum-length)) (deftype lfixnum nil `(signed-lfixnum)) (deftype fcomplex nil `(complex short-float)) (deftype dcomplex nil `(complex long-float)) (deftype string (&optional size) `(array character (,size))) (deftype base-string (&optional size) `(array base-char (,size))) (deftype bit-vector (&optional size) `(array 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))) (deftype cons (&optional car cdr) `(or (proper-cons ,car ,cdr) (improper-cons ,car ,cdr))) (deftype proper-cons (&whole w &optional car cdr &aux (a (normalize-type (if (eq car '*) t car))) (d (normalize-type (if (eq cdr '*) t cdr)))) (cond ((and (eq a car) (eq d cdr)) w) ((and a d) `(,(car w) ,a ,d)))) (setf (get 'improper-cons 'deftype-definition) (get 'proper-cons 'deftype-definition)) (deftype function-name nil `(or symbol (proper-cons (member setf) (proper-cons symbol null)))) (deftype function-identifier nil `(or function-name (proper-cons (member lambda) t)));;FIXME? t? (deftype list nil `(or cons null)) (deftype sequence nil `(or list vector)) (deftype extended-char nil nil) (deftype base-char nil `(or standard-char non-standard-base-char)) (deftype character nil `(or base-char extended-char)) (deftype stream nil `(or broadcast-stream concatenated-stream echo-stream file-stream string-stream synonym-stream two-way-stream)) (deftype file-stream nil `(or file-input-stream file-output-stream file-io-stream file-probe-stream)) (deftype path-stream nil `(or file-stream file-synonym-stream)) (deftype pathname-designator nil `(or pathname string path-stream)) (deftype synonym-stream nil `(or file-synonym-stream non-file-synonym-stream)) (deftype string-stream nil `(or string-input-stream string-output-stream)) (deftype input-stream nil `(and stream (satisfies input-stream-p))) (deftype output-stream nil `(and stream (satisfies output-stream-p))) ;(deftype bignum nil `(and integer (not fixnum))) (deftype non-negative-bignum nil `(and non-negative-byte (not non-negative-fixnum))) (deftype negative-bignum nil `(and negative-byte (not negative-fixnum))) (defconstant most-negative-immfix (or (cadr +ift+) 1)) (defconstant most-positive-immfix (or (caddr +ift+) -1)) (deftype rational (&optional low high) `(or (integer ,low ,high) (ratio ,low ,high))) (deftype float (&optional low high) `(or (short-float ,low ,high) (long-float ,low ,high))) (deftype single-float (&optional low high) `(long-float ,low ,high)) (deftype double-float (&optional low high) `(long-float ,low ,high)) (deftype real (&optional low high) `(or (rational ,low ,high) (float ,low ,high))) (deftype number nil `(or real complex)) (deftype atom nil `(not cons)) (deftype compiled-function nil `(or funcallable-std-instance non-standard-object-compiled-function)) (deftype function (&rest r) (declare (ignore r)) `(or compiled-function interpreted-function)) (deftype string-designator nil `(or string symbol character (integer 0 255))) (defun ctp-num-bnd (x tp inc &aux (a (atom x))(nx (if a x (car x)))) (flet ((f (b) (when (fboundp 'fpe::break-on-floating-point-exceptions);FIXME (fpe::break-on-floating-point-exceptions :suspend t)) (let ((z (float nx b))) (when (fboundp 'fpe::break-on-floating-point-exceptions) (fpe::break-on-floating-point-exceptions :suspend nil)) (if (eql z nx) x (if a z (list z)))))) (case tp (integer (let ((nx (if (unless a (integerp (rational nx))) (+ nx inc) nx))) (if (> inc 0) (ceiling nx) (floor nx)))) (ratio (let ((z (rational nx))) (if (eql z nx) (if (integerp x) (list x) x) (if a z (list z))))) (short-float (f 0.0s0)) (long-float (f 0.0))))) (defun ctp-bnd (x tp inc) (if (eq x '*) x (ctp-num-bnd x tp inc))) (defun bnd-chk (l h &aux (nl (if (listp l) (car l) l))(nh (if (listp h) (car h) h))) (or (eq l '*) (eq h '*) (< nl nh) (and (eql l h) (eql nl nh) (eql l nl)))) (defun bnd-exp (tp w low high &aux (l (ctp-bnd low tp 1)) (h (ctp-bnd high tp -1))) (when (bnd-chk l h) (if (and (eql l (cadr w)) (eql h (caddr w))) w `(,tp ,l ,h)))) (deftype integer (&whole w &optional low high) (bnd-exp 'integer w low high)) (deftype ratio (&whole w &optional low high) (bnd-exp 'ratio w low high)) (deftype short-float (&whole w &optional low (high '* hp)) (if (and (eq low 'unordered) (not hp)) w ;This unnecessary extension is simpler than ;(and short-float (not (or (short-float 0) (short-float * 0)))) (bnd-exp 'short-float w low high))) (deftype long-float (&whole w &optional low (high '* hp)) (if (and (eq low 'unordered) (not hp)) w (bnd-exp 'long-float w low high))) (deftype zero nil `(integer 0 0)) (deftype one nil `(integer 1 1)) (deftype non-negative-integer nil `(integer 0)) (deftype negative-integer nil `(integer * (0))) (deftype tractable-fixnum nil `(integer ,(- most-positive-fixnum) ,most-positive-fixnum)) (deftype negative-short-float nil `(short-float * (0.0))) (deftype positive-short-float nil `(short-float (0.0))) (deftype non-positive-short-float nil `(short-float * 0.0)) (deftype non-negative-short-float nil `(short-float 0.0)) (deftype negative-long-float nil `(long-float * (0.0))) (deftype positive-long-float nil `(long-float (0.0))) (deftype non-positive-long-float nil `(long-float * 0.0)) (deftype non-negative-long-float nil `(long-float 0.0)) (deftype negative-float nil `(float * (0.0))) (deftype positive-float nil `(float (0.0))) (deftype non-positive-float nil `(float * 0.0)) (deftype non-negative-float nil `(float 0.0)) (deftype negative-real nil `(real * (0.0))) (deftype positive-real nil `(real (0.0))) (deftype non-positive-real nil `(real * 0.0)) (deftype non-negative-real nil `(real 0.0)) (deftype double nil 'long-float) (deftype unadjustable-array nil `(or simple-string simple-bit-vector simple-vector)) (deftype adjustable-array nil `(and array (not unadjustable-array))) (deftype adjustable-vector nil `(and vector (not unadjustable-array))) (deftype matrix (&optional et dims) `(and (array ,et ,dims) (not vector))) (deftype simple-array (&whole w &optional et dims) (if (eq et '*) `(or ,@(mapcar (lambda (x) `(simple-array ,x ,dims)) (cons nil +array-types+))) (let* ((e (upgraded-array-element-type et))(d (or dims 0))) (if (and (eq (cadr w) e) (eq (caddr w) d)) w `(simple-array ,e ,d))))) (deftype non-simple-array (&whole w &optional et dims &aux (ets '(character t bit)) (d (cond ((eq dims '*) dims) ((eql dims 1) '*) ((atom dims) nil) ((cdr dims) nil) ((eq (car dims) '*) '*) (dims)))) (when d (if (eq et '*) (?or (mapcar (lambda (x) `(non-simple-array ,x ,d)) ets)) (let* ((e (upgraded-array-element-type et))) (when (member e ets) (if (and (eq (cadr w) e) (eq (caddr w) d)) w `(non-simple-array ,e ,d))))))) (deftype array (&optional et dims) `(or (simple-array ,et ,dims) (non-simple-array ,et ,dims))) (deftype true nil `(member t)) (deftype null nil `(member nil)) (deftype boolean nil `(or true null)) (deftype symbol nil `(or boolean keyword gsym)) (defconstant +ctps+ (mapcar (lambda (x) (list x (intern (string-concatenate "COMPLEX-" (if (consp x) (string-concatenate (string (pop x)) "-" (string (car x))) (string x)))))) (cons '(integer ratio) (cons '(ratio integer) +complex-types+))));FIXME #.`(progn ,@(mapcar (lambda (x &aux (s (cadr x))(x (car x))) `(deftype ,s (&optional l h) ,(if (consp x) ``(complex* (,',(pop x) ,l ,h) (,',(car x) ,l ,h)) ``(complex (,',x ,l ,h))))) +ctps+)) (defun ?or (x) (if (cdr x) (cons 'or x) (car x))) (deftype complex (&optional rp) `(complex* ,rp)) (defun ncs (rp &aux (rp (if (eq rp '*) 'real rp))) (mapcar (lambda (x) (cons x (car (resolve-type `(and ,x ,rp))))) +range-types+)) (defun make-complex* (r i) (when (and (cdr r) (cdr i)) `((complex* ,(cdr r) ,(cdr i))))) (deftype complex* (&optional rp (ip rp) &aux (rr (ncs rp))(ri (ncs ip)));FIXME upgraded (?or (nconc (make-complex* (assoc 'integer rr) (assoc 'ratio ri)) (make-complex* (assoc 'ratio rr) (assoc 'integer ri)) (mapcan (lambda (x) (make-complex* (assoc x rr) (assoc x ri))) +range-types+)))) ;; &whole w ;; (if (or (equal w x) (member w x :test 'equal));FIXME ;; w x))) (deftype pathname nil `(or non-logical-pathname logical-pathname)) (deftype proper-sequence nil `(or vector proper-list)) (deftype proper-list nil `(or null proper-cons)) (deftype not-type nil 'null) (deftype type-spec nil '(or (and symbol (not (eql values))) (proper-cons (and symbol (not (member values function)))) (and std-instance (satisfies si-classp)))) (deftype ftype-spec nil `(cons (member function) (cons (satisfies arg-list-type-p) (cons (satisfies values-list-type-p) null)))) (deftype fpvec nil `(and adjustable-vector (satisfies array-has-fill-pointer-p))) (deftype vector (&optional et size) `(array ,et (,size))) (deftype non-negative-immfix nil `(non-negative-byte ,(1+ (integer-length most-positive-immfix)))) (deftype immfix nil #.(when (plusp most-positive-immfix) `'(signed-byte ,(1+ (integer-length most-positive-immfix)))));FIXME check null (deftype fixnum nil `(signed-byte #.(1+ (integer-length most-positive-fixnum)))) (deftype bfix nil `(and fixnum (not immfix))) (deftype bignum nil `(or (integer * ,(1- most-negative-fixnum)) (integer ,(1+ most-positive-fixnum) *))) (deftype function-type-spec nil `(cons (member function) t));fixme (deftype full-type-spec nil `(or type-spec function-type-spec)) (deftype seqind nil `(integer 0 ,(- array-dimension-limit 2))) (deftype seqbnd nil `(integer 0 ,(1- array-dimension-limit))) (deftype rnkind nil `(integer 0 ,(1- array-rank-limit))) (deftype mod (n) `(integer 0 ,(1- n))) (deftype bit nil `(mod 2)) (defun all-eq (x y) (cond ((not (and x y)) t) ((eq (car x) (car y)) (all-eq (cdr x) (cdr y))))) (defun and-or-norm (op w r &aux (n (mapcar 'normalize-type r))) (if (all-eq r n) w (cons op n))) (deftype or (&whole w &rest r) (when r (and-or-norm 'or w r))) (deftype and (&whole w &rest r &aux (r (if r r '(t)))) (and-or-norm 'and w r)) (deftype not (&whole w &rest r) (and-or-norm 'not w r));x and-or-flatten (deftype satisfies (&whole w pred &aux (tp (get pred 'predicate-type)));Note: guard against infinite recursion (if tp (normalize-type tp) w)) (deftype eql (&rest r) (when r (unless (cdr r) `(member ,@r)))) (deftype member (&whole w &rest r) (when r w)) (deftype cnum nil `(or fixnum float fcomplex dcomplex)) (deftype creal nil `(and real cnum)) (deftype long nil 'fixnum) (deftype key-test-type nil `(or null function-designator)) gcl-2.7.1/lsp/PaxHeaders/gcl_nr.lsp0000644000000000000000000000013114774225145014140 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.356938455 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_nr.lsp0000644000175000017500000000572214774225145013545 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (eval-when (compile eval) (defmacro defcomp ((fn fn2)) `(defun ,fn (n1 &optional (n2 n1 n2p) &rest r) (declare (dynamic-extent r)) (declare (optimize (safety 1))) (check-type n1 ,(if (member fn '(= /=)) 'number 'real)) (check-type n2 ,(if (member fn '(= /=)) 'number 'real)) (cond ((not n2p)) ((not (,fn2 n1 n2)) nil) ((not r)) ((apply ',fn n2 (car r) (cdr r)))))) (defmacro defpt ((fn fn2) &aux (def (if (eq fn '+) 0 1))) `(defun ,fn (&optional (n1 ,def) (n2 ,def) &rest r) (declare (dynamic-extent r)) (declare (optimize (safety 1))) (check-type n1 number) (check-type n2 number) (if r (apply ',fn (,fn2 n1 n2) (car r) (cdr r)) (,fn2 n1 n2)))) (defmacro defmm ((fn c)) `(defun ,fn (n1 &optional (n2 n1) &rest r) (declare (dynamic-extent r)) (declare (optimize (safety 1))) (check-type n1 real) (check-type n2 real) (if r (apply ',fn (if (,c n1 n2) n1 n2) (car r) (cdr r)) (if (,c n1 n2) n1 n2)))) (defmacro defmd ((fn fn2 fn3)) `(defun ,fn (n1 &optional (n2 n1 n2p) &rest r) (declare (dynamic-extent r)) (declare (optimize (safety 1))) (check-type n1 number) (check-type n2 number) (if n2p (if r (apply ',fn (,fn2 n1 n2) (car r) (cdr r)) (,fn2 n1 n2)) (,fn ,fn3 n1))))) (defcomp (< <2)) (defcomp (<= <=2)) (defcomp (= =2)) (defun /= (n1 &rest r) (declare (optimize (safety 1))(dynamic-extent r)) (check-type n1 number) (if r (unless (member n1 r :test '=) (apply '/= r)) t)) (defcomp (>= >=2)) (defcomp (> >2)) (defpt (+ number-plus)) (defpt (* number-times)) (defmm (max >=)) (defmm (min <=)) (defmd (- number-minus 0)) (defmd (/ number-divide 1)) (defun zgcd2 (x y) (cond ((= x 0) y) ((= y 0) x) ((fgcd2 x y)))) (defun lgcd2 (x y tt &aux (tt (>> tt (ctzl tt)))) (if (plusp tt) (setq x tt) (setq y (- tt))) (if (= x y) x (lgcd2 x y (- x y))));FIXME too many tagbody iterations (defun fgcd2 (x y &aux (tx (min (ctzl x) (ctzl y)))(x (>> x tx))(y (>> y tx))) (<< (lgcd2 x y (if (oddp x) (- y) (>> x 1))) tx)) (setf (get 'zgcd2 'cmp-inline) t) (setf (get 'lgcd2 'cmp-inline) t) (setf (get 'fgcd2 'cmp-inline) t) (defun gcd (&rest r) (declare (optimize (safety 1))(dynamic-extent r)) (labels ((gcd2 (x y &aux (tp `(integer #.(1+ most-negative-fixnum) #.most-positive-fixnum))) (check-type x integer) (check-type y integer) (if (and (typep x tp) (typep y tp)) (zgcd2 (abs x) (abs y)) (mpz_gcd x y)))) (reduce #'gcd2 r :initial-value 0))) (defun lcm (&rest r) (declare (optimize (safety 1))(dynamic-extent r)) (labels ((lcm2 (x y &aux (tp `(integer #.(1+ most-negative-fixnum) #.most-positive-fixnum))) (check-type x integer) (check-type y integer) (if (and (typep x tp) (typep y tp)) (let* ((x (abs x))(y (abs y))(g (zgcd2 x y))) (if (= 0 g) g (* x (truncate y g)))) (mpz_lcm x y)))) (reduce #'lcm2 r :initial-value 1))) ;) gcl-2.7.1/lsp/PaxHeaders/gcl_sc.lsp0000644000000000000000000000013114774225145014126 xustar0030 mtime=1743858277.045814259 30 atime=1744346652.093823691 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_sc.lsp0000644000175000017500000002747014774225145013537 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;to-do fast link defentry, sig propagation ;; (in-package 'lisp) ;; (export '(string char schar string= string/= string> string>= ;; string< string<= string-equal string-not-equal ;; string-greaterp string-not-lessp string-lessp ;; string-not-greaterp char-code code-char char-upcase ;; char-downcase char= char/= char> char>= char< ;; char<= char-equal char-not-equal char-greaterp ;; char-lessp char-not-greaterp char-not-lessp ;; upper-case-p lower-case-p both-case-p ;; string-upcase string-downcase nstring-upcase nstring-downcase ;; string-trim string-left-trim string-right-trim)) (in-package :si) (defun symbol-name-length-one-p (x) (eql 1 (length (symbol-name x)))) (deftype character-designator nil `(or character (integer 0 255) (array character (1));FIXME deftype.lsp (and symbol (satisfies symbol-name-length-one-p)))) (eval-when (compile eval) (defmacro with-aref-shadow (&body body) `(labels ((lower-case-p (x) (<= #.(char-code #\a) x #.(char-code #\z))) (upper-case-p (x) (<= #.(char-code #\A) x #.(char-code #\Z))) (char-upcase (x) (if (lower-case-p x) (+ x #.(- (char-code #\A) (char-code #\a))) x)) (char-downcase (x) (if (upper-case-p x) (+ x #.(- (char-code #\a) (char-code #\A))) x)) (aref (s i) (*uchar (c-array-self s) i nil nil)) (aset (v s i) (*uchar (c-array-self s) i t v)) (char= (x z) (= x z)) (char< (x z) (< x z)) (char> (x z) (> x z)) (char-equal (x z) (or (= x z) (= (char-upcase x) (char-upcase z)))) (char-greaterp (x z) (> (char-upcase x) (char-upcase z))) (char-lessp (x z) (< (char-upcase x) (char-upcase z)))) (declare (ignorable #'lower-case-p #'upper-case-p #'char-upcase #'char-downcase #'aref #'aset #'char= #'char< #'char> #'char-equal #'char-greaterp #'char-lessp)) ,@body)) (defmacro defstr (name (s1 s2) = &body body) `(defun ,name (,s1 ,s2 &key (start1 0) end1 (start2 0) end2) (declare (optimize (safety 1))) (check-type s1 string-designator) (check-type s2 string-designator) (check-type start1 seqind) (check-type end1 (or null seqind)) (check-type start2 seqind) (check-type end2 (or null seqind)) (with-aref-shadow (let* ((s1 (string s1)) (s2 (string s2)) (l1 (length s1)) (l2 (length s2)) (e1 end1)(c1 0) (e2 end2)(c2 0) (end1 (or end1 l1)) (end2 (or end2 l2))) (declare (ignorable c1 c2)) (unless (if e1 (<= start1 end1 l1) (<= start1 l1)) (error 'type-error "Bad array bounds")) (unless (if e2 (<= start2 end2 l2) (<= start2 l2)) (error 'type-error "Bad array bounds")) (do ((i1 start1 (1+ i1)) (i2 start2 (1+ i2))) ((or (>= i1 end1) (>= i2 end2) (not (,= (setq c1 (aref s1 i1)) (setq c2 (aref s2 i2))))) ,@body) (declare (seqbnd i1 i2)))))));FIXME (defmacro defchr (n (comp key)) `(defun ,n (c1 &optional (c2 c1 c2p) &rest r) (declare (optimize (safety 1)) (list r) (dynamic-extent r));fixme (check-type c1 character) (or (not c2p) (when (,comp (,key c1) (,key c2)) (or (null r) (apply ',n c2 r)))))) (defmacro defnchr (n (test key)) `(defun ,n (c1 &rest r) (declare (optimize (safety 1)) (list r) (dynamic-extent r));fixme (check-type c1 character) (cond ((null r)) ((member (,key c1) r :test ',test :key ',key) nil) ((apply ',n r))))) (defmacro defstr1 (n query case &optional copy) `(defun ,n (s &key (start 0) end) (declare (optimize (safety 1))) (check-type s ,(if copy 'string-designator 'string)) (check-type start seqind) (check-type end (or null seqind)) (with-aref-shadow (flet ((cpy (s l) (let ((n (make-array l :element-type 'character))) (do ((j 0 (1+ j))) ((>= j l) n) (aset (aref s j) n j))))) (let* ((s (string s)) (l (length s)) (e end) (end (or end l)) (n ,(let ((x `(cpy s l))) (if copy x `(if (stringp s) s ,x))))) (unless (if e (<= start end l) (<= start l)) (error 'type-error "Bad sequence bounds")) (do ((i start (1+ i))) ((>= i end) n) (let ((ch (aref s i))) (unless (,query ch) (aset (,case ch) n i)))))))))) (defun character (c) (declare (optimize (safety 1))) (check-type c character-designator) (typecase c (character c) (unsigned-char (code-char c)) (otherwise (char (string c) 0)))) (defun char-int (c) (declare (optimize (safety 1))) (check-type c character-designator) (char-code c)) (defun int-char (c) (declare (optimize (safety 1))) (check-type c character-designator) (code-char c)) (defun char-name (c) (declare (optimize (safety 1))) (check-type c character) (let ((c (char-code c))) (case c (#.(char-code #\Return) "Return") (#.(char-code #\Space) "Space") (#.(char-code #\Rubout) "Rubout") (#.(char-code #\Page) "Page") (#.(char-code #\Tab) "Tab") (#.(char-code #\Backspace) "Backspace") (#.(char-code #\Newline) "Newline") (otherwise (let ((ch (code-char c))) (unless (graphic-char-p ch) (subseq (with-output-to-string (s) (prin1 ch s)) 2))))))) (defun name-char (sd &aux (s (string sd))) (declare (optimize (safety 1))) (check-type sd string-designator) (cond ((cdr (assoc s '(("Return" . #\Return) ("Space" . #\Space) ("Rubout" . #\Rubout) ("Page" . #\Page) ("Tab" . #\Tab) ("Backspace" . #\Backspace) ("Newline" . #\Newline) ("Linefeed" . #\Newline)) :test 'string-equal))) ((let ((l (length s))) (case l (1 (aref s 0)) (2 (when (char= #\^ (aref s 0)) (code-char (- (char-code (aref s 1)) #.(- (char-code #\A) 1))))) (3 (when (and (char= #\^ (aref s 0)) (char= #\\ (aref s 2))) (code-char (- (char-code (aref s 1)) #.(- (char-code #\A) 1))))) (4 (when (char= #\\ (aref s 0)) (code-char (+ (* 64 (- (char-code (aref s 1)) #.(char-code #\0))) (* 8 (- (char-code (aref s 2)) #.(char-code #\0))) (- (char-code (aref s 3)) #.(char-code #\0))))))))))) (setf (symbol-function 'char-code) (symbol-function 'c-character-code)) (defun code-char (d) ; (declare (optimize (safety 1))) (typecase d (unsigned-char (let ((b #.(1- (integer-length (- (address #\^A) (address #\^@)))))) (the character (nani (c+ (address #\^@) (ash d b))))))));FIXME (defchr char= (= address)) (defchr char> (> address)) (defchr char>= (>= address)) (defchr char< (< address)) (defchr char<= (<= address)) (defchr char-equal (char= char-upcase)) (defchr char-greaterp (char> char-upcase)) (defchr char-lessp (char< char-upcase)) (defchr char-not-greaterp (char<= char-upcase)) (defchr char-not-lessp (char>= char-upcase)) (defnchr char/= (= address)) (defnchr char-not-equal (char-equal identity)) (defun upper-case-p (c) (declare (optimize (safety 1))) (check-type c character) (char>= #\Z c #\A)) (defun lower-case-p (c) (declare (optimize (safety 1))) (check-type c character) (char>= #\z c #\a)) (defun both-case-p (c) (declare (optimize (safety 1))) (check-type c character) (or (upper-case-p c) (lower-case-p c))) (defun char-upcase (c) (declare (optimize (safety 1))) (check-type c character) (if (lower-case-p c) (nani (+ (address c) #.(- (address #\A) (address #\a)))) c)) (defun char-downcase (c) (declare (optimize (safety 1))) (check-type c character) (if (upper-case-p c) (nani (+ (address c) #.(- (address #\a) (address #\A)))) c)) (defun alphanumericp (c) (declare (optimize (safety 1))) (check-type c character) (or (char<= #\0 c #\9) (alpha-char-p c))) (defun alpha-char-p (c) (declare (optimize (safety 1))) (check-type c character) (both-case-p c)) (defun digit-char-p (c &optional (r 10)) (declare (optimize (safety 1))) (check-type c character) (check-type r (integer 0)) (when (typep r 'fixnum) (let* ((r r)(r (1- r))(i (char-code c)) (j (- i #.(char-code #\0))) (k (- i #.(- (char-code #\a) 10))) (l (- i #.(- (char-code #\A) 10)))) (cond ((and (<= 0 j r) (<= j 9)) j);FIXME infer across inlines ((<= 10 k r 36) k) ((<= 10 l r 36) l))))) (defun digit-char (w &optional (r 10)) (declare (optimize (safety 1))) (check-type w (integer 0)) (check-type r (integer 0)) (when (and (typep w 'fixnum) (typep r 'fixnum)) (let ((w w)(r r)) (when (< w r) (code-char (if (< w 10) (+ w #.(char-code #\0)) (+ w #.(- (char-code #\A) 10)))))))) (defun graphic-char-p (c) (declare (optimize (safety 1))) (check-type c character) (char<= #\Space c #\~)) (defun standard-char-p (c) (declare (optimize (safety 1))) (check-type c character) (or (graphic-char-p c) (char= c #\Newline))) (defun string (x) (declare (optimize (safety 1))) (check-type x string-designator) (typecase x (string x) (symbol (symbol-name x)) (character (c-character-name x)) ((integer 0 255) (string (code-char x))))) (defstr1 string-upcase upper-case-p char-upcase t) (defstr1 string-downcase lower-case-p char-downcase t) (defstr1 nstring-upcase upper-case-p char-upcase) (defstr1 nstring-downcase lower-case-p char-downcase) (defstr string= (s1 s2) char= (and (>= i1 end1) (>= i2 end2))) (defstr string/= (s1 s2) char= (unless (and (>= i1 end1) (>= i2 end2)) i1)) (defstr string> (s1 s2) char= (cond ((>= i1 end1) nil) ((>= i2 end2) i1) ((char> c1 c2) i1))) (defstr string>= (s1 s2) char= (cond ((>= i2 end2) i1) ((>= i1 end1) nil) ((char> c1 c2) i1))) (defstr string< (s1 s2) char= (cond ((>= i2 end2) nil) ((>= i1 end1) i1) ((char< c1 c2) i1))) (defstr string<= (s1 s2) char= (cond ((>= i1 end1) i1) ((>= i2 end2) nil) ((char< c1 c2) i1))) (defstr string-equal (s1 s2) char-equal (and (>= i1 end1) (>= i2 end2))) (defstr string-not-equal (s1 s2) char-equal (unless (and (>= i1 end1) (>= i2 end2)) i1)) (defstr string-greaterp (s1 s2) char-equal (cond ((>= i1 end1) nil) ((>= i2 end2) i1) ((char-greaterp c1 c2) i1))) (defstr string-not-lessp (s1 s2) char-equal (cond ((>= i2 end2) i1) ((>= i1 end1) nil) ((char-greaterp c1 c2) i1))) (defstr string-lessp (s1 s2) char-equal (cond ((>= i2 end2) nil) ((>= i1 end1) i1) ((char-lessp c1 c2) i1))) (defstr string-not-greaterp (s1 s2) char-equal (cond ((>= i1 end1) i1) ((>= i2 end2) nil) ((char-lessp c1 c2) i1))) (defun string-left-trim (b s) (declare (optimize (safety 1))) (check-type b sequence) (let ((s (string s))) (do ((l (length s)) (i 0 (1+ i))) ((or (>= i l) (not (find (aref s i) b))) (if (= i 0) s (subseq s i)))))) (defun string-right-trim (b s) (declare (optimize (safety 1))) (check-type b sequence) (let* ((s (string s)) (l (length s))) (do ((i (1- l) (1- i))) ((or (< i 0) (not (find (aref s i) b))) (if (= i l) s (subseq s 0 (1+ i))))))) (defun string-trim (b s) (declare (optimize (safety 1))) (check-type b sequence) (let* ((s (string s)) (l (length s))) (do ((i 0 (1+ i))) ((or (>= i l) (not (find (aref s i) b))) (do ((j (1- l) (1- j))) ((or (< j i) (not (find (aref s j) b))) (if (and (= i 0) (= j l)) s (subseq s i (1+ j))))))))) ;FIXME ;; (defun interpreted-function-p (x) ;; (typecase x (interpreted-function t))) ;; (defun seqindp (x) ;; (typecase x (seqind t))) (declaim (inline fixnump)) (defun fixnump (x) (typecase x (fixnum t))) (declaim (inline spicep)) (defun spicep (x) (typecase x (spice t))) (defun constantp (x &optional env) (declare (ignore env)) (typecase x (symbol (= 1 (c-symbol-stype x))) (cons (eq 'quote (car x))) (otherwise t))) ;; FIXME these functions cannot be loaded interpreted, cause an infinite loop on typep/fsf (defun functionp (x) (typecase x (function t))) (defun compiled-function-p (x) (typecase x (compiled-function t))) (defun stringp (x) (typecase x (string t))) gcl-2.7.1/lsp/PaxHeaders/gcl_setf.lsp0000644000000000000000000000013114774225145014462 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_setf.lsp0000644000175000017500000006076514774225145014077 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'lisp) ;; (export '(setf psetf shiftf rotatef ;; define-modify-macro defsetf ;; getf remf incf decf push pushnew pop ;; ; define-setf-method ;; define-setf-expander ;; ; get-setf-method ;; get-setf-expansion ;; ; get-setf-method-multiple-value ;; )) (in-package :system) ;(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) ;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol code))) (eval-when (eval compile) (setq si:*inhibit-macro-special* nil)) (defvar *setf-syms* nil) (defvar *setf-set* nil) (defconstant +setf-prefix+ "SETF") (defconstant +setf-syms+ (let ((*gensym-counter* 0)) (mapl (lambda (x) (rplaca x (gensym +setf-prefix+))) (make-list 19)))) ;(defun setf-set nil (setq *setf-syms* nil *gensym-counter* 0)) ;(defun setf-set nil (or *setf-set* (setq *setf-syms* +setf-syms+)));FIXME, this does not seem possible (defun setf-gensym nil (if *setf-syms* (prog1 (car *setf-syms*) (setq *setf-syms* (cdr *setf-syms*))) (gensym +setf-prefix+))) ;;; DEFSETF macro. (defmacro defsetf (access-fn &rest rest) (declare (optimize (safety 2))) (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.")) (multiple-value-bind (doc decls ctps body) (parse-body-header (cddr rest)) (declare (ignore ctps)) `(eval-when (compile eval load) (si:putprop ',access-fn (lambda ,(car rest) ,@decls (lambda ,(cadr rest) (block ,access-fn ,@body))) 'setf-lambda) (remprop ',access-fn 'setf-update-fn) (remprop ',access-fn 'setf-method) (si:putprop ',access-fn ,doc 'setf-documentation) ',access-fn))))) ;;; DEFINE-SETF-METHOD macro. (defmacro define-setf-method (access-fn &rest rest &aux body) (multiple-value-bind (args env) (get-&environment (car rest)) (setq body (cdr rest)) (cond (env (setq args (cons env args))) ((setq args (cons (sgen "DEFINE-SETF-METHOD") args)) (push `(declare (ignore ,(car args))) body))) `(eval-when (compile eval load) (si:putprop ',access-fn #'(lambda ,args (block ,access-fn ,@body)) 'setf-method);(*setf-set* (setf-set)) (remprop ',access-fn 'setf-lambda) (remprop ',access-fn 'setf-update-fn) (si:putprop ',access-fn ,(find-documentation (cdr rest)) 'setf-documentation) ',access-fn))) (defmacro define-setf-expander (access-fn &rest rest) (declare (optimize (safety 2))) `(define-setf-method ,access-fn ,@rest)) ;;; GET-SETF-METHOD. ;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE ;;; and checks the number of the store variable. (defun get-setf-method (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))) (defun get-setf-expansion (form &optional env) (declare (optimize (safety 2))) (get-setf-method form env)) ;;;; GET-SETF-METHOD-MULTIPLE-VALUE. ;; FIXME when all is well, remove this and the setf tests in the pcl directory (push :setf *features*) (defun get-setf-method-multiple-value (form &optional env &aux tem); (*setf-set* (setf-set)) (flet ((mvars (form) (mapcar (lambda (x) (declare (ignore x)) (setf-gensym)) (cdr form)))) (cond ((symbolp form) (let ((store (setf-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)) ((multiple-value-bind (t1 exp) (macroexpand form env) (when exp (setq tem t1))) (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 (mvars form)) (store (setf-gensym))) (values vars (cdr form) (list store) (cond (tem (setf-structure-access (car vars) (car tem) (cdr tem) store)) ((let ((f (get (car form) 'setf-update-fn))) `(,f ,@vars ,store)))) (cons (car form) vars)))) ((get (car form) 'setf-lambda) (let* ((vars (mvars form)) (store (setf-gensym)) (f (get (car form) 'setf-lambda))) (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 env))) (t (let ((vars (mvars form)) (store (setf-gensym))) (values vars (cdr form) (list store) `(funcall #'(setf ,(car form)) ,store ,@vars ) (cons (car form) vars))))))) ;;;; 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 &optional env) (v) `(let ((env ,env)) (declare (ignorable env)) (si:fset ,s (cons 'macro ,v)) ,v)) ;; (defun aset-wrap (x &rest r &aux v) ;; (declare (:dynamic-extent r)) ;; (setq r (nreverse r) v (pop r) r (nreverse r)) ;; (apply 'si:aset v x r)) (defsetf aref (x &rest r) (v) `(si::aset ,v ,x ,@r)) ;(defsetf aref aset-wrap) (defsetf get put-aux) (defmacro put-aux (a b &rest l) `(si::sputprop ,a ,b (progn ,@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 aset-wrap) ;(defsetf sbit aset-wrap) (defsetf bit (x &rest r) (v) `(baset ,v ,x ,@r)) (defsetf sbit (x &rest r) (v) `(sbaset ,v ,x ,@r)) (defsetf fill-pointer c-set-adjvector-fillp) ;(defsetf symbol-plist si:set-symbol-plist) (defsetf symbol-plist (x) (y) `(c-set-symbol-plist ,x ,y)) (defsetf gethash (k h &optional d) (v) `(progn ,d (si:hash-set ,k ,h ,v))) (defsetf row-major-aref si::aset1) (defsetf readtable-case si::set-readtable-case) (define-setf-method getf (&environment env place indicator &optional default) (let ((itemp (setf-gensym))(store (setf-gensym))(def-temp (if default (setf-gensym)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method place env) (values `(,@vars ,itemp ,@(if default `(,def-temp))) `(,@vals ,indicator ,@(if default `(,default))) (list store) `(let ((,(car stores) (si:put-f ,access-form ,store ,itemp))) ,store-form ,store) `(getf ,access-form ,itemp ,@(if default `(,def-temp))))))) (defsetf subseq (sequence1 start1 &optional end1) (sequence2) `(progn (replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1) ,sequence2)) (define-setf-method the (&environment env type form) (let ((store (setf-gensym))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method form env) (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) (let ((ntemp (setf-gensym))(store (setf-gensym))) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method char env) (values `(,ntemp ,@temps) `(,name ,@vals) (list store) `(let ((,(first stores) (set-char-bit ,access-form ,ntemp ,store))) ,store-form ,store) `(char-bit ,access-form ,ntemp))))) (define-setf-method ldb (&environment env bytespec int) (let ((btemp (setf-gensym))(store (setf-gensym))) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method int env) (values `(,btemp ,@temps) `(,bytespec ,@vals) (list store) `(let ((,(first stores) (dpb ,store ,btemp ,access-form))) ,store-form ,store) `(ldb ,btemp ,access-form))))) (define-setf-method mask-field (&environment env bytespec int) (let ((btemp (setf-gensym))(store (setf-gensym))) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method int env) (values `(,btemp ,@temps) `(,bytespec ,@vals) (list store) `(let ((,(first stores) (deposit-field ,store ,btemp ,access-form))) ,store-form ,store) `(mask-field ,btemp ,access-form))))) (defun setf-expand-values (places newvalue env) (let* ((syms (mapcar (lambda (x) (declare (ignore x)) (setf-gensym)) places)) (expns (mapcar (lambda (x y) (setf-expand-1 x y env)) places syms)) binds decls ctps alist (setters (mapcar (lambda (x) (cond ((when (consp x) (eq (car x) 'let*)) (mapc (lambda (x) (if (when (consp x) (member (cadr x) syms)) (push (cons (car x) (cadr x)) alist) (push x binds))) (cadr x)) (multiple-value-bind (doc dec ctp body) (parse-body-header (cddr x)) (declare (ignore doc));FIXME? (setq decls (nconc decls dec) ctps (nconc ctps ctp)) `(progn ,@body))) (x))) expns))) `(let* ,(nreverse binds) ,@decls ,@ctps (multiple-value-bind ,syms ,newvalue (values ,@(sublis alist setters)))))) ;;; 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)) (return-from setf-expand-1 (setf-expand-values (cdr place) newvalue env))) (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))) (declare (ignorable ,@vars)) ,store-form))) (defun setf-structure-access (struct type index newvalue) (case type (list `(setf (nth ,index ,struct) ,newvalue)) ; (list `(si:rplaca-nthcdr ,struct ,index ,newvalue)) (vector `(si::elt-set ,struct ,index ,newvalue)) (t `(str-refset ,struct ',type ,index ,newvalue))));si::structure-set (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))) (defmacro setf (&environment env &rest rest &aux (*gensym-counter* 0)) (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)) ((cons 'progn (setf-expand rest env))))) ;;; PSETF macro. (defmacro psetf (&environment env &rest rest &aux (*gensym-counter* 0)) (declare (optimize (safety 2))) (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);FIXME put in ignorable decl here 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 &aux (*gensym-counter* 0)) (declare (optimize (safety 2))) (do ((r rest (cdr r)) (pairs nil) (stores nil) (store-forms nil) (g (setf-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-method (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 &aux (*gensym-counter* 0)) (declare (optimize (safety 2))) (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)) (when store-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-method (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))))) (defmacro define-modify-macro (name lambda-list function &optional doc-string &aux (r (member '&rest lambda-list))) (declare (optimize (safety 2))) (let* ((update-form ``((lambda (&rest ,rest-var) (declare (dynamic-extent ,rest-var));GCL will not cons this list anyway, but to be safe (apply ',',function ,access-form ,rest-var)) ,,@(mapcan (lambda (x) (unless (eq x '&optional) (list (if (atom x) x (car x))))) (ldiff-nf lambda-list r));FIXME ,@,(cadr r)))) `(defmacro ,name (&environment env reference . ,lambda-list) ,@(when doc-string `(,doc-string)) (let ((*gensym-counter* 0)(rest-var (setf-gensym))) (when (symbolp reference) (return-from ,name (let ((access-form reference)) `(setq ,reference ,,update-form)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion reference env) `(let* ,(mapcar 'list (append vars stores) (append vals (list ,update-form))) (declare (ignorable ,@vars)) ,store-form)))))) ;;; Some macro definitions. ;;; (defmacro remf (&environment env place indicator) ;;; (multiple-value-bind (vars vals stores store-form access-form) ;;; (get-setf-method place env) ;;; `(let* ,(mapcar #'list vars vals) ;;; (multiple-value-bind (,(car stores) flag) ;;; (si:rem-f ,access-form ,indicator) ;;; ,store-form ;;; flag)))) ;;; This definition was obtained from SBCL (defmacro remf (&environment env place indicator &aux (*gensym-counter* 0)) (declare (optimize (safety 2))) (let* ((ind-temp (setf-gensym))(local1 (setf-gensym))(local2 (setf-gensym))) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (do* ((d dummies (cdr d)) (v vals (cdr v)) (let-list nil)) ((null d) ;; See ANSI 5.1.3 for why we do out-of-order evaluation (push (list ind-temp indicator) let-list) (push (list (car newval) getter) let-list) `(let* ,(nreverse let-list) (do ((,local1 ,(car newval) (cddr ,local1)) (,local2 nil ,local1)) ((atom ,local1) nil) (cond ((atom (cdr ,local1)) (error "Odd-length property list in REMF.")) ((eq (car ,local1) ,ind-temp) (cond (,local2 (rplacd (cdr ,local2) (cddr ,local1)) (return t)) (t (setq ,(car newval) (cddr ,(car newval))) ,setter (return t)))))))) (push (list (car d) (car v)) let-list))))) (define-modify-macro incf (&optional (delta 1)) +) (define-modify-macro decf (&optional (delta 1)) -) (defmacro push (&environment env item place &aux (*gensym-counter* 0)) (declare (optimize (safety 2))) (let ((myitem (setf-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-method place env) `(let* ,(mapcar 'list (append (list myitem) vars stores) (append (list item) vals (list (list 'cons myitem access-form)))) (declare (ignorable ,@vars)) ,store-form)))) (defmacro pushnew (&environment env item place &rest rest &aux (*gensym-counter* 0)) (declare (optimize (safety 2))) (let ((myitem (setf-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-method place env) `(let* ,(mapcar 'list (append (list myitem) vars stores) (append (list item) vals (list (list* 'adjoin myitem access-form rest)))) (declare (ignorable ,@vars)) ,store-form)))) (defmacro pop (&environment env place &aux (*gensym-counter* 0)) (declare (optimize (safety 2))) (when (symbolp place) (return-from pop (let ((temp (setf-gensym))) `(let ((,temp (car ,place))) (setq ,place (cdr ,place)) ,temp)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method place env) `(let* ,(mapcar 'list (append vars stores) (append vals (list (list 'cdr access-form)))) (declare (ignorable ,@vars)) (prog1 (car ,access-form) ,store-form)))) (defun fdefinition (n) (declare (optimize (safety 2))) (let ((n (funid-sym n))) (if (fboundp n) (symbol-function n) (error 'undefined-function :name n)))) (defun (setf fdefinition) (def n) (declare (optimize (safety 2))) (check-type def function) (let ((n (funid-sym n))) (assert (not (special-operator-p n))) (setf (symbol-function n) def))) gcl-2.7.1/lsp/PaxHeaders/gcl_serror.lsp0000644000000000000000000000013114774225145015035 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_serror.lsp0000644000175000017500000003052614774225145014442 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;; -*-Lisp-*- (in-package :si) (macrolet ((make-conditionp (condition &aux (n (intern (concatenate 'string (string condition) "P")))) `(defun ,n (x &aux (z (load-time-value nil))) (setq z (or z (let ((x (si-find-class ',condition nil))) (unless (symbolp x) x)))) (when z (typep x z)))) (make-condition-classp (class &aux (n (intern (concatenate 'string (string class) "-CLASS-P")))) `(defun ,n (x &aux (s (load-time-value nil)) (z (load-time-value nil))) (setq s (or s (let ((x (si-find-class 'standard-class nil))) (unless (symbolp x) x)))) (setq z (or z (let ((x (si-find-class ',class nil))) (unless (symbolp x) x)))) (when (and s z) (let ((x (if (symbolp x) (si-find-class x nil) x))) (when (and x (typep x s)) (member z (si-cpl-or-nil x)))))))) (make-conditionp condition) (make-conditionp warning) (make-condition-classp condition) (make-condition-classp simple-condition)) (defun si-make-condition (tp &rest args &aux (z (load-time-value nil))) (setq z (or z (when (fboundp 'make-condition) (symbol-function 'make-condition)))) (when z (values (apply z tp args)))) (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 #'si-make-condition datum arguments)) ((when (condition-class-p default-type) (or (stringp datum) (functionp datum))) (si-make-condition default-type :format-control datum :format-arguments arguments)) ((coerce-to-string datum arguments)))) (defvar *handler-clusters* nil) (defvar *break-on-signals* nil) (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)) (declare (ignore type)) (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)))) (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)) (unless (stringp condition) (do nil ((not *handler-clusters*)) (dolist (handler (pop *handler-clusters*)) (when (typep condition (car handler));FIXME, might string-match condition w handler in non-ansi here. (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 fun-name (fun) (sixth (c-function-plist fun))) (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 &optional fc fa others);FIXME do this without consing, could be oom (cond ((not args) (nconc (nreverse others) (when fc (list (apply 'format nil fc fa))))) ((eq (car args) :format-control) (process-args (cddr args) (cadr args) fa others)) ((eq (car args) :format-arguments) (process-args (cddr args) fc (cadr args) others)) ((process-args (cdr args) fc fa (cons (car args) others))))) (defun coerce-to-string (datum args) (cond ((stringp datum) (if args (let ((*print-pretty* nil)(*print-readably* 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)) (fn (member :function-name args)) (args (if fn (nconc (ldiff args fn) (cddr fn)) args))) (string-concatenate (or (cadr fn) "") (substitute #\^ #\~ (coerce-to-string (apply 'string-concatenate datum (if args ": " "") (make-list (length args) :initial-element " ~a")) args))))) ("unknown error"))) (defun put-control-string (strm strng) (when (tty-stream-p strm) (let ((pos (c-stream-int strm))) (format strm strng) (c-set-stream-int strm pos)))) (defvar *error-color* "92") (defun error-format (control &rest arguments) (put-control-string *error-output* (concatenate 'string (string 27) "[1;" *error-color* "m")) (apply 'format *error-output* control arguments) (put-control-string *error-output* (concatenate 'string (string 27) "[0m"))) (defun warn (datum &rest arguments);FIXME? &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name)))) (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))) (error-format "~&~a~%" c) (force-output *error-output*) nil)) (putprop 'cerror t 'compiler::cmp-notinline) (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 (concatenate 'string "INTERNAL-" (string datum)) :conditions)) ((condition-class-p datum) (find-symbol (concatenate 'string "INTERNAL-SIMPLE-" (string datum)) :conditions))))) (coerce-to-condition (or internal datum) (if internal (append args (list :function-name *sig-fn-name*)) 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*) (error-format (if (and correctable *break-enable*) "Correctable error:" "Error:")) (let ((*indent-formatted-output* t)) (when (stringp condition) (error-format condition))) (terpri *error-output*) (if (> (length *link-array*) 0) (error-format "Fast links are on: do (si::use-fast-links nil) for debugging~%")) (error-format "Signalled by ~:@(~S~).~%" (or *sig-fn-name* "an anonymous function")) (when (and correctable *break-enable*) (error-format "~&If continued: ")) (force-output *error-output*) (when (and correctable *break-enable*) (funcall (restart-report-function correctable) *debug-io*)) (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*)) (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 (error-format "~&Break: ") (let ((*indent-formatted-output* t)) (apply 'error-format format-string args)) (terpri *error-output*) (setq message (apply 'format nil format-string args))) (t (error-format "~&Break.~%") (setq message ""))) (force-output *error-output*)) (with-simple-restart (continue "Return from break.") (break-level message)) nil) (putprop 'break t 'compiler::cmp-notinline) gcl-2.7.1/lsp/PaxHeaders/gcl_c.lsp0000644000000000000000000000013214774225145013744 xustar0030 mtime=1743858277.045814259 30 atime=1744346652.093823691 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_c.lsp0000644000175000017500000000562314774225145013350 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defun car (x) (declare (optimize (safety 2))) (check-type x list) ; (*object (address x) 1 nil nil) (lit :object (:object x) "->c.c_car") ); (cons-car x) (defun cdr (x) (declare (optimize (safety 2))) (check-type x list) ; (*object (address x) 0 nil nil) (lit :object (:object x) "->c.c_cdr") ); (cons-cdr x) (defun cadr (x) (declare (optimize (safety 2))) (check-type x list) (car (cdr x))) (defun caar (x) (declare (optimize (safety 2))) (check-type x list) (car (car x))) (defun cdar (x) (declare (optimize (safety 2))) (check-type x list) (cdr (car x))) (defun cddr (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cdr x))) (defun caaar (x) (declare (optimize (safety 2))) (check-type x list) (car (caar x))) (defun caadr (x) (declare (optimize (safety 2))) (check-type x list) (car (cadr x))) (defun cadar (x) (declare (optimize (safety 2))) (check-type x list) (car (cdar x))) (defun cdaar (x) (declare (optimize (safety 2))) (check-type x list) (cdr (caar x))) (defun caddr (x) (declare (optimize (safety 2))) (check-type x list) (car (cddr x))) (defun cdadr (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cadr x))) (defun cddar (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cdar x))) (defun cdddr (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cddr x))) (defun caaaar (x) (declare (optimize (safety 2))) (check-type x list) (car (caaar x))) (defun caaadr (x) (declare (optimize (safety 2))) (check-type x list) (car (caadr x))) (defun caadar (x) (declare (optimize (safety 2))) (check-type x list) (car (cadar x))) (defun cadaar (x) (declare (optimize (safety 2))) (check-type x list) (car (cdaar x))) (defun cdaaar (x) (declare (optimize (safety 2))) (check-type x list) (cdr (caaar x))) (defun caaddr (x) (declare (optimize (safety 2))) (check-type x list) (car (caddr x))) (defun cadadr (x) (declare (optimize (safety 2))) (check-type x list) (car (cdadr x))) (defun cdaadr (x) (declare (optimize (safety 2))) (check-type x list) (cdr (caadr x))) (defun caddar (x) (declare (optimize (safety 2))) (check-type x list) (car (cddar x))) (defun cdadar (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cadar x))) (defun cddaar (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cdaar x))) (defun cdddar (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cddar x))) (defun cddadr (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cdadr x))) (defun cdaddr (x) (declare (optimize (safety 2))) (check-type x list) (cdr (caddr x))) (defun cadddr (x) (declare (optimize (safety 2))) (check-type x list) (car (cdddr x))) (defun cddddr (x) (declare (optimize (safety 2))) (check-type x list) (cdr (cdddr x))) gcl-2.7.1/lsp/PaxHeaders/gcl_parse_namestring.lsp0000644000000000000000000000013114774225145017062 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_parse_namestring.lsp0000644000175000017500000001261114774225145016462 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defun match-beginning (i &aux (v *match-data*)) (declare ((vector fixnum) v)(seqind i)) (the (or (integer -1 -1 ) seqind) (aref v i))) (defun match-end (i &aux (v *match-data*)) (declare ((vector fixnum) v)(seqind i)) (the (or (integer -1 -1 ) seqind) (aref v (+ i (ash (length v) -1))))) (declaim (inline match-beginning match-end)) (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 sep sepfirst &optional (b 0)) (when (stringp x) (let ((i (position sep x :start b)));string-match spoils outer match results (when i (let* ((y (dir-parse x sep sepfirst (1+ i))) (z (element x b i :directory)) (y (if z (cons z y) y))) (if (zerop b) (cons (if (zerop i) sepfirst (dir-conj sepfirst)) 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)) &aux (x (string-upcase x))) (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) (let* ((dir (dir-parse (match-component x 2 :none) #\; :relative)) (edir (expand-home-dir dir))) (make-pathname :host host :device :unspecific :directory edir :name (match-component x 6 :name) :type (match-component x 8 :type 1) :version (version-parse (match-component x 11 :version 1)) :namestring (when (and mhost (eql b 0) (eql e (length x)) (eq dir edir)) 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))) (append (dir-parse (home-namestring (cadr dir)) #\/ :absolute) (cddr dir)) 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)) (let* ((dir (dir-parse (match-component x 1 :none) #\/ :absolute)) (edir (expand-home-dir dir))) (make-pathname :directory edir :name (match-component x 3 :name) :type (match-component x 4 :type 1) :namestring (when (and (eql b 0) (eql e (length x)) (eq dir edir)) 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) (set-dispatch-macro-character #\# #\" 'sharp-dq-reader) gcl-2.7.1/lsp/PaxHeaders/gcl_fle.lsp0000644000000000000000000000013214774225145014270 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_fle.lsp0000644000175000017500000000742414774225145013675 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;; (in-package :lisp) ;; (export '(function-lambda-expression)) (in-package :si) (export 'fle) ;; (export '(blocked-body-name parse-body-header)) ;; (defun parse-body-header (x &optional doc decl ctps &aux (a (car x))) ;; (cond ;; ((unless (or doc ctps) (and (stringp a) (cdr x))) (parse-body-header (cdr x) a decl ctps)) ;; ((unless ctps (when (consp a) (eq (car a) 'declare))) (parse-body-header (cdr x) doc (cons a decl) ctps)) ;; ((when (consp a) (eq (car a) 'check-type)) (parse-body-header (cdr x) doc decl (cons a ctps))) ;; (t (values doc (nreverse decl) (nreverse ctps) x)))) ;; (defun parse-body-header (x &optional doc decl ctps) ;; (let* ((a (car x)) ;; (q (macroexpand a)));FIXME is this correct? clisp doesn't seem to think so ;; (cond ;; ((unless (or doc ctps) (and (stringp q) (cdr x))) (parse-body-header (cdr x) q decl ctps)) ;; ((unless ctps (when (consp q) (eq (car q) 'declare))) (parse-body-header (cdr x) doc (cons q decl) ctps)) ;; ((when (consp a) (eq (car a) 'check-type)) (parse-body-header (cdr x) doc decl (cons a ctps))) ;; (t (values doc (nreverse decl) (nreverse ctps) x))))) ;; (defun make-blocked-lambda (ll decls ctps body block) ;; (let ((body (if (eq block (blocked-body-name body)) body `((block ,block ,@body))))) ;; `(lambda ,ll ,@decls ,@ctps ,@body))) (defun block-lambda (ll block body) (multiple-value-bind (doc decls ctps body) (parse-body-header body) (declare (ignore doc)) (make-blocked-lambda ll decls ctps body block))) ;; (defun find-doc (x &optional y) ;; (declare (ignore y)) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header x) ;; (values doc decls (nconc ctps body)))) ;; (defun blocked-body-name (body) ;; (when (and (not (cdr body)) ;; (consp (car body)) ;; (eq (caar body) 'block)) ;; (cadar body))) (defun get-blocked-body-name (x) (multiple-value-bind (doc decls ctps body) (parse-body-header (cddr x)) (declare (ignore doc decls ctps)) (blocked-body-name body))) (defun compress-src (src) (let* ((w (make-string-output-stream)) (ss (si::open-fasd w :output nil nil))) (si::find-sharing-top src (aref ss 1)) (si::write-fasd-top src ss) (si::close-fasd ss) (get-output-stream-string w))) (defun uncompress-src (fun) (let* ((h (call fun)) (fas (when h (call-src h))) (fas (unless (fixnump fas) fas)) (ss (if (stringp fas) (open-fasd (make-string-input-stream fas) :input 'eof nil) fas)) (out (if (vectorp ss) (read-fasd-top ss) ss)) (es (when (eq (car out) 'lambda-closure) (cadr out))) (env (when es (function-env fun 0)))) (when env (setq out (list* (car out) (mapcar (lambda (x) (list (pop x) (nth (- (length es) (car x)) env))) es) (cddr out)))) (when (vectorp ss) (close-fasd ss)) out)) (defun fle (x) (typecase x (function (function-lambda-expression x)) (symbol (when (fboundp x) (unless (special-operator-p x) (unless (macro-function x) (function-lambda-expression (symbol-function x)))))))) (defun function-lambda-expression (y &aux z) (declare (optimize (safety 1))) (check-type y function) (let ((x (uncompress-src y))) (case (car x) (lambda (values x nil (get-blocked-body-name x))) (lambda-block (values (block-lambda (caddr x) (cadr x) (cdddr x)) nil (cadr x))) (lambda-closure (values (setq z (cons 'lambda (cddr (cddr x)))) (cadr x) (get-blocked-body-name z))) (lambda-block-closure (values (block-lambda (caddr (cdddr x)) (cadr (cdddr x)) (cddr (cddr (cddr x)))) (cadr x) (fifth x))) (otherwise (values nil t nil))))) (defun function-src (sym) (let ((fun (if (symbolp sym) (symbol-to-function sym) sym)));FIXME (values (function-lambda-expression fun)))) gcl-2.7.1/lsp/PaxHeaders/gcl_typecase.lsp0000644000000000000000000000013114774225145015336 xustar0030 mtime=1743858277.049814274 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_typecase.lsp0000644000175000017500000001754014774225145014744 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defmacro typecase (keyform &rest clauses &aux (sym (sgen "TYPECASE"))(key (if (symbolp keyform) keyform sym))) (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 etypecase (keyform &rest clauses &aux (sym (sgen "ETYPECASE"))(key (if (symbolp keyform) keyform sym))) (declare (optimize (safety 2))) (let* ((x `((t (error 'type-error :datum ,key :expected-type '(or ,@(mapcar 'car clauses)))))) (x `(typecase ,key ,@(append clauses x)))) (if (eq key keyform) x `(let ((,key ,keyform)) ,x)))) (defmacro infer-tp (x y z) (declare (ignore x y)) z) (defun mib (o l &optional f) (let* ((a (atom l)) (l (if a l (car l))) (l (unless (eq '* l) l))) (when l (if (eq l 'unordered) `((isnan ,o)) (if f (if a `((<= ,l ,o)) `((< ,l ,o))) (if a `((<= ,o ,l)) `((< ,o ,l)))))))) (defun ?and-or (op x) (cond ((cdr x) (cons op x)) ((car x)) ((eq op 'and)))) (defun mibb (o tp) (?and-or 'and (nconc (mib o (car tp) t) (mib o (cadr tp))))) (defun mdb (o tp) (let* ((b (car tp))) (cond ((not tp)) ((eq b '*)) ((not (listp b)) (or (eql b 1) `(eql (array-rank ,o) ,b))) ((let ((l (length b)) (x (?and-or 'and (let ((i -1)) (mapcan (lambda (x) (incf i) (unless (eq x '*) `((eql ,x (array-dimension ,o ,i))))) b))))) (cond ((eql l 1) x) ((eq x t) `(eql ,l (array-rank ,o))) (`(when (eql ,l (array-rank ,o)) ,x)))))))) (defun msubt-and-or (and-or o tp y &optional res) (if tp (let ((x (msubt o (pop tp) y))) (if (eq x (eq and-or 'or)) x (msubt-and-or and-or o tp y (if (eq x (eq and-or 'and)) res (cons x res))))) (?and-or and-or (nreverse res)))) (defvar *complex-part-types* (mapcar (lambda (x &aux (x (if (listp x) x (list x x)))) (list (cmp-norm-tp (cons 'complex* x)) (cmp-norm-tp (car x)) (cmp-norm-tp (cadr x)))) (list* '(integer ratio) '(ratio integer) +range-types+))) (defun complex-part-types (z) (lreduce (lambda (y x) (if (tp-and z (pop x)) (mapcar 'tp-or x y) y)) *complex-part-types* :initial-value (list nil nil))) (defun and-form (x y) (when (and x y) (cond ((eq x t) y) ((eq y t) x) (`(when ,x ,y))))) (defun msubt (o tp y &aux (tp (let ((x (cmp-norm-tp tp))) (or (tp>= x y) (when (tp-and x y) tp)))) (otp (normalize-type tp));FIXME normalize, eg structure (lp (listp otp))(ctp (if lp (car otp) otp))(tp (when lp (cdr otp)))) (case ctp ((or and) (msubt-and-or ctp o tp y)) (not (let ((x (msubt o (car tp) y))) (cond ((not x))((eq x t) nil)(`(not ,x))))) (satisfies `(,(car tp) ,o)) (member (if (cdr tp) `(member ,o ',tp) `(eql ,o ',(car tp)))) ((t nil) ctp) (otherwise (if (tp>= (case ctp ((proper-cons improper-cons) #tcons) (otherwise (cmp-norm-tp ctp))) y) ;FIXME (ecase ctp (#.+range-types+ (mibb o tp)) (complex* (let* ((x (complex-part-types y)) (f (and-form (msubt 'r (car tp) (car x)) (msubt 'i (cadr tp) (cadr x))))) (if (consp f) `(let ((r (realpart ,o))(i (imagpart ,o))) ,f) f))) ((simple-array non-simple-array) (mdb o (cdr tp))) ((structure structure-object) (if tp `(mss (c-structure-def ,o) ',(car tp)) t)) ((std-instance funcallable-std-instance) (if tp `(when (member (load-time-value (si-find-class ',(si-class-name (car tp)) nil)) (si-cpl-or-nil (si-class-of ,o))) t) t)) ((proper-cons improper-cons) (and-form (and-form (simple-type-case `(car ,o) (car tp)) (simple-type-case `(cdr ,o) (cadr tp))) (if (eq ctp 'proper-cons) (or (tp>= #tproper-list (cmp-norm-tp (cadr tp))) `(not (improper-consp ,o))) (or (tp>= #t(not proper-list) (cmp-norm-tp (cadr tp))) `(improper-consp ,o)))))) (progn (break) (simple-type-case o otp))))));;undecidable aggregation support (defun branch (tpsff x f y &aux (q (cdr x))(x (car x))(z (cddr (assoc x tpsff)))) (if q `((,(msubt f (tp-type q) y) ,(mkinfm f q z))) `((t ,(?-add 'progn z))))) (defun branch1 (x tpsff f o &aux (y (lreduce 'tp-or (car x) :initial-value nil))) (let* ((z (mapcan (lambda (x) (branch tpsff x f y)) (cdr x))) (s (lremove nil (mapcar 'cdr (cdr x)))) (z (if s (nconc z `((t ,(mkinfm f (tp-not (lreduce 'tp-or s :initial-value nil)) (cdar o))))) z))) (cons 'cond z))) (defun mkinfm (f tp z &aux (z (?-add 'progn z))) (if (tp>= tp #tt) z `(infer-tp ,f ,tp ,z))) (define-compiler-macro typecase (x &rest ff) (let* ((bind (unless (symbolp x) (list (list (gensym) x))));FIXME sgen? (f (or (caar bind) x)) (o (member-if (lambda (x) (or (eq (car x) t) (eq (car x) 'otherwise))) ff));FIXME (ff (if o (ldiff-nf ff o) ff)) (o (list (cons t (cdar o)))) (tps (mapcar 'cmp-norm-tp (mapcar 'car ff))) (z nil) (tps (mapcar (lambda (x) (prog1 (tp-and x (tp-not z)) (setq z (tp-or x z)))) tps)) (tpsff (mapcan (lambda (x y) (when x (list (cons x y)))) tps ff)) (oth (unless (eq z t) (mkinfm f (tp-not z) (cdar o)))) (nb (>= (+ (length tpsff) (if oth 1 0)) 2)) (fm (if nb (let* ((c (calist2 (type-and-list (mapcar 'car tpsff)))) (fn (best-type-of c))) `(case (,fn ,f) ,@(branches f tpsff (cdr (assoc fn +rs+)) o c) ,@(when oth `((otherwise ,oth))))) (if z (mkinfm f (caar tpsff) (cddar tpsff)) oth)))) (if (when nb bind) `(let ,bind ,fm) fm))) (defun simple-type-case (x type) (funcall (get 'typecase 'compiler-macro-prop) `(typecase ,x (,type t)) nil)) (defun ?-add (x tp) (if (atom tp) tp (if (cdr tp) (cons x tp) (car tp)))) (defun branches (f tpsff fnl o c) (mapcar (lambda (x) `(,(lremove-duplicates (mapcar (lambda (x) (cdr (assoc x fnl))) (car x))) ,(mkinfm f (lreduce 'tp-or (car x) :initial-value nil) (list (branch1 x tpsff f o))))) c)) (defun funcallable-symbol-function (x) (c-symbol-gfdef x)) (defconstant +xi+ (let* ((a (type-and-list (list (cmp-norm-tp `(and number (not immfix)))))) (rl (cdr (assoc 'tp8 +rs+))) (i (lremove-duplicates (mapcar (lambda (x) (cdr (assoc (cadr x) rl))) a))) ; (mi (apply 'min i)) (xi (apply 'max i)) ; (m (apply '+ i)) ) ; (assert (= mi 1)) ; (assert (= m (/ (* xi (1+ xi)) 2))) xi)) (eval-when (compile eval) (defun mtp8b (tpi &aux (rl (cdr (assoc 'tp8 +rs+))) (tp (lreduce 'tp-or (mapcar 'car (lremove-if-not (lambda (x) (eql tpi (cdr x))) rl)) :initial-value nil))) `(infer-tp x ,tp (infer-tp y ,tp ,(let ((x (caar (member-if (lambda (x &aux (z (assoc (cmp-norm-tp (cdr x)) rl :test 'tp<=))) (eql tpi (cdr z))) '((:fixnum . (and fixnum (not immfix))) (:float . short-float) (:double . long-float) (:fcomplex . fcomplex) (:dcomplex . dcomplex)))))) (if x `(,(intern (string-upcase (strcat "C-" x "-=="))) x y) (cond ((tp<= tp (cmp-norm-tp 'bignum)) `(eql 0 (mpz_cmp x y))) ((tp<= tp (cmp-norm-tp 'ratio)) `(and (eql (numerator x) (numerator y)) (eql (denominator x) (denominator y)))) ((tp<= tp (cmp-norm-tp '(complex rational))) `(and (eql (realpart x) (realpart y)) (eql (imagpart x) (imagpart y)))) ((error "Unknown tp"))))))))) #.`(defun num-comp (x y tp) (declare (fixnum tp)) (case tp ,@(let (r) (dotimes (i +xi+) (push `(,(1+ i) ,(mtp8b (1+ i))) r)) (nreverse r)))) (setf (get 'num-comp 'cmp-inline) t) (defun eql (x y) (or (eq x y) (let ((tx (tp8 x))) (unless (zerop tx) (let ((ty (tp8 y))) (when (= tx ty) (num-comp x y tx))))))) (defun eql-with-tx (x y tx) (declare (fixnum tx)) (or (eq x y) (unless (zerop tx) (let ((ty (tp8 y))) (when (= tx ty) (num-comp x y tx)))))) (setf (get 'eql-with-tx 'cmp-inline) t) gcl-2.7.1/lsp/PaxHeaders/gcl_iolib.lsp0000644000000000000000000000013214774225145014620 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_iolib.lsp0000644000175000017500000004606014774225145014224 0ustar00cammcamm;; -*-Lisp-*- ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 2))) (multiple-value-bind (doc decls ctps body) (parse-body-header body) (declare (ignore doc)) `(let ((,var (make-string-input-stream ,string ,start ,end))) ,@decls ,@ctps (multiple-value-prog1 (progn ,@body) ,@(when index `((setf ,index (get-string-input-stream-index ,var)))))))) (defvar *sosm* (make-string-output-stream)) (defun get-sosm nil (when *sosm* (setf (fill-pointer (c-stream-object0 *sosm*)) 0) *sosm*)) (defmacro with-output-to-string ((var &optional string &key (element-type ''character)) . body) (declare (optimize (safety 2))) (multiple-value-bind (doc decls ctps body) (parse-body-header body) (declare (ignorable doc)) `(let* ((,var ,(if string `(progn ,element-type (make-string-output-stream-from-string ,string)) `(or (get-sosm) (make-string-output-stream :element-type ,element-type)))) (*sosm* (unless (eq ,var *sosm*) *sosm*))) ,@decls ,@ctps ,@body ,@(unless string `((get-output-stream-string ,var)))))) (defun read-from-string (string &optional (eof-error-p t) eof-value &key (start 0) end preserve-whitespace) (declare (optimize (safety 2))) (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*) *print-array*) ((:base *print-base*) *print-base*) ((:case *print-case*) *print-case*) ((:circle *print-circle*) *print-circle*) ((:escape *print-escape*) *print-escape*) ((:gensym *print-gensym*) *print-gensym*) ((:length *print-length*) *print-length*) ((:level *print-level*) *print-level*) ((:lines *print-lines*) *print-lines*) ((:miser-width *print-miser-width*) *print-miser-width*) ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*) ((:pretty *print-pretty*) *print-pretty*) ((:radix *print-radix*) *print-radix*) ((:readably *print-readably*) *print-readably*) ((:right-margin *print-right-margin*) *print-right-margin*)) (write-int x stream)) (defun write-to-string (x &rest r &aux (stream (or (get-sosm) (make-string-output-stream)))(*sosm* nil)) (declare (optimize (safety 1))(dynamic-extent r)) (apply 'write x :stream stream r) (get-output-stream-string stream)) (defun prin1-to-string (object &aux (stream (or (get-sosm) (make-string-output-stream)))(*sosm* nil)) (declare (optimize (safety 2))) (prin1 object stream) (get-output-stream-string stream)) (defun princ-to-string (object &aux (stream (or (get-sosm) (make-string-output-stream)))(*sosm* nil)) (declare (optimize (safety 2))) (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) ((subtypep (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 (doc decls ctps body) (parse-body-header body) (declare (ignore doc)) `(let ((,stream (open ,@filespec))) ,@decls ,@ctps (unwind-protect (progn ,@body) (when ,stream (close ,stream)))))) (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) (optimize (safety 2))) (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)) (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 :supersede :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)))))) ; simple formatter macro (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) (defmacro with-standard-io-syntax (&body body) (declare (optimize (safety 2))) `(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)))) ; (print-unreadable-object-function ,object ,stream ,type ,identity ,(when body `(lambda nil ,@body))))) (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 2))) (declare (ignore opt)) `(multiple-value-prog1 (progn ,@body) ; (do-recomp) )) (defun restrict-stream-element-type (tp) (cond ((member tp '(unsigned-byte signed-byte)) tp) ((or (member tp '(character :default)) (subtypep tp 'character)) 'character) ((subtypep tp 'integer) (let* ((ntp (tp-bnds (cmp-norm-tp tp))) (min (car ntp))(max (cdr 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 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 &aux created) (declare (optimize (safety 1))) (check-type ps pathname-designator) (when (wild-pathname-p ps) (error 'file-error :pathname ps :format-control "Pathname is wild")) (labels ((d (x y &aux (z (ldiff-nf x y)) (n (namestring (make-pathname :directory z)))) (when (when z (stringp (car (last z)))) (unless (eq :directory (stat n)) (mkdir n) (setq created t) (when verbose (format *standard-output* "Creating directory ~s~%" n)))) (when y (d x (cdr y))))) (let ((pd (pathname-directory ps))) (d pd (cdr pd))) (values ps created))) (defun get-byte-stream-nchars (s) (let* ((tp (stream-element-type s))(ctp (cmp-norm-tp tp))) (labels ((ts (i) (when (<= i 32) (if (tp<= ctp (cmp-norm-tp `(unsigned-byte ,(* i char-length)))) i (ts (1+ i)))))) (cond ((tp<= ctp #tcharacter) 1) ((ts 0)) (1))))) (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 &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)));FIXME (check-type seq sequence) (check-type strm stream) (check-type start (integer 0)) (check-type end (or null (integer 0))) (labels ((set-cons (x z) (check-type x cons) (setf (car x) z) (cdr x))) (the seqbnd (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 (setq seqp (set-cons seqp z)) (setf (aref seq y) z)) (1+ y)) seq :initial-value start :start start :end end)))) (defun write-sequence (seq strm &key (start 0) end &aux (cp (eq (stream-element-type strm) 'character))) (declare (optimize (safety 1))) (check-type seq sequence) (check-type strm stream) (check-type start (integer 0)) (check-type end (or null (integer 0))) (reduce (lambda (y x) (declare (seqind y)) (if cp (write-char x strm) (write-byte x strm)) (1+ y)) seq :initial-value start :start start :end end) seq) (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 file-length (x) (declare (optimize (safety 1))) (check-type x (or broadcast-stream path-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)))))) gcl-2.7.1/lsp/PaxHeaders/gcl_trace.lsp0000644000000000000000000000013114774225145014617 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_trace.lsp0000644000175000017500000003660114774225145014224 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'lisp) ;; (export '(trace untrace)) ;; (export 'step) (in-package :system) ;;(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) `(mapcan 'untrace-one ',(or r (mapcar 'car *trace-list*)))) (defun trace-one-preprocess (x) (if (symbolp x) (trace-one-preprocess (list x)) (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) (let* ((n (funid-sym-p form)) (n1 (or n (funid-sym (car form)))) (ofname (if n form (car form))) (form (or n (cons n1 (cdr form)))) (fname n1)) (check-trace-spec 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 ofname)) (setq form (trace-one-preprocess form)) (let ((x (get fname 'state-function))) (when x (break-state 'trace x))) (fset (setq f (gensym)) (symbol-function fname)) (eval `(defun ,fname (&rest args) (trace-call ',f args ,@(cddr form)))) (putprop fname f 'traced) (setq *trace-list* (cons (cons ofname (cadr form)) *trace-list*)) (list ofname))) (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*) (*print-circle* t) vals indent) (when (= *trace-level* 0) (reset-trace-declarations (all-trace-declarations))) (cond ((eval `(let ((arglist (quote ,args))) ,cond)) (setq *trace-level* (c+ 1 *trace-level*)) (setq indent (let ((x (c+ *trace-level* *trace-level*))) (if (si::<2 x 20) x 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 traced-sym (fname) (let* ((sym (when (symbolp fname) (get fname 'traced))) (fn (when (and sym (symbolp sym) (fboundp fname)) (function-lambda-expression (symbol-function fname)))) (fn (and (consp fn) (third fn))) (fn (and (consp fn) (third fn)))) (and (consp fn) (eq (car fn) 'trace-call) sym))) (defun untrace-one (fname) (let* ((ofname fname) (fname (funid-sym fname)) (sym (traced-sym fname)) (g (get fname 'traced))) (unless sym (cond ((not g) (warn "The function ~S is not traced.~%" fname)) ((fboundp fname) (warn "The function ~S was traced, but redefined.~%" ofname)) ((warn "The function ~S was traced, but is no longer defined.~%" ofname)))) (remprop fname 'traced) (setq *trace-list* (delete-if #'(lambda (u) (equal (car u) ofname)) *trace-list* :count 1)) (when sym (fset fname (symbol-function sym))) (when g (list ofname)))) #| 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.7.1/lsp/PaxHeaders/gcl_directory.lsp0000644000000000000000000000013214775056562015534 xustar0030 mtime=1744067954.036330684 30 atime=1744340056.328938277 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_directory.lsp0000644000175000017500000000710314775056562015133 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (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-nf 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* (pathname (current-directory-namestring))))) (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.7.1/lsp/PaxHeaders/gcl_pathname_match_p.lsp0000644000000000000000000000013114774225145017011 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_pathname_match_p.lsp0000644000175000017500000000100414774225145016403 0ustar00cammcamm(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.7.1/lsp/PaxHeaders/gcl_dl.lsp0000644000000000000000000000013214774225145014121 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_dl.lsp0000644000175000017500000000162514774225145013523 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (export '(mdlsym mdl lib-name)) (defun lib-name (p) (if (or (string= p "") (string= p "libc") (string= p "libm")) "" (string-concatenate #+darwin "/usr/lib/system/" p #+darwin ".dylib" #+cygwin ".dll" #-(or darwin cygwin) ".so")));FIXME (defun mdl (n p vad) (let* ((sym (mdlsym n (lib-name p))) (ad (symbol-value sym)) (adp (aref %init vad))) (dladdr-set adp ad) (dllist-push %memory sym adp))) (defun mdlsym (str &optional (n "" np)) (let* ((pk (or (find-package "LIB") (make-package "LIB"))) (k (if np (dlopen n) 0)) (ad (dlsym k str)) (p (or (dladdr ad t) ""));FIXME work around dladdr here, not posix (psym (intern p pk)) (npk (or (find-package psym) (make-package psym :use '(:cl)))) (sym (and (shadow str npk) (intern str npk)))) (export (list psym) pk) (export sym npk) (set psym k)(set sym ad) sym)) gcl-2.7.1/lsp/PaxHeaders/gcl_seq.lsp0000644000000000000000000000013114774225145014311 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_seq.lsp0000644000175000017500000001457414774225145013723 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) #.`(defun make-sequence-element-type (x) (or (cdr (assoc x ',(mapcar (lambda (x) (cons (cmp-norm-tp (car x)) (cdr x))) `((null . null) (cons . cons) (list . list) ,@(mapcar (lambda (x) `((vector ,x) . ,x)) +array-types+))) :test 'tp<=)) (equal #tvector (if (listp x) (car x) x)))) (defun ntp-cons-lengths (x) (labels ((g (x) (if (integerp x) (1+ x) x)) (f (x) (mapcan (lambda (x) (cond ((eq x t) (list '*)) ((cadr x) (mapcar #'g (ntp-cons-lengths (cadr x)))))) x))) (let ((y (nconc (f (cdr (assoc 'proper-cons (car x)))) (f (cdr (assoc 'improper-cons (car x))))))) (if (assoc-if-not (lambda (x) (or (eq x 'proper-cons) (eq x 'improper-cons))) (car x)) (cons 0 y) y)))) (defun cons-tp-lengths (tp &aux (tp (tp-and #tcons tp))) (when (consp tp) (let ((x (lremove-duplicates (ntp-cons-lengths (caddr tp))))) (unless (member '* x) x)))) (defun ntp-vector-lengths (x) (labels ((fx (x) (mapcan (lambda (x) (cond ((eq x t) (list '*)) ((and (consp x) (not (eq 'rank (car x)))) (list (car x))))) x))) (lreduce (lambda (y x) (when (rassoc (car x) *all-array-types*) (nunion (fx (cdr x)) y))) (car x) :initial-value nil))) (defun vector-tp-lengths (tp &aux (tp (tp-and #tvector tp))) (when (consp tp) (let ((x (lremove-duplicates (ntp-vector-lengths (caddr tp))))) (unless (member '* x) x)))) (defun sequence-tp-lengths (tp) (if (tp<= tp #tlist) (cons-tp-lengths tp) (vector-tp-lengths tp))) (defun sequence-tp-nonsimple-p (tp) (tp<= tp #tnon-simple-array)) #.`(defun make-sequence (type size &key initial-element) (declare (optimize (safety 1))) (check-type type type-spec) (check-type size seqbnd) #+pre-gcl(when (eq type 'string);accelerator (return-from make-sequence (make-vector 'character size nil nil nil 0 nil initial-element))) (let* ((tp (cmp-norm-tp type)) (st (make-sequence-element-type tp)) (lns (sequence-tp-lengths tp))) (check-type st (not null)) (when lns (assert (member size lns) (size) 'type-error :datum size :expected-type (cons 'member lns))) (case st (null (check-type size (integer 0 0)) nil) ((cons list) (when (eq st 'cons) (check-type size (integer 1))) (make-list size :initial-element initial-element)) (otherwise (make-vector st size (sequence-tp-nonsimple-p tp) nil nil 0 nil initial-element))))) (defun concatenate (rt &rest seqs) (declare (optimize (safety 1)) (dynamic-extent seqs)) (macrolet ((++ (x &optional (n 1)) `(prog1 ,x (incf ,x ,n))));FIXME immnum (let* ((rs (make-sequence rt (reduce '+ seqs :key 'length :initial-value 0))) (rt (unless (listp rs) (array-element-type rs)))(rh rs)(i 0)) (mapc ;FIXME dolist does not unroll seqs (lambda (seq &aux (sh seq)(j 0)(st (unless (listp seq) (array-element-type seq))) (ls (if st (length seq) array-dimension-limit))) (if (when rt (eq rt st)) (set-array-n rs (++ i ls) seq (++ j ls) ls) (do nil ((or (>= j ls) (unless st (endp sh)))) (let ((tmp (if st (aref seq (++ j)) (pop sh)))) (if rt (setf (aref rs (++ i)) tmp) (setf (car rh) tmp rh (cdr rh))))))) seqs) rs))) (eval-when (compile eval) (defmacro locsym (f s) `(si::sgen (concatenate 'string (string ,f) ,s))) (defmacro dyncpl (x &aux (l (locsym 'dyncpl "-LOOP")));FIXME this can't cons in a labels as it might be a separate fn. Get do to unroll too. `(labels ((,l (x y) (when x (setf (car x) (car y)) (,l (cdr x) (cdr y))))) (declare (notinline make-list)) (let ((tmp (make-list (length ,x)))) (declare (dynamic-extent tmp)) (,l tmp ,x);Can't be mapl, used by tmp))) (defmacro seqval (seq place i) `(if (listp ,seq) (pop ,place) (aref ,seq ,i))) (defmacro seqvals (vals ns i) `(mapl (lambda (x y &aux (yc (car y))) (setf (car x) (seqval yc (car y) ,i))) ,vals ,ns))) (defun map (rt f seq &rest sqs &aux (f (coerce f 'function)) (l (listp seq));FIXME test array-dimension-limit instead of length for lists (sl (reduce (lambda (y x) (min y (length x))) sqs :initial-value (length seq))) (x (when rt (make-sequence rt sl)))(lx (listp x))) (declare (optimize (safety 1))(dynamic-extent sqs)) (check-type rt type-spec) (check-type f function-designator) (check-type seq sequence) (labels ((lp (fn i xp seq) ;(print (list fn i xp seq)) (unless (>= i sl) (let ((tmp (funcall fn i seq))) (when rt (if lx (setf (car xp) tmp) (setf (aref x i) tmp)))) (lp fn (1+ i) (cdr xp) (if l (cdr seq) seq))))) (if sqs (let* ((ns (dyncpl sqs))(vals (dyncpl sqs))(nf (when sqs (afc-sym (length sqs))))) (lp (lambda (i seq) (funcall nf f (if l (car seq) (aref seq i)) (seqvals vals ns i))) 0 (when (consp x) x) seq)) (lp (lambda (i seq) (funcall f (if l (car seq) (aref seq i)))) 0 (when (consp x) x) seq)) x)) (defun map-into (rs g &rest seqs &aux (h rs) (lp (unless (listp rs) (array-total-size rs))) (fp (when lp (array-has-fill-pointer-p rs)))(j 0)) (declare (optimize (safety 1))(dynamic-extent seqs)) (check-type rs proper-sequence) (unless (member rs seqs) (when fp (setf (fill-pointer rs) lp))) (block exit (apply 'map nil (lambda (x &rest r) (declare (ignore x)) (when (if lp (= j lp) (endp h)) (return-from exit)) (let ((tmp (apply g r))) (if lp (setf (aref rs j) tmp j (1+ j)) (setf (car h) tmp h (cdr h))))) rs seqs)) (when fp (setf (fill-pointer rs) j)) rs) gcl-2.7.1/lsp/PaxHeaders/gcl_arraylib.lsp0000644000000000000000000000013214774225145015327 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.344938378 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_arraylib.lsp0000644000175000017500000004403414774225145014732 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :system) (defconstant +array-type-info+ (mapcar (lambda (x &aux (y (make-vector x 1 t nil nil 0 nil nil))) (list x (c-array-elttype y) (c-array-eltsize y) (c-array-eltmode y) (ecase x (signed-char '*char) ((character unsigned-char non-negative-char bit) '*uchar) (signed-short '*short) ((unsigned-short non-negative-short) '*ushort) (signed-int '*int) ((unsigned-int non-negative-int) '*uint) (short-float '*float) (long-float '*double) (t '*object) ((non-negative-fixnum fixnum) '*fixnum)))) +array-types+)) #.`(defun set-array (r i s j &optional sw);assumes arrays of same type and indices in bounds (declare (optimize (safety 1))(seqind i j)) (check-type r array) (check-type s array) (flet ((sp (r i s j gf sf &aux (x (when sw (funcall gf r i)))) (funcall sf (funcall gf s j) r i) (when sw (funcall sf x s j)))) (case (c-array-eltsize r) ,@(mapcar (lambda (x &aux (z (pop x))(y (pop x))(w (car x))) `(,z (infer-tp r ,y (infer-tp s ,y ,(if (zerop z) `(sp r i s j #'0-byte-array-self #'set-0-byte-array-self) `(let* ((rs (c-array-self r))(ss (if (eq r s) rs (c-array-self s)))) (sp rs i ss j (lambda (rs i) (,w rs i nil nil)) (lambda (v rs i) (,w rs i t v))))))))) (lreduce (lambda (y x &aux (sz (caddr x))(fn (fifth x))(z (assoc sz y))(tp (cmp-norm-tp `(array ,(car x))))) (cond (z (setf (cadr z) (tp-or (cadr z) tp) (caddr z) fn) y) ((cons (list sz tp fn) y)))) +array-type-info+ :initial-value nil))))) (declaim (inline set-array)) (defun set-array-n (r i s j n);assumes arrays of same type and indices in bounds (declare (optimize (safety 1))(seqind i j n));FIXME (check-type r array) (check-type s array) (let ((z (c-array-eltsize r))) (if (zerop z) (copy-bit-vector r i s j n) (let* ((rs (c-array-self r))(ss (if (eq r s) rs (c-array-self s)))) (memmove (c+ rs (<< i (1- z))) (c+ ss (<< j (1- z))) (<< n (1- z)))))) r) (declaim (inline set-array-n)) #.`(defun array-element-type (x) (declare (optimize (safety 1))) (check-type x array) (case (c-array-elttype x) ,@(mapcar (lambda (x &aux (tp (pop x))) `(,(car x) ',tp)) +array-type-info+))) #.`(defun row-major-aref-int (a i) (ecase (c-array-elttype a) ,@(mapcar (lambda (y &aux (x (pop y))) `(,(pop y) ,(case x (character `(code-char (*uchar (c-array-self a) i nil nil))) (bit `(0-byte-array-self a i)) (otherwise `(,(caddr y) (c-array-self a) i nil nil))))) +array-type-info+))) (declaim (inline row-major-aref-int)) (defun row-major-aref (a i) (declare (optimize (safety 1))) (check-type a array) (check-type i seqind) (assert (< i (array-total-size a)) (i) 'type-error :datum i :expected-type `(integer 0 (,(array-total-size a)))) (row-major-aref-int a i)) #.`(defun row-major-aset (v a i) (declare (optimize (safety 1))) (check-type a array) (check-type i seqind) (assert (< i (array-total-size a)) (i) 'type-error :datum i :expected-type `(integer 0 (,(array-total-size a)))) (ecase (c-array-elttype a) ,@(mapcar (lambda (y &aux (x (pop y))) `(,(pop y) (check-type v ,x) ,(case x (character `(code-char (*uchar (c-array-self a) i t (char-code v)))) (bit `(set-0-byte-array-self v a i)) ((t) `(,(caddr y) (c-array-self a) i a v)) (otherwise `(,(caddr y) (c-array-self a) i t v))))) +array-type-info+))) (setf (get 'row-major-aset 'compiler::consider-inline) t) (defun 0-byte-array-self (array index) (declare (optimize (safety 1))) (check-type array (array bit)) (check-type index seqind) (let* ((off (+ index (array-offset array))) (ind (>> off #.(1- (integer-length fixnum-length)))) (word (*fixnum (c-array-self array) ind nil nil)) (shft (end-shft (& off #.(1- fixnum-length))))) (& (>> word shft) 1))) (declaim (inline 0-byte-array-self)) (defun set-0-byte-array-self (bit array index) (declare (optimize (safety 1))) (check-type array (array bit)) (check-type index seqind) (check-type bit bit) (let* ((off (+ index (array-offset array))) (ind (>> off #.(1- (integer-length fixnum-length)))) (word (*fixnum (c-array-self array) ind nil nil)) (shft (end-shft (& off #.(1- fixnum-length)))) (val (<< 1 shft))) (*fixnum (c-array-self array) ind t (if (zerop bit) (& word (~ val)) (\| word val))) bit)) (declaim (inline set-0-byte-array-self)) (defun array-row-major-index (array &rest indices &aux (k 1)) (declare (optimize (safety 1))(inline array-dimension)(rnkind k)) (check-type array array) (assert (apply 'array-in-bounds-p array indices)) (the seqind (lreduce (lambda (y x &aux (z (array-dimension array k))) (declare (seqind x y)) (incf k) (+ x (the seqind (c* y z))));FIXME * inline-args (cdr indices) :initial-value (if indices (car indices) 0)))) (defun aref (a &rest q) (declare (optimize (safety 1)) (dynamic-extent q)) (check-type a array) (if (and q (not (cdr q))) (let ((x a))(check-type x vector)) (let ((x a))(check-type x matrix))) (row-major-aref a (apply 'array-row-major-index a q))) #-(and pre-gcl raw-image) (defun aset (v a &rest q) (declare (optimize (safety 1)) (dynamic-extent q)) (check-type a array) (if (and q (not (cdr q))) (let ((x a))(check-type x vector)) (let ((x a))(check-type x matrix))) (row-major-aset v a (apply 'array-row-major-index a q))) (declaim (inline aset)) (setf (symbol-function 'array-rank) (symbol-function 'c-array-rank) (symbol-function 'array-total-size) (symbol-function 'c-array-dim)) (defun array-in-bounds-p (a &rest i &aux (j 0)) (declare (optimize (safety 1)) (dynamic-extent i)) (check-type a array) (unless (member-if-not (lambda (x) (<= 0 x (1- (array-dimension a (prog1 j (incf j)))))) i) (eql j (c-array-rank a)))) (defun array-dimension (x i) (declare (optimize (safety 2))) (check-type x array) (check-type i rnkind) (let ((r (c-array-rank x)));FIXME (assert (< i r) () 'type-error :datum i :expected-type `(integer 0 (,r))) (if (eql 1 r) (c-array-dim x) (array-dims x i))));(the seqind (*fixnum (c-array-dims x) i nil nil)) (defun array-displacement (x) (declare (optimize (safety 1))) (check-type x array) (let ((x (typecase x (adjustable-array (car (c-adjarray-displaced x)))))) (values (car x) (or (cdr x) 0)))) (defun array-dimensions (x) (declare (optimize (safety 1))) (check-type x array) (let ((r (array-rank x)) z) (labels ((collect (i) (cond ((minusp i) z) ((push (array-dimension x i) z) (collect (1- i)))))) (collect (1- r))))) (defun array-has-fill-pointer-p (x) (declare (optimize (safety 1))) (check-type x array) (typecase x (adjustable-vector (not (zerop (c-array-hasfillp x)))))) (defun fill-pointer (x) (declare (optimize (safety 1))) (check-type x adjustable-vector) (assert (array-has-fill-pointer-p x) (x) 'type-error :datum x :expected-type '(satisfies array-has-fill-pointer-p)) (c-adjvector-fillp x)) ; (fill-pointer-internal x) (defun make-array (dimensions &key (element-type t) initial-element (initial-contents nil icsp) adjustable fill-pointer displaced-to (displaced-index-offset 0) static &aux (dimensions (if (and (listp dimensions) (not (cdr dimensions))) (car dimensions) dimensions)) (element-type (upgraded-array-element-type element-type))) (declare (optimize (safety 1))) (check-type fill-pointer (or boolean integer)) (check-type displaced-to (or null array)) (check-type displaced-index-offset integer) (etypecase dimensions (list (assert (not fill-pointer)) (dolist (d dimensions) (check-type d integer)) (let ((x (make-array1 element-type static initial-element displaced-to displaced-index-offset dimensions adjustable))) (when (unless (member 0 dimensions) icsp) (let ((i -1)) (labels ((set (d c) (cond (d (assert (eql (car d) (length c))) (map nil (lambda (z) (set (cdr d) z)) c)) ((row-major-aset c x (incf i)))))) (set dimensions initial-contents)))) x)) (integer (let ((x (make-vector element-type dimensions adjustable (when fill-pointer dimensions) displaced-to displaced-index-offset static initial-element))) (when icsp (replace x initial-contents)) (when (and fill-pointer (not (eq t fill-pointer))) (setf (fill-pointer x) fill-pointer)) x)))) (defun vector (&rest objects) (declare (dynamic-extent objects)) (make-array (length objects) :element-type t :initial-contents objects)) (deftype bit-array nil `(array bit)) (deftype simple-bit-array nil `(simple-array bit)) (defun bit (bit-array &rest indices) (declare (dynamic-extent indices)(optimize (safety 1))) (check-type bit-array bit-array) (apply 'aref bit-array indices)) #-(and pre-gcl raw-image) (defun sbit (bit-array &rest indices) (declare (dynamic-extent indices)(optimize (safety 1))) (check-type bit-array simple-bit-array) (apply 'aref bit-array indices)) (defun char (x i) (declare (optimize (safety 2))) (check-type x string) (check-type i seqind) (aref x i)) (defun schar (x i) (declare (optimize (safety 1))) (check-type x simple-string) (check-type i seqind) (aref x i)) (declaim (inline char-set)) (defun char-set (x i v) (declare (optimize (safety 1))) (check-type x string) (check-type i seqind) (check-type v character) (aset v x i)) (declaim (inline schar-set)) (defun schar-set (x i v) (declare (optimize (safety 1))) (check-type x simple-string) (check-type i seqind) (check-type v character) (aset v x i)) (defun vector-push (new-element vector) (declare (optimize (safety 1))) (check-type vector adjustable-vector) (assert (array-has-fill-pointer-p vector) (vector) 'type-error :datum vector :expected-type '(satisfies array-has-fill-pointer-p));FIXME (let ((fp (fill-pointer vector))) (cond ((< fp (array-dimension vector 0)) (setf (aref vector fp) new-element (fill-pointer vector) (1+ fp)) fp)))) (defun vector-push-extend (new-element vector &optional extension) (declare (optimize (safety 1))) (check-type vector adjustable-vector) (assert (array-has-fill-pointer-p vector) (vector) 'type-error :datum vector :expected-type '(satisfies array-has-fill-pointer-p)) (let* ((fp (fill-pointer vector)) (dim (array-dimension vector 0)) (vector (if (< fp dim) vector (adjust-array vector (the seqind (+ dim (or extension (max 5 dim)))) :element-type (array-element-type vector) :fill-pointer fp)))) (setf (aref vector fp) new-element (fill-pointer vector) (1+ fp)) fp)) (defun vector-pop (vector) (declare (optimize (safety 1))) (check-type vector adjustable-vector) (assert (array-has-fill-pointer-p vector) (vector) 'type-error :datum vector :expected-type '(satisfies array-has-fill-pointer-p)) (let ((fp (fill-pointer vector))) (check-type fp (integer 1)) (setf (fill-pointer vector) (1- fp)) (aref vector (1- fp)))) (defun adjustable-array-p (array) (declare (optimize (safety 1))) (check-type array array) (typep array 'adjustable-array)) (defun adjust-array (array new-dimensions &rest r &key element-type initial-element (initial-contents nil initial-contents-supplied-p) (fill-pointer nil fill-pointer-supplied-p) (displaced-to nil) (displaced-index-offset 0) (static nil static-supplied-p)) (declare (ignore initial-element initial-contents static displaced-index-offset) ;FIXME (dynamic-extent r) (optimize (safety 2))) (check-type array array) (check-type new-dimensions (or seqind proper-list)) (when (and (listp new-dimensions) (not (cdr new-dimensions))) (setq new-dimensions (car new-dimensions))) (setq element-type (array-element-type array)) (unless (eq element-type t) (setq r (cons element-type r) r (cons :element-type r))) (unless static-supplied-p (setq r (cons (staticp array) r) r (cons :static r))) (cond (fill-pointer-supplied-p (let ((fill-pointer (or fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array))))) (setf (cadr (member :fill-pointer r)) fill-pointer))) ((array-has-fill-pointer-p array) (setq r (cons (fill-pointer array) r) r (cons :fill-pointer r)))) (let ((x (apply 'make-array new-dimensions :adjustable t r))) ;FIXME avoid when possible (unless (or displaced-to initial-contents-supplied-p) (cond ((or (seqindp new-dimensions) (and (equal (cdr new-dimensions) (cdr (array-dimensions array))) (or (not (eq element-type 'bit)) (when new-dimensions (= 0 (mod (the seqind (car (last new-dimensions))) char-length)))))) (copy-array-portion array x 0 0 (min (array-total-size x) (array-total-size array)))) ((let ((i -1)) (labels ((set (dim &optional (cur (make-list (length new-dimensions) :initial-element 0)) (ind cur)) (declare (dynamic-extent cur)) (cond (dim (dotimes (i (pop dim)) (setf (car cur) i) (set dim (cdr cur) ind))) ((incf i) (when (apply 'array-in-bounds-p array ind) (row-major-aset (apply 'aref array ind) x i)))))) (set new-dimensions)))))) (if (typep array 'unadjustable-array) (setq array x) (replace-array array x)) (when (eq fill-pointer t) (setq fill-pointer (array-total-size array))) (when fill-pointer (setf (fill-pointer array) fill-pointer)) array)) (defun array-total-size (a) (declare (optimize (safety 1))) (check-type a array) (c-array-dim a)) (defun array-rank (a) (declare (optimize (safety 1))) (check-type a array) (c-array-rank a)) (defun array-dims-propagator (f t1 t2 &aux (d (atomic-tp-array-dimensions t1)) (a (car (atomic-tp t2)))) (declare (ignore f)) (when (and a d) (object-tp (nth a (car d))))) (setf (get 'array-dims 'type-propagator) 'array-dims-propagator) (defun applicable-array-infos (x k) (when (tp>= #tarray x) (cmp-norm-tp (cons 'member (mapcar k (lreduce (lambda (y z) (if (tp<= x (car z)) y (cons (cdr z) y))) '#.(mapcar (lambda (x) (cons (cmp-norm-tp `(not (array ,(pop x)))) x)) +array-type-info+) :initial-value nil)))))) (defun array-elttype-propagator (f x) (declare (ignore f)) (applicable-array-infos x 'car)) (setf (get 'c-array-elttype 'type-propagator) 'array-elttype-propagator) (defun array-eltsize-propagator (f x) (declare (ignore f)) (applicable-array-infos x 'cadr)) (setf (get 'c-array-eltsize 'type-propagator) 'array-eltsize-propagator) (defun array-eltmode-propagator (f x) (declare (ignore f)) (applicable-array-infos x 'caddr)) (setf (get 'c-array-eltmode 'type-propagator) 'array-eltmode-propagator) (defun array-rank-propagator (f x) (declare (ignore f)) (cond ((tp>= #tvector x) #t(member 1)) ((let ((d (atomic-tp-array-rank x))) (when d (object-tp d)))) ((tp>= #tmatrix x) #t(and rnkind (not (eql 1)))) ((tp>= #tarray x) #trnkind))) (setf (get 'c-array-rank 'type-propagator) 'array-rank-propagator) (defun array-dim-propagator (f t1 &aux (d (atomic-tp-array-dimensions t1))) (declare (ignore f)) (when d (object-tp (reduce '* (car d))))) (setf (get 'c-array-dim 'type-propagator) 'array-dim-propagator) (defun svref (x i) (declare (optimize (safety 1))) (check-type x simple-vector) (check-type i seqind) (aref x i)) (defun svset (x i v) (declare (optimize (safety 1))) (check-type x simple-vector) (check-type i seqind) (aset v x i)) (setf (get 'svset 'cmp-inline) t) #.`(defun array-eql-is-eq (x) (case (c-array-elttype x) (,(mapcan (lambda (x) (when (subtypep x 'eql-is-eq-tp) (list (c-array-elttype (make-array 1 :element-type x))))) +array-types+) t))) (declaim (inline array-eql-is-eq)) (defun msdata-ref (d s) (structure-ref1 d (fifth (assoc s (structure-ref1 d 7)))));FIXME 7 (defmacro str-refset (x s n &optional (v nil vp) &aux (str (sgen "STR-REFSET"))(val (sgen "STR-REFSET"))) (declare (optimize (safety 1))) (assert (and (constantp s) (constantp n))) (let* ((s (eval s))(n (eval n))(?sd (eq s 's-data)) (d (get s 's-data)) (pos (aref (if ?sd (msdata-ref d 'slot-position) (s-data-slot-position d)) n)) (tp (car (last (nth n (if ?sd (msdata-ref d 'slot-descriptions) (s-data-slot-descriptions d)))))) (k (aref (if ?sd (msdata-ref d 'raw) (s-data-raw d)) n)) (l (nth k +array-type-info+)) (off (ash pos (min 0 (- (1- (third l)))))) (cp (eq (car l) 'character))) (flet ((fm (x y) (let* ((res `(,(fifth l) (c-strstd-sself ,x) ,off ,(when y (if (eq '*object (fifth l)) x t)) ,y)) (res (if cp `(code-char ,res) res))) (if (unless (eq tp t) tp) `(the ,tp ,res) res)))) (if vp `(let ((,str ,x)(,val ,(if cp `(char-code ,v) v)));FIXME sgc-touch would go here ,(fm str val)) (fm x nil))))) (defun *-propagator (f t1 t2 t3 t4) (declare (ignore t1 t2)) (when (tp<= t3 #t(not null)) (tp-and t4 (reduce 'tp-or (mapcar (lambda (x) (unless (eq (car x) 'character) (cmp-norm-tp (car x))));FIXME (remove f +array-type-info+ :test-not 'eq :key 'fifth)) :initial-value nil)))) (dolist (l (mapcar 'fifth +array-type-info+)) (setf (get l 'type-propagator) '*-propagator)) gcl-2.7.1/lsp/PaxHeaders/gcl_hash.lsp0000644000000000000000000000013214774225145014445 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_hash.lsp0000644000175000017500000000703714774225145014052 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (defun make-hash-table (&key (test 'eql) (size *default-hash-table-size*) (rehash-size *default-hash-table-rehash-size*) (rehash-threshold *default-hash-table-rehash-threshold*)) (the hash-table (make-hash-table-int test size rehash-size rehash-threshold nil))) (defun hash-table-p (x) (declare (optimize (safety 1))) (typecase x (hash-table t))) (defun htent-key (e) (*fixnum e 0 nil nil)) (setf (get 'htent-key 'compiler::cmp-inline) t) (defun htent-value (e) (*object e 1 nil nil)) (setf (get 'htent-value 'compiler::cmp-inline) t) (defun set-htent-key (e y) (*fixnum e 0 t y)) (setf (get 'set-htent-key 'compiler::cmp-inline) t) (defun set-htent-value (e y) (*object e 1 t y)) (setf (get 'set-htent-value 'compiler::cmp-inline) t) (defun gethash (x y &optional z) (declare (optimize (safety 1))) (check-type y hash-table) (let ((e (gethash-int x y))) (if (eql +objnull+ (htent-key e)) (values z nil) (values (htent-value e) t)))) (defun gethash1 (x y) (declare (optimize (safety 1))) (check-type y hash-table) (let ((e (gethash-int x y))) (if (eql +objnull+ (htent-key e)) nil (htent-value e)))) (defun maphash (f h) (declare (optimize (safety 1))) (check-type h hash-table) (let ((n (hash-table-size h))) (dotimes (i n) (let* ((e (hashtable-self h i)) (k (htent-key e))) (unless (eql +objnull+ k) (funcall f (nani k) (htent-value e))))))) (defun remhash (x y) (declare (optimize (safety 1))) (check-type y hash-table) (let ((e (gethash-int x y))) (unless (eql +objnull+ (htent-key e)) (set-htent-key e +objnull+) (c-set-hashtable-nent y (1- (c-hashtable-nent y))) t))) (defun clrhash (h) (declare (optimize (safety 1))) (check-type h hash-table) (let ((n (hash-table-size h))) (dotimes (i n) (let ((e (hashtable-self h i))) (set-htent-key e +objnull+) (set-htent-value e (nani +objnull+))));FIXNE? (c-set-hashtable-nent h 0) h)) (defun sxhash (x) (declare (optimize (safety 1))) (typecase x (symbol (c-symbol-hash x)) (otherwise (hash-equal x 0)))) (defun hash-set (k h v) (declare (optimize (safety 1))) (check-type h hash-table) (let ((n (c-hashtable-nent h))) (when (>= (1+ n) (c-hashtable-max_ent h)) (extend-hashtable h)) (let ((e (gethash-int k h))) ;touch hashtable header; ;FIXME GBC (c-set-hashtable-nent h (if (eql +objnull+ (htent-key e)) (1+ n) n)) (set-htent-key e (address k)) (set-htent-value e v)))) (setf (get 'hash-set 'compiler::cmp-inline) t) (setf (symbol-function 'hash-table-count) (symbol-function 'c-hashtable-nent)) (setf (symbol-function 'hash-table-size) (symbol-function 'c-hashtable-size)) (setf (symbol-function 'hash-table-rehash-size) (symbol-function 'c-hashtable-rhsize)) (setf (symbol-function 'hash-table-rehash-threshold) (symbol-function 'c-hashtable-rhthresh)) (defun hash-table-test (h) (declare (optimize (safety 1))) (check-type h hash-table) (aref #(eq eql equal equalp) (c-hashtable-test h))) (defun hash-table-eq-p (x) (declare (optimize (safety 1))) (typecase x (hash-table (eq 'eq (hash-table-test x))))) (defun hash-table-eql-p (x) (declare (optimize (safety 1))) (typecase x (hash-table (eq 'eql (hash-table-test x))))) (defun hash-table-equal-p (x) (declare (optimize (safety 1))) (typecase x (hash-table (eq 'equal (hash-table-test x))))) (defun hash-table-equalp-p (x) (declare (optimize (safety 1))) (typecase x (hash-table (eq 'equalp (hash-table-test x))))) gcl-2.7.1/lsp/PaxHeaders/gcl_info.lsp0000644000000000000000000000013214774225145014455 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.352938429 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_info.lsp0000644000175000017500000003625514774225145014066 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :si) (eval-when (compile eval) (defmacro f (op x y) (list op x y))) (defconstant +crlu+ #v"") (defconstant +crnp+ #v"[ ]") (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 #v"[ \n]+Indirect:" s 0) 0) (setq i (match-end 0)) (setq lim (string-match +crlu+ s i)) (while (f >= (string-match #v"\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 #v"[\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) (declare (fixnum i)) (let* ((x (if (stringp x) x (string x))) (len (length x)) (tem x)) (while (< i len) (setq ch (aref x i)) (when (position ch "\\()[]+.*|^$?") (when (eq x tem) (setq tem (make-array len :adjustable t :element-type 'character :fill-pointer i)) (dotimes (j i) (setf (aref tem j) (aref x j)))) (vector-push-extend #\\ tem)) (unless (eq tem x) (vector-push-extend ch tem)) (setq i (+ i 1))) (remove-if-not 'standard-char-p 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 #v"[\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 #v"^\\(([^(]+)\\)([^)]*)" 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 #v"\n -+ [a-zA-Z]" s (let* ((bg (+ beg 1 initial-offset)) (sd (string-match #v"\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.7.1/lsp/PaxHeaders/gcl_seqlib.lsp0000644000000000000000000000013114776006046014777 xustar0030 mtime=1744309286.186034518 30 atime=1744309286.294035039 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_seqlib.lsp0000644000175000017500000004400014776006046014374 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :system) (defun length (x) (declare (optimize (safety 1))) (check-type x proper-sequence) (labels ((ll (x i) (declare (seqind i)) (if x (ll (cdr x) (1+ i)) i))) (if (listp x) (ll x 0) (if (array-has-fill-pointer-p x) (fill-pointer x) (array-dimension x 0))))) (defun elt (seq n) (declare (optimize (safety 1))) (check-type seq sequence) (check-type n seqind) (assert (< n (length seq)) () 'type-error :datum n :expected-type `(integer 0 (,(length seq)))) (if (listp seq) (nth n seq) (aref seq n))) (declaim (inline elt-set)) (defun elt-set (seq n v) (declare (optimize (safety 1))) (check-type seq sequence) (check-type n seqind) (assert (< n (length seq)) () 'type-error :datum n :expected-type `(integer 0 (,(length seq)))) (if (listp seq) (setf (nth n seq) v) (setf (aref seq n) v))) (defun nreverse (s) (declare (optimize (safety 1))) (check-type s proper-sequence) (labels ((lr (tl &optional hd) (if tl (lr (cdr tl) (rplacd tl hd)) hd)) (la (&optional (i 0) (j (1- (length s)))) (cond ((< i j) (set-array s i s j t) (la (1+ i) (1- j))) (s)))) (if (listp s) (lr s) (la)))) (defun reverse (s) (declare (optimize (safety 1))) (check-type s sequence);FIXME (labels ((lr (tl &optional hd) (if tl (lr (cdr tl) (cons (car tl) hd)) hd)) (la (&optional (ls (length s)) (r (make-array ls :element-type (array-element-type s))) (i 0) (j (1- ls))) (cond ((and (< i ls) (>= j 0)) (set-array r i s j) (la ls r (1+ i) (1- j))) (r)))) (if (listp s) (lr s) (la)))) (defun subseq (s start &optional end) (declare (optimize (safety 1))) (check-type s sequence) (check-type start seqind) (check-type end (or null seqind)) (if (listp s) (let ((s (nthcdr start s))) (ldiff s (when end (nthcdr (- end start) s)))) (let* ((ls (length s))(n (- (if (when end (< end ls)) end ls) start))) (set-array-n (make-array n :element-type (array-element-type s)) 0 s start n)))) #-pre-gcl (eval-when (compile) (load (merge-pathnames "gcl_defseq.lsp" *compile-file-pathname*))) (defseq find ((item) s) (labels ((find-loop (i p) (unless (or (< i start) (>= i end) (when l (endp p))) (let ((el (el p i))) (when (test item el) (return-from find el))) (find-loop (if jj i (+ i j)) (cdr p))))) (find-loop (if from-end (1- end) start) (when l (or r s))))) (defseq position ((item) s) (labels ((position-loop (i p) (unless (or (< i start) (>= i end) (when l (endp p))) (when (test item (el p i)) (return-from position i)) (position-loop (+ i j) (cdr p))))) (position-loop (if from-end (1- end) start) (when l (or r s))))) (defseq count ((item) s) (labels ((count-loop (i p k) (if (or (< i start) (>= i end) (>= k end) (when l (endp p))) (the seqbnd k);FIXME (count-loop (if jj i (+ i j)) (cdr p) (+ k (if (test item (el p i)) 1 0)))))) (count-loop (if from-end (1- end) start) (when l (or r s)) 0))) (defseq remove ((item) seq :count t) (let* ((indl (cons (unless l lsa) nil))(inds (when from-end indl)) indp indt) (declare (dynamic-extent inds indl indt));FIXME consider removing indices for lists (labels ((remove-loop (i p) (unless (or (< i start) (>= i end) (when l (endp p)) (<= cnt 0)) (when (test item (el p i)) (cond (from-end (push (hd p i) inds)) ((setq indt (cons (hd p i) nil)) (collect indt inds indp))) (when count (decf cnt))) (remove-loop (if jj i (+ i j)) (cdr p))))) (remove-loop (if from-end (1- end) start) (when l (or r s))) (unless from-end (collect indl inds indp))) (unless (cdr inds) (return-from remove seq)) (cond ((listp seq) (let (w r rp) (dolist (ind inds r) (declare (proper-list ind));FIXME (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (unless ind (collect q r rp)) (setq w ind)) (collect (cons (car q) nil) r rp))))) ((let* ((q (make-array (- lsa (1- (length inds))) :element-type (array-element-type s)))) (do* ((inds inds (cdr inds))(n -1 nn)(nn (car inds) (car inds))(k 0 (1+ k)))((not inds) q) (declare (seqind nn k));FIXME (set-array-n q (- n (1- k)) seq (1+ n) (- nn n)))))))) (defseq delete ((item) seq :count t) (let* ((indl (cons (unless l lsa) nil))(inds (when from-end indl)) indp indt) (declare (dynamic-extent inds indl indt)) (labels ((delete-loop (i p) (unless (or (< i start) (>= i end) (when l (endp p)) (<= cnt 0)) (when (test item (el p i)) (cond (from-end (push (hd p i) inds)) ((setq indt (cons (hd p i) nil)) (collect indt inds indp))) (when count (decf cnt))) (delete-loop (if jj i (+ i j)) (cdr p))))) (delete-loop (if from-end (1- end) start) (when l (or r s))) (unless from-end (collect indl inds indp))) (unless (cdr inds) (return-from delete seq)) (cond ((listp seq) (let (w r rp) (dolist (ind inds r) (declare (proper-list ind));FIXME (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (unless ind (collect q r rp)) (setq w ind)) (collect q r rp))))) ((let* ((lq (- lsa (1- (length inds)))) (q (if (array-has-fill-pointer-p seq) seq (make-array lq :element-type (array-element-type s))))) (do* ((inds inds (cdr inds))(n -1 nn)(nn (car inds) (car inds))(k 0 (1+ k)))((not inds) (when (eq seq q) (setf (fill-pointer q) lq)) q) (declare (seqind nn k));FIXME (set-array-n q (- n (1- k)) seq (1+ n) (- nn n)))))))) (defseq nsubstitute ((new item) seq :count t) (labels ((nsubstitute-loop (i p) (if (or (< i start) (>= i end) (when l (endp p)) (<= cnt 0)) seq (progn (when (test item (el p i)) (cond (l (setf (car (hd p i)) new))((setf (aref seq i) new))) (when count (decf cnt))) (nsubstitute-loop (if jj i (+ i j)) (cdr p)))))) (nsubstitute-loop (if from-end (1- end) start) (when l (or r s))))) (defseq substitute ((new item) seq :count t) (let* ((indl (cons (unless l lsa) nil))(inds (when from-end indl)) indp indt) (declare (dynamic-extent inds indl indt)) (labels ((substitute-loop (i p) (unless (or (< i start) (>= i end) (when l (endp p)) (<= cnt 0)) (when (test item (el p i)) (cond (from-end (push (hd p i) inds)) ((setq indt (cons (hd p i) nil)) (collect indt inds indp))) (when count (decf cnt))) (substitute-loop (if jj i (+ i j)) (cdr p))))) (substitute-loop (if from-end (1- end) start) (when l (or r s))) (unless from-end (collect indl inds indp))) (unless (cdr inds) (return-from substitute seq)) (cond ((listp seq) (let (w r rp) (dolist (ind inds r) (declare (proper-list ind));FIXME (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (collect (if ind (cons new nil) q) r rp) (setq w ind)) (collect (cons (car q) nil) r rp))))) ((let* ((q (make-array lsa :element-type (array-element-type s)))) (do* ((inds inds (cdr inds))(n -1 nn)(nn (car inds) (car inds)))((not inds) q) (declare (seqind nn));FIXME (set-array-n q (1+ n) seq (1+ n) (- nn n)) (when (cdr inds) (setf (aref q nn) new)))))))) (defseq remove-duplicates (nil seq) (let ((e (if l (- end start) end))(st (if l 0 start))) (declare (seqbnd e st));FIXME (remove-if (lambda (x) (position x (if (unless from-end l) (setq e (1- e) s (cdr s)) s) :start (if (or l from-end) st (incf st)) :end (if from-end (decf e) e) :test (lambda (x y) (test (key x) y)))) seq :start start :end end :from-end from-end))) (defseq delete-duplicates (nil seq) (let ((e (if l (- end start) end))(st (if l 0 start))) (declare (seqbnd e st));FIXME (delete-if (lambda (x) (position x (if (unless from-end l) (setq e (1- e) s (cdr s)) s) :start (if (or l from-end) st (incf st)) :end (if from-end (decf e) e) :test (lambda (x y) (test (key x) y)))) seq :start start :end end :from-end from-end))) (defun reduce (fd s &key key from-end (start 0) end (initial-value nil ivp) &aux (kf (when key (coerce key 'function)))(f (coerce fd 'function)) (l (listp s))(e (or end (if l (1- array-dimension-limit) (length s))))) (declare (optimize (safety 1))) (check-type fd function-designator) (check-type s sequence) (check-type key (or null function-designator)) (check-type start seqind) (check-type end (or null seqind)) (labels ((k (s i &aux (z (if l (car s) (aref s i)))) (if kf (funcall kf z) z)) (fc (r k) (values (funcall f (if from-end k r) (if from-end r k)))) (rl (s i res) (cond ((or (>= i e) (when l (endp s))) res) (from-end (fc (rl (if l (cdr s) s) (1+ i) (if ivp res (k s i))) (if ivp (k s i) res))) ((rl (if l (cdr s) s) (1+ i) (fc res (k s i))))))) (let ((s (if l (nthcdr start s) s))) (cond (ivp (rl s start initial-value)) ((or (>= start e) (when l (endp s))) (values (funcall f))) ((rl (if l (cdr s) s) (1+ start) (k s start))))))) (defun every (pred seq &rest seqs &aux (pred (coerce pred 'function))) (declare (optimize (safety 1))(dynamic-extent seqs)) (check-type pred function-designator) (check-type seq proper-sequence) (apply 'map nil (lambda (x &rest r) (unless (apply pred x r) (return-from every nil))) seq seqs) t) (defun some (pred seq &rest seqs &aux (pred (coerce pred 'function))) (declare (optimize (safety 1))(dynamic-extent seqs)) (check-type pred function-designator) (check-type seq proper-sequence) (apply 'map nil (lambda (x &rest r &aux (v (apply pred x r))) (when v (return-from some v))) seq seqs)) (defun notevery (pred seq &rest seqs) (declare (optimize (safety 1))(dynamic-extent seqs)) (check-type pred function-designator) (check-type seq proper-sequence) (not (apply 'every pred seq seqs))) (defun notany (pred seq &rest seqs) (declare (optimize (safety 1))(dynamic-extent seqs)) (check-type pred function-designator) (check-type seq proper-sequence) (not (apply 'some pred seq seqs))) (defun seqtype (sequence) (cond ((listp sequence) 'list) ((stringp sequence) 'string) ((bit-vector-p sequence) 'bit-vector) ((vectorp sequence) (list 'vector (array-element-type sequence))) (t (error "~S is not a sequence." sequence)))) (defun fill (sequence item &key (start 0) end) (declare (optimize (safety 1))) (check-type sequence proper-sequence) (check-type start (or null seqind)) (check-type end (or null seqind)) (nsubstitute-if item (lambda (x) (declare (ignore x)) t) sequence :start start :end end)) (defun replace (s1 s2 &key (start1 0) end1 (start2 0) end2 &aux (os1 s1) s3) (declare (optimize (safety 1))(notinline make-list)(dynamic-extent s3)) (check-type s1 sequence) (check-type s2 sequence) (check-type start1 seqind) (check-type start2 seqind) (check-type end1 (or null seqind)) (check-type end2 (or null seqind)) (let* ((lp1 (listp s1)) (lp2 (listp s2)) (e1 (or end1 (if lp1 (1- array-dimension-limit) (length s1)))) (e2 (or end2 (if lp2 (1- array-dimension-limit) (length s2))))) (if (unless (or lp1 lp2) (eq (array-element-type s1) (array-element-type s2))) (set-array-n s1 start1 s2 start2 (min (- e1 start1) (- e2 start2))) (progn (when (and (eq s1 s2) (> start1 start2)) (setq s3 (make-list (length s2)) s2 (replace s3 s2) lp2 t e2 (1- array-dimension-limit))) (do ((i1 start1 (1+ i1))(i2 start2 (1+ i2)) (s1 (if lp1 (nthcdr start1 s1) s1) (if lp1 (cdr s1) s1)) (s2 (if lp2 (nthcdr start2 s2) s2) (if lp2 (cdr s2) s2))) ((or (not s1) (>= i1 e1) (not s2) (>= i2 e2)) os1) (let ((e2 (if lp2 (car s2) (aref s2 i2)))) (if lp1 (setf (car s1) e2) (setf (aref s1 i1) e2)))))))) (defseq mismatch (nil (s1 s2)) (let* ((s2 (or r s))(i2 (if from-end (1- end2) start2))(j (if from-end -1 1))) (or (let ((x (position-if-not (lambda (x) (unless (or (< i2 start2) (>= i2 end2) (when l (endp s2))) (let ((el (el s2 i2))) (incf i2 j)(setq s2 (if l (cdr s2) s2)) (test (key x) el)))) s1 :from-end from-end :start start1 :end end1))) (when x (if from-end (1+ x) x))) (unless (or (< i2 start2) (>= i2 end2) (when l (endp s2))) (if from-end start1 (let ((ln1 (length s1))) (if end1 (min end1 ln1) ln1))))))) (defun nonregexp-string-p (str s e) (when (and (stringp str) (zerop s) (if e (eql e (length str)) t));FIXME frame (map nil (lambda (x) (case (char-code x) (#.(mapcar 'char-code (coerce "\\^$.|?*+()[]{}" 'list)) (return-from nonregexp-string-p nil)))) str) t)) (declaim (inline nonregexp-string-p)) (defseq search (nil (s1 s2));consider (position-if-not 'eql-is-eq s1 :start start1 :end end1) (unless (or test test-not key from-end) (when (and (stringp s2) (nonregexp-string-p s1 start1 end1)) (let ((x (string-match s1 s2 start2 end2))) (return-from search (unless (minusp x) x))))) (let ((n (max 0 (- (or end1 (length s1)) start1)))) (do ((p (when l (if from-end (nthcdr (max 0 (1- n)) r) s)) (cdr p)) (i (if from-end (- end2 n) start2) (if (>= i end2) (return nil) (+ i (if from-end -1 1)))));keep i seqbnd ((or (< i start2) (> i (- end2 n)) (when l (endp p)))) (unless (mismatch s1 (or (if l (if from-end (car p) p)) s2) :test (lambda (x y) (test (key x) y)) :start1 start1 :start2 (if p 0 i) :end1 end1 :end2 (if p n (+ i n))) (return i))))) (eval-when (compile eval) (defmacro mrotatef (a b &aux (s (sgen "MRF-S"))) `(let ((,s ,a)) (setf ,a ,b ,b ,s))) (defmacro raref (a seq i j l) `(if ,l (mrotatef (car (aref ,a ,i)) (car (aref ,a ,j))) (set-array ,seq ,i ,seq ,j t))) (defmacro garef (a seq i l) `(if ,l (car (aref ,a ,i)) (aref ,seq ,i)))) (defun sort (seq pred &key (key 'identity)) (declare (optimize (safety 1))) (check-type seq proper-sequence) (let* ((ll (length seq)) (list (listp seq)) (a (when list (make-array ll)))) (when list (do ((fi 0 (1+ fi)) (l seq (cdr l))) ((>= fi ll)) (setf (aref a fi) l))) (do ((ii (list ll 0))) ((not ii) seq) (declare (dynamic-extent ii)) (let* ((ls (pop ii)) (fi (pop ii))) (declare (seqind ls fi)) (do nil ((>= fi (1- ls))) (let* ((spi (+ fi (random (- ls fi)))) (sp (garef a seq spi list)) (sp (if key (funcall key sp) sp))) (raref a seq fi spi list) (do ((lf fi) (rt ls)) ((>= lf rt)) (declare (seqind lf rt));FIXME (do ((q t)) ((or (>= (if q (incf lf) lf) (if q rt (decf rt))) (let* ((f (garef a seq (if q lf rt) list)) (f (if key (funcall key f) f))) (and (not (funcall pred (if q f sp) (if q sp f))) (setq q (not q))))))) (let* ((r (< lf rt)) (f (if r lf fi)) (s (if r rt (setq spi (1- lf))))) (raref a seq f s list))) (let* ((ospi (1+ spi)) (b (< (- ls ospi) (- spi fi))) (lf (if b ospi 0)) (rt (if b 0 spi)) (b1 (if b (> (- ls lf) 1) (> (- rt fi) 1))) (ns (if b lf fi)) (ns1 (if b ls rt)) (nls (if b spi ls)) (nfi (if b fi ospi))) (when b1 (push ns ii) (push ns1 ii)) (setq ls nls fi nfi)))))))) (defun stable-sort (sequence predicate &key key) (declare (optimize (safety 1))) (check-type sequence proper-sequence) (typecase sequence (list (list-merge-sort sequence predicate key)) (string (sort sequence predicate :key key)) (bit-vector (sort sequence predicate :key key)) (otherwise (replace sequence (list-merge-sort (coerce sequence 'list) predicate key))))) (eval-when (compile eval) (defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) (defmacro f- (x y) `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))) (defun merge (result-type sequence1 sequence2 predicate &key (key #'identity) &aux (l1 (length sequence1)) (l2 (length sequence2))) (declare (optimize (safety 1))) (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)))))) (defmacro with-hash-table-iterator ((name hash-table) &body body) (declare (optimize (safety 1))) (let ((table (sgen)) (ind (sgen)) (size (sgen))) `(let* ((,table ,hash-table) (,ind -1) (,size (1- (hash-table-size ,table)))) (macrolet ((,name nil `(do nil ((>= ,',ind ,',size)) (let* ((e (hashtable-self ,',table (incf ,',ind))) (k (htent-key e))) (unless (eql +objnull+ k) (return (values t (nani k) (htent-value e)))))))) ,@body)))) (defun copy-seq (s) (declare (optimize (safety 1))) (check-type s sequence) (if (listp s) (copy-list s) (let* ((n (length s)) (o (make-array n :element-type (array-element-type s)))) (set-array-n o 0 s 0 n)))) gcl-2.7.1/lsp/PaxHeaders/gcl_bnum.lsp0000644000000000000000000000013214774225145014463 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.344938378 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_bnum.lsp0000644000175000017500000000355014774225145014064 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;; -*-Lisp-*- (in-package :si) (defun cnum-type (x) (let ((y (c-type x))) (if (/= y #.(c-type #c(0 1))) y (case (c-type (complex-real (the complex x))) (#.(c-type 0.0s0) #.(1+ c-type-max)) (#.(c-type 0.0) #.(+ 2 c-type-max)) (otherwise y))))) ;FIXME no declaim yet in default init position (si::putprop 'cnum-type t 'compiler::cmp-inline) (defun ratio-to-double (x &aux nx ny) (declare (inline isnormal)) (let ((y (denominator x)) (x (numerator x))) (do ((dx (float x)) (dy (float y))) ((or (zerop dx) (zerop dy) (progn (setq nx (isnormal dx) ny (isnormal dy)) (and nx ny))) (/ dx dy)) (if nx (setq dx (* 0.5 dx)) (setq x (ash x -1) dx (float x))) (if ny (setq dy (* 0.5 dy)) (setq y (ash y -1) dy (float y)))))) (defun float (x &optional z) (declare (optimize (safety 2))) (check-type x real) (check-type z (or null float)) (let ((s (typep (or z x) 'short-float))) (etypecase x (short-float (if s x (* 1.0 x))) (long-float (if s (long-to-short x) x)) (fixnum (if s (* 1.0s0 x) (* 1.0 x))) (bignum (let ((z (big-to-double x))) (if s (long-to-short z) z))) (ratio (let ((z (ratio-to-double x))) (if s (long-to-short z) z)))))) (defun realpart (x) (declare (optimize (safety 2))) (check-type x number) (typecase x (real x) (otherwise (c-ocomplex-real x)))) (defun imagpart (x) (declare (optimize (safety 2))) (check-type x number) (typecase x (real (if (floatp x) (float 0 x) 0)) (otherwise (c-ocomplex-imag x)))) (defun numerator (x) (declare (optimize (safety 2))) (check-type x rational) (typecase x (integer x) (otherwise (c-ratio-num x)))) (defun denominator (x) (declare (optimize (safety 2))) (check-type x rational) (typecase x (integer 1) (otherwise (c-ratio-den x)))) gcl-2.7.1/lsp/PaxHeaders/gcl_defstruct.lsp0000644000000000000000000000013214774225145015525 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_defstruct.lsp0000644000175000017500000006700514774225145015133 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'lisp) ;; (export 'defstruct) (in-package :system) (defvar *accessors* (make-array 10 :adjustable t)) (defvar *list-accessors* (make-array 2 :adjustable t)) (defvar *vector-accessors* (make-array 2 :adjustable t)) (defun record-fn (&rest l) (declare (ignore 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 ost) (declare (ignore named default-init predicate no-fun ost)) (let ((access-function (if no-conc slot-name (intern (si:string-concatenate conc-name slot-name))))) (record-fn access-function 'defun '(t) slot-type) (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))) (unless (and (consp tem) include (subtypep include (car tem)) (eql (cdr tem) offset)) (setf (get access-function 'structure-access) (cons (if type type name) offset))))))) nil) (defmacro key-name (key prior-keyword) `(cond ((not (consp ,key)) ,key) (t (unless (endp (cdddr ,key)) (error "Bad key ~S~%" ,key)) (cond ((not (consp (car ,key))) (car ,key)) ((and (eq ,prior-keyword '&key) (not (consp (caar ,key)))) (unless (endp (cddar ,key)) (error "Bad key ~S~%" ,key)) (cadar ,key)) (t (error "Bad key ~S~%" ,key)))))) (defmacro maybe-add-keydef (key keydefs prior-keyword) `(let ((def (cadar (member (key-name ,key ,prior-keyword) ,keydefs :key (lambda (k) (declare (optimize (safety 2))) (when (consp k) (car k))))))) (if def (cond ((not (consp ,key)) (list ,key def)) (t (if (cdr ,key) ,key (list (car ,key) def)))) ,key))) (defun parse-boa-lambda-list (lambda-list keydefs) (let ((keywords '(none &optional &rest &key &allow-other-keys &aux)) vs res tk restvar seen-keys) (do ((ll lambda-list (cdr ll))) ((endp ll)) (let ((key (car ll))) (cond ((setq tk (member key keywords)) (setq keywords tk) (push key res) (push key seen-keys)) ((member key lambda-list-keywords) (error "Keyword ~S appeared in a bad place in BOA lambda list" key)) (t (let ((prior-keyword (car keywords))) (case prior-keyword ((none &rest) (unless (symbolp key) (error "non-symbol appeared in bad place in BOA lambda list" key)) (push key res) (push key vs) (when (eq prior-keyword '&rest) (when restvar (error "Multiple variables after &rest in BOA lambda list")) (setq restvar t))) ((&optional &key) (push (maybe-add-keydef key keydefs prior-keyword) res) (push (key-name key prior-keyword) vs)) (&allow-other-keys (error "Variable ~S appeared after &allow-other-keys in BOA list" key)) (&aux (push key res) (push (key-name key prior-keyword) vs)))))))) (when (and (member '&rest seen-keys) (not restvar)) (error "Missing &rest variable in BOA list")) (unless (member '&aux seen-keys) (push '&aux res)) (do ((ll keydefs (cdr ll))) ((endp ll)) (let* ((keydef (car ll)) (keydef-name (if (atom keydef) keydef (car keydef)))) (unless (member keydef-name vs) (push keydef res)))) (nreverse res))) (defun maybe-cons-keyname (x &optional y) (unless (consp x) (error 'program-error :format-control "x ~S is not a list~%" :format-arguments (list x))) (let ((sn (sixth x))) (if sn (if y (list (list (car x) sn) y) (list (list (car x) sn))) (if y (list (car x) y) (car x))))) (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 (let ((sn (sixth x))) (if sn sn (car x)))))) slot-descriptions)) (keys ;; Make the keyword parameters. (mapcan (lambda (x) (cond ((null x) nil) ((null (car x)) nil) ((null (cadr x)) (list (maybe-cons-keyname x))) (t (list (maybe-cons-keyname x (cadr x)))))) slot-descriptions))) (cond ((consp constructor) (setq keys (parse-boa-lambda-list (cadr constructor) keys)) (setq constructor (car constructor))) (t ;; If not a BOA constructor, just cons &KEY. (setq keys (cons '&key keys)))) (cond ((null type) `(defun ,constructor ,keys (the ,name (si:make-structure ',name ,@slot-names)))) ((eq type 'vector) `(defun ,constructor ,keys (vector ,@slot-names))) ((and (consp type) (eq (car type) 'vector)) (if (endp (cdr type)) `(defun ,constructor ,keys (vector ,@slot-names))) `(defun ,constructor ,keys (make-array ,(length slot-names) :element-type ',(cadr type) :initial-contents (list ,@slot-names)))) ((eq type 'list) `(defun ,constructor ,keys (list ,@slot-names))) ((error "~S is an illegal structure type" 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 nil slot-type))) ;;; 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)) (upgraded-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 rest from the old. (cddddr (car olds))) (overwrite-slot-descriptions news (cdr olds)))) (t (cons (car olds) (overwrite-slot-descriptions news (cdr olds)))))))) (defconstant +aet-type-object+ (aet-type nil)) (defconstant +all-t-s-type+ (make-array 50 :element-type 'unsigned-char :static t :initial-element +aet-type-object+)) (defconstant +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+)) (let ((def +aet-type-object+)) (dotimes (i n) (cond ((not (= (the fixnum (aref res i)) def)) (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)) (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 (ignore include) (special *standard-slot-positions*)) (dolist (v slot-descriptions) (when (and v (car v)) (setf type (upgraded-array-element-type (or (caddr v) t)) (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 ((member 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) )))) ;FIXME reconsider holding on to computed structure types (defun update-sdata-included (name &aux r (i (sdata-includes (get name 's-data)))) (when i (let ((to (cmp-norm-tp `(and ,(sdata-name i) (not (or ,@(sdata-included i)))))) (tn (cmp-norm-tp name))) (labels ((find-updates (x &aux (tp (car x))) (when (unless (tp<= #tstructure tp) (tp-and #tstructure tp)) (let ((ntp (if (tp-and to tp) (tp-or tn tp) tp)));FIXME negative (unless (tp= tp ntp) (setf (car x) ntp) (push (cons tp ntp) r))))) (update-sig (x &aux (y (assoc (car x) r))) (when y (setf (car x) (cdr y))))) (mapl #'find-updates (gethash (tsrch #tstructure) *uniq-tp*));FIXME more systematic (mapl #'find-updates (gethash t *uniq-tp*)) (maphash (lambda (x y) (declare (ignore y)) (mapl #'update-sig (car x)) (if (cmpt (cadr x)) (mapl #'update-sig (cdadr x)) (update-sig (cdr x)))) *uniq-sig*))) (pushnew name (s-data-included i)))) ;FIXME function-src for all functions, sigs for constructor and copier (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) (declare (ignore copier)) (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))) (cond ((and (null type) (eq name 's-data)) ;bootstrapping code! (setq def (make-s-data-structure (make-array (* leng (size-of t)) :element-type 'unsigned-char :static t :initial-element +aet-type-object+) (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)))) (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) (update-sdata-included name))) (when documentation (setf (get name 'structure-documentation) documentation)) (when (and (null type) predicate) (record-fn predicate 'defun '(t) t) (setf (get predicate 'compiler::co1)'compiler::co1structure-predicate) (setf (get predicate 'struct-predicate) name) (setf (get predicate 'predicate-type) name))) nil) (defun str-ref (x y z) (declare (ignore y)) (structure-ref1 x z)) (export 'str-ref) (defmacro defstruct (name &rest slots) (declare (optimize (safety 2))) (let ((slot-descriptions slots) options conc-name constructors default-constructor no-constructor copier predicate predicate-specified include print-function print-object 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 (or v (gensym))) (setq predicate-specified t)) (:include (setq include (cdar os)) (unless (get v 's-data) (error "~S is an illegal included structure." v))) (:print-object (and (consp v) (eq (car v) 'function) (setq v (second v))) (setq print-object 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))) (when (and print-function print-object) (error "Cannot specify both :print-function and :print-object.")) (when print-object (setq print-function (lambda (x y z) (declare (optimize (safety 2))) (declare (ignore z)) (funcall print-object x y)))) (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.")) (let* ((tp (cond ((not type) nil) ((subtypep type 'list) 'list) ((subtypep type 'vector) 'vector))) (ctp (cond ((or (not type) named) name) (tp))) new-slot-descriptions (new-slot-descriptions ;(copy-list slot-descriptions))) (dolist (sd slot-descriptions (nreverse new-slot-descriptions)) (if (and (consp sd) (eql (length sd) 7)) (let* ((csd (car sd)) (sym (when (or (constantp csd) (keywordp csd) (si::specialp csd)) (make-symbol (symbol-name csd)))) (nsd (if (or (constantp csd) (si::specialp csd)) (cons (intern (symbol-name csd) 'keyword) (cdr sd)) sd))) (push (append (butlast nsd 2) (list sym (car (last nsd)))) new-slot-descriptions) (when sym (setf (car sd) sym))) (push sd new-slot-descriptions))))) `(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 new-slot-descriptions)) constructors) ,@(when copier `((defun ,copier (x) (declare (optimize (safety 1))) (check-type x ,ctp) (the ,ctp ,(ecase tp ((nil) `(copy-structure x)) (list `(copy-list x)) (vector `(copy-seq x))))))) ,@(mapcar (lambda (y) (let* ((sn (pop y)) (nm (if no-conc sn (intern (si:string-concatenate (string conc-name) (string sn))))) (di (pop y)) (st (pop y)) (ro (pop y)) (offset (pop y))) (declare (ignore di ro)) `(defun ,nm (x) (declare (optimize (safety 2))) (check-type x ,ctp) (the ,(or (not st) st) ,(ecase tp ((nil) `(str-refset x ',name ,offset));FIXME possibly macroexpand here, include? (list `(let ((c (nthcdr ,offset x))) (check-type c cons) (car c)));(list-nth ,offset x)) (vector `(aref x ,offset))))))) slot-descriptions) ,@(mapcar (lambda (y) (let* ((sn (car y)) (y (if no-conc sn (intern (si:string-concatenate (string conc-name) (string sn)))))) `(si::putprop ',y t 'compiler::cmp-inline))) slot-descriptions);FIXME ,@(when predicate `((defun ,predicate (x) (declare (optimize (safety 2))) (the boolean ,(ecase tp ((nil) `(typecase x (,name t)));`(structure-subtype-p x ',name) (list (unless named (error "The structure should be named.")) `(let ((x (when (listp x) (nthcdr ,name-offset x)))) (when x (eq (car x) ',name)))) (vector (unless named (error "The structure should be named.")) `(and (typep x '(vector t)) (> (length x) ,name-offset) (eq (aref x ,name-offset) ',name)))))) (si::putprop ',predicate t 'compiler::cmp-inline))) ',name)))) ;; First several fields of this must coincide with the C structure ;; s_data (see object.h). (defstruct s-data (name nil :type symbol) (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.7.1/lsp/PaxHeaders/gcl_translate_pathname.lsp0000644000000000000000000000013114774225145017373 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_translate_pathname.lsp0000644000175000017500000000667314774225145017006 0ustar00cammcamm(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)) (concatenate 'string (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.7.1/lsp/PaxHeaders/gcl_fpe.lsp0000644000000000000000000000013214774225145014274 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.348938404 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_fpe.lsp0000644000175000017500000001413014774225145013671 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :fpe) (import 'si::(disassemble-instruction feenableexcept fedisableexcept fld *fixnum *float *double *fixnum *ushort *uint fun-name si-class-direct-subclasses si-class-name si-find-class +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 (substitute #\; #\# 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 subclasses (class) (when class (cons class (mapcan 'subclasses (si-class-direct-subclasses class))))) (defun code-condition (code) (or (reduce (lambda (y x) (if (subtypep y x) (si-class-name x) y)) (reduce (lambda (&rest r) (when r (apply 'intersection r))) (mapcar (lambda (x) (subclasses (si-find-class (car x)))) (remove code +fe-list+ :key 'caddr :test-not 'logtest))) :initial-value nil) 'arithmetic-error)) (defun floating-point-error (code addr context) (break-on-floating-point-exceptions :suspend t) (restart-case (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))))) (code-condition code) :operation (list :insn (pop m) :op (pop m) :fun fun :addr addr) :operands m :function-name (when fun (fun-name fun)))) (break-on-floating-point-exceptions)) (continue nil :report (lambda (s) (format s "Continue disabling floating point exception trapping")) (apply 'break-on-floating-point-exceptions (mapcan (lambda (x) (list x nil)) (break-on-floating-point-exceptions)))))) gcl-2.7.1/lsp/PaxHeaders/gcl_rename_file.lsp0000644000000000000000000000013114774225145015767 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_rename_file.lsp0000644000175000017500000000334314774225145015371 0ustar00cammcamm(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 (stat 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.7.1/lsp/PaxHeaders/gcl_assert.lsp0000644000000000000000000000013214774225145015023 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.344938378 30 ctime=1744351535.634907855 gcl-2.7.1/lsp/gcl_assert.lsp0000644000175000017500000000574714774225145014436 0ustar00cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 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)) (defun read-evaluated-form nil (format *query-io* "~&type a form to be evaluated:~%") (list (eval (read *query-io*)))) (defun assert-places (places values string &rest args) (declare (dynamic-extent args)) (restart-case (apply 'cerror "Repeat assertion." string args) (store-value (&rest r) :report (lambda (stream) (format stream "Supply a new values for ~s (old values are ~s)." places values)) :interactive (lambda nil (mapcar (lambda (x) (format *query-io* "~&type a form to be evaluated for ~s:~%" x) (eval (read *query-io*))) places)) :test (lambda (c) (declare (ignore c)) places) (declare (dynamic-extent r)) (values-list r)))) (defmacro assert (test-form &optional places string &rest args) (declare (dynamic-extent args)) `(do nil (,test-form nil) (multiple-value-setq ,places (apply 'assert-places ',places (list ,@places) ,@(if string `(,string (list ,@args)) `("The assertion ~:@(~S~) failed." ',test-form nil)))))) (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))))) gcl-2.7.1/lsp/PaxHeaders/gcl_s.lsp0000644000000000000000000000013114774225145013763 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.372938557 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_s.lsp0000644000175000017500000001652014774225145013366 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (in-package :cstruct) (export '(lisp-type defdlfun +ks+ +fl+ strcat adjustable-vector adjustable-array matrix)) (si::import-internal 'si::(\| & ^ ~ c+ c* << >> object double end-shft std-instance c-object-== c-fixnum-== c-float-== c-double-== c-fcomplex-== c-dcomplex-== fcomplex dcomplex string-concatenate lit seqind seqbnd fixnum-length char-length cref address nani short int cnum unsigned-char unsigned-short unsigned-int package-internal package-external array-dims cmp-norm-tp tp0 tp1 tp2 tp3 tp4 tp5 tp6 tp7 tp8)) (dolist (l '((:float "make_shortfloat" short-float cnum);FIXME repetitive with gcl_cmpopt.lsp (:double "make_longfloat" long-float cnum) (:character "code_char" character cnum) (:char "make_fixnum" char cnum) (:short "make_fixnum" short cnum) (:int "make_fixnum" int cnum) (:uchar "make_fixnum" unsigned-char cnum) (:ushort "make_fixnum" unsigned-short cnum) (:uint "make_fixnum" unsigned-int cnum) (:fixnum "make_fixnum" fixnum cnum) (:long "make_fixnum" fixnum cnum) (:fcomplex "make_fcomplex" fcomplex cnum) (:dcomplex "make_dcomplex" dcomplex cnum) (:string "make_simple_string" string) (:object "" t) ; (:stdesig "" (or symbol string character)) (:strstd "" (or structure std-instance)) (:matrix "" matrix) (:adjvector "" adjustable-vector) (:adjarray "" adjustable-array) (:longfloat "" long-float) (:shortfloat "" short-float) (:hashtable "" hash-table) (:ocomplex "" complex) (:bitvector "" bit-vector) (:random "" random-state) (:ustring "" string) (:fixarray "" (array fixnum)) (:sfarray "" (array short-float)) (:lfarray "" (array long-float)) (:real "" real) (:float* nil nil (array short-float) "->sfa.sfa_self") (:double* nil nil (array long-float) "->lfa.lfa_self") (:long* nil nil (array fixnum) "->fixa.fixa_self") (:void* nil nil (array t) "->v.v_self")));FIXME (setf (get (car l) 'lisp-type) (if (cadr l) (caddr l) (cadddr l)))) (si::*make-constant '+fl+ (- (integer-length fixnum-length) 4)) (si::*make-constant '+ks+ `((:char 0 0)(:uchar 0 1)(:short 1 0)(:ushort 1 1)(:int 2 0) ,@(when (member :64bit *features*) `((:uint 2 1))) (:float 2 2) (:double 3 2) (:fcomplex 3 3) (:dcomplex 4 3) (:long ,+fl+ 0) (:fixnum ,+fl+ 0) (:object ,+fl+ 5))) (eval-when (compile) (defmacro idefun (n &rest args) `(progn (defun ,n ,@args) (si::putprop ',n t 'si::cmp-inline) (export ',n))) (defmacro mffe nil `(progn ,@(mapcar (lambda (z &aux (x (pop z))(s (pop z))(m (car z))(n (intern (string-concatenate "*" (string-upcase x))))) `(idefun ,n (x o s y) (declare (fixnum x o) ,@(unless (eq n '*object) `((boolean s)))) ,(cond ((when (eq n '*fixnum) (member :sparc64 *features*));Possibly unaligned access `(if s ;FIXME there does not appear any useful way to lift thie branch into lisp for possible branch elimination (lit :fixnum "((" (:fixnum x) "&(sizeof(fixnum)-1)) ? " "({fixnum _t=" (:fixnum y) ";unsigned char *p1=(void *)(((fixnum *)" (:fixnum x) ")+" (:fixnum o) "),*p2=(void *)&_t,*pe=p1+sizeof(fixnum);for (;p1d.e=1;(((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]=" (,x y) ");})") (lit ,x "((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]")))) (`(if s (lit ,x "(((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]=" (,x y) ")") (lit ,x "((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]")))))) +ks+))) (defmacro mfff nil `(progn (idefun address (x) (lit :fixnum "((fixnum)" (:object x) ")")) (idefun nani (x) (declare (fixnum x)) (lit :object "((object)" (:fixnum x) ")")) (idefun ~ (x) (declare (fixnum x)) (lit :fixnum "(~" (:fixnum x) ")")) ,@(mapcar (lambda (x &aux (c (consp x))(n (if c (car x) x))(s (string (if c (cdr x) x)))) `(idefun ,n (x y) (declare (fixnum x y)) (lit :fixnum "(" (:fixnum x) ,s (:fixnum y) ")"))) '(& \| ^ >> << (c+ . +) (c* . *) (c- . -) (c/ . /) %)) (idefun tp0 (x) (lit :fixnum "tp0(" (:object x) ")")) (idefun tp1 (x) (lit :fixnum "tp1(" (:object x) ")")) (idefun tp2 (x) (lit :fixnum "tp2(" (:object x) ")")) (idefun tp3 (x) (lit :fixnum "tp3(" (:object x) ")")) (idefun tp4 (x) (lit :fixnum "tp4(" (:object x) ")")) (idefun tp5 (x) (lit :fixnum "tp5(" (:object x) ")")) (idefun tp6 (x) (lit :fixnum "tp6(" (:object x) ")")) (idefun tp7 (x) (lit :fixnum "tp7(" (:object x) ")")) (idefun tp8 (x) (lit :fixnum "tp8(" (:object x) ")")) ,@(mapcan (lambda (x) (mapcan (lambda (y) (mapcar (lambda (z) (let ((n (intern (string-upcase (strcat "C-" (string x) "-" (string y) "-" (string z)))))) `(idefun ,n (x y) (lit :boolean "(" (,x x) ,(string z) (,y y) ")")))) '(>))) '(:fixnum :float :double))) '(:fixnum :float :double)) ,@(mapcan (lambda (x) (mapcan (lambda (y) (mapcar (lambda (z) (let ((n (intern (string-upcase (strcat "C-" (string x) "-" (string y) "-" (string z)))))) `(idefun ,n (x y) (lit :boolean "(" (,x x) ,(string z) (,y y) ")")))) '(==))) '(:fixnum :float :double :fcomplex :dcomplex))) '(:fixnum :float :double :fcomplex :dcomplex)) ,@(mapcar (lambda (x &aux (tp (intern (string x)))(tp (or (eq tp 'object) tp))(n (intern (string-upcase (strcat "C-" x "-=="))))) `(idefun ,n (x y) (declare (,tp x y))(lit :boolean (,x x) "==" (,x y)))) '(:object :fixnum :float :double :fcomplex :dcomplex))))) (eval-when (eval) #.`(progn ,@(mapcar #'(lambda (z &aux (x (pop z))(s (pop z))(m (car z))(n (intern (string-concatenate "*" (string-upcase x))))) `(progn (defun ,n (x o s y) (declare (fixnum x o)(boolean s)) (cref (c+ x (<< o ,s)) ,(<< 1 s) ,m (if s 1 0) y)) (si::putprop ',n t 'si::cmp-inline) (export ',n))) +ks+)) (defun mffe nil nil) (defun mfff nil nil)) (mffe) (mfff) gcl-2.7.1/lsp/PaxHeaders/gcl_mnum.lsp0000644000000000000000000000013114774225145014475 xustar0030 mtime=1743858277.045814259 30 atime=1744346652.093823691 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_mnum.lsp0000644000175000017500000002411214774225145014074 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;; -*-Lisp-*- (in-package :si) #+c99 (progn (eval-when (compile eval) (defmacro deflibmfun (x) `(progn (defdlfun (:float ,(strcat x "f") ) :float) (defdlfun (:double ,x ) :double) (defdlfun (:fcomplex ,(strcat "c" x "f") ) :fcomplex) (defdlfun (:dcomplex ,(strcat "c" x) ) :dcomplex))) (defmacro defrlibmfun (x &optional y) `(progn (defdlfun (:float ,(strcat x "f") ) :float :float) (defdlfun (:double ,x ) :double :double) ,@(when y `((defdlfun (:fcomplex ,(strcat "c" x "f") ) :fcomplex :fcomplex) (defdlfun (:dcomplex ,(strcat "c" x) ) :dcomplex :dcomplex))))) (defmacro defrlibmfun1 (x) `(progn (defdlfun (:float ,(strcat x "f") ) :float) (defdlfun (:double ,x ) :double))) (defmacro defalibmfun (x) `(progn (defdlfun (:float ,(strcat "f" x "f") ) :float) (defdlfun (:double ,(strcat "f" x) ) :double) (defdlfun (:fixnum ,(strcat "l" x) ) :fixnum) (defdlfun (:float ,(strcat "c" x "f") ) :fcomplex) (defdlfun (:double ,(strcat "c" x) ) :dcomplex)))) (defalibmfun "abs") (deflibmfun "exp") (defrlibmfun "pow" t) (deflibmfun "log") (deflibmfun "sqrt") (deflibmfun "sin") (deflibmfun "cos") (deflibmfun "tan") (deflibmfun "sinh") (deflibmfun "cosh") (deflibmfun "tanh") (deflibmfun "asin") (deflibmfun "acos") (deflibmfun "atan") (defrlibmfun "atan2") (deflibmfun "asinh") (deflibmfun "acosh") (deflibmfun "atanh") (defrlibmfun1 "erf") (defrlibmfun1 "erfc") (defrlibmfun1 "lgamma") (defrlibmfun1 "tgamma") (defdlfun (:float "cargf" ) :fcomplex) (defdlfun (:double "carg" ) :dcomplex) (defun bsqrt (x);this is an instruction, or a jump to main body (declare (long-float x)) (lit :double "sqrt(" (:double x) ")")) (setf (get 'bsqrt 'compiler::cmp-inline) t) (defun bsqrtf (x);this is an instruction, or a jump to main body (declare (short-float x)) (lit :float "sqrtf(" (:float x) ")")) (setf (get 'bsqrtf 'compiler::cmp-inline) t) (eval-when (compile eval) (defmacro defmfun (x &optional n protect-real sqrtp) (let* ((b (if sqrtp 'bsqrt (mdlsym x))) (f (if sqrtp 'bsqrtf (mdlsym (string-concatenate x "f")))) (c (mdlsym (string-concatenate "c" x))) (cf (mdlsym (string-concatenate "c" x "f"))) (ts (intern (string-upcase x))) (tp (get ts 'compiler::type-propagator)) (body `(typecase x (long-float (,b x)) (short-float (,f x)) ,@(when sqrtp `((bignum (max (,b (float x 0.0)) (float (isqrt x) 0.0))))) (rational (,b (float x 0.0))) (dcomplex (,c x)) (fcomplex (,cf x)) (otherwise (,c (complex (float (realpart x) 0.0) (float (imagpart x) 0.0))))))) `(progn (mdlsym ,x) (mdlsym (string-concatenate ,x "f")) (mdlsym (string-concatenate "c" ,x)) (mdlsym (string-concatenate "c" ,x "f")) (setf (get ',b 'compiler::type-propagator) ',tp) (setf (get ',f 'compiler::type-propagator) ',tp) (setf (get ',c 'compiler::type-propagator) ',tp) (setf (get ',cf 'compiler::type-propagator) ',tp) (defun ,(or n (intern (string-upcase x))) (x) ,@(unless (and n (not (string= (string-upcase n) (string-upcase x)))) `((declare (optimize (safety 2))) (check-type x number))) ,(if protect-real `(if (and (realp x) ,protect-real) ,body (let ((x (cond ((not (realp x)) x) ((floatp x) (complex x (float 0.0 x))) ((complex (float x 0.0) 0.0))))) ,body)) body))))) (defmacro defmlog (x &optional n) (let* ((b (mdlsym x)) (f (mdlsym (string-concatenate x "f"))) (c (mdlsym (string-concatenate "c" x))) (cf (mdlsym (string-concatenate "c" x "f"))) (ts (intern (string-upcase x))) (tp (get ts 'compiler::type-propagator))) `(progn (mdlsym ,x) (mdlsym (string-concatenate ,x "f")) (mdlsym (string-concatenate "c" ,x)) (mdlsym (string-concatenate "c" ,x "f")) (setf (get ',b 'compiler::type-propagator) ',tp) (setf (get ',f 'compiler::type-propagator) ',tp) (setf (get ',c 'compiler::type-propagator) ',tp) (setf (get ',cf 'compiler::type-propagator) ',tp) (defun ,(or n (intern (string-upcase x))) (x) ,@(unless (and n (not (string= (string-upcase n) (string-upcase x)))) `((declare (optimize (safety 2))) (check-type x number))) (etypecase x (fixnum (,b (float x 0.0))) (integer (ilog x)) (rational (- (ilog (numerator x)) (ilog (denominator x)))) (short-float (,f x)) (long-float (,b x)) (fcomplex (,cf x)) (dcomplex (,c x)) (complex (,c (complex (float (realpart x) 0.0) (float (imagpart x) 0.0))))))))) (defmacro defmabs (x &optional n) (let* ((i 'babs);(mdlsym (string-concatenate "l" x))) (b (mdlsym (string-concatenate "f" x))) (f (mdlsym (string-concatenate "f" x "f"))) (c (mdlsym (string-concatenate "c" x))) (cf (mdlsym (string-concatenate "c" x "f"))) (ts (intern (string-upcase x))) (tp (get ts 'compiler::type-propagator))) `(progn (mdlsym ,x) (mdlsym (string-concatenate "f" ,x)) (mdlsym (string-concatenate "c" ,x)) (setf (get ',i 'compiler::type-propagator) ',tp) (setf (get ',b 'compiler::type-propagator) ',tp) (setf (get ',f 'compiler::type-propagator) ',tp) (setf (get ',c 'compiler::type-propagator) ',tp) (setf (get ',cf 'compiler::type-propagator) ',tp) (defun ,(or n (intern (string-upcase x))) (x) ,@(unless n `((declare (optimize (safety 2))) (check-type x number))) (typecase x (long-float (,b x)) (short-float (,f x)) (fixnum (if (= x most-negative-fixnum) (- most-negative-fixnum) (,i x))) (rational (if (minusp x) (- x) x)) (dcomplex (,c x)) (fcomplex (,cf x)) (otherwise (,c (complex (float (realpart x) 0.0) (float (imagpart x) 0.0))))))))) (defmacro defrmfun (x &optional n) (let ((b (mdlsym x)) (f (mdlsym (string-concatenate x "f"))) (tp (get 'atan 'compiler::type-propagator)));FIXME `(progn (mdlsym ,x) (mdlsym (string-concatenate ,x "f")) (setf (get ',b 'compiler::type-propagator) ',tp) (setf (get ',f 'compiler::type-propagator) ',tp) (defun ,(or n (intern (string-upcase x))) (x z) ,(unless n `((declare (optimize (safety 2))) (check-type x real) (check-type z real))) (typecase z (long-float (typecase x (long-float (,b x z)) (short-float (,b (float x z) z)) (fixnum (,b (float x z) z)) (rational (,b (float x z) z)))) (short-float (typecase x (long-float (,b x (float z x))) (short-float (,f x z)) (fixnum (,f (float x z) z)) (rational (,f (float x z) z)))) (fixnum (typecase x (long-float (,b x (float z x))) (short-float (,f x (float z x))) (fixnum (,b (float x 0.0) (float z 0.0))) (rational (,b (float x 0.0) (float z 0.0))))) (rational (typecase x (long-float (,b x (float z x))) (short-float (,f x (float z x))) (fixnum (,b (float x 0.0) (float z 0.0))) (rational (,b (float x 0.0) (float z 0.0))))))))))) (defun babs (x) (declare (fixnum x)) (lit :fixnum "labs(" (:fixnum x) ")"));this is a builtin in recent gcc (setf (get 'babs 'compiler::cmp-inline) t) (defmabs "abs") (defmfun "sin") (defmfun "cos") (defmfun "tan") (defmfun "asinh") (defmfun "sinh") (defmfun "cosh") (defmfun "tanh") (defmfun "exp" rawexp) (defun exp (x) (declare (inline rawexp)) (check-type x number) (rawexp x)) ;(defrmfun "pow" expt) (defrmfun "atan2" rawatan2) (defmfun "atan" rawatan) (defun atan (x &optional (z 0.0 zp)) (declare (optimize (safety 2)) (inline rawatan2 rawatan)) (check-type x number) (check-type z real) (cond (zp (check-type x real) (rawatan2 x z)) ((rawatan x)))) (defun ilog (n &aux (l (integer-length n))) (+ (plog (float (/ n (ash 1 l)))) (* (plog 2.0) l))) (declaim (inline ilog)) (defmlog "log" plog) (declaim (inline plog)) (defun rawlog (x) (cond ((complexp x) (let* ((z (max (abs (realpart x)) (abs (imagpart x))))) (+ (plog z) (plog (complex (/ (realpart x) z) (/ (imagpart x) z)))))) ((minusp x) (+ (plog (- x)) (plog (complex -1 (if (floatp x) (float 0.0 x) 0.0))))) ((plog x)))) (defun log (x &optional b) (declare (optimize (safety 2)) (inline rawlog)) (check-type x number) (check-type b (or null number)) (if b (/ (log x) (log b)) (rawlog x))) (defmfun "acosh" acosh (>= x 1)) (defmfun "atanh" atanh (and (>= x -1) (<= x 1))) (defmfun "acos" acos (and (>= x -1) (<= x 1))) (defmfun "asin" asin (and (>= x -1) (<= x 1))) (defmfun "sqrt" sqrt (>= x 0) t) (defun isfinite (x) (typecase x (short-float (lit :boolean "__builtin_isfinite(" (:float x) ")")) (long-float (lit :boolean "__builtin_isfinite(" (:double x) ")")))) (setf (get 'isfinite 'compiler::cmp-inline) t) (defun isnormal (x) (typecase x (short-float (lit :boolean "__builtin_isnormal(" (:float x) ")")) (long-float (lit :boolean "__builtin_isnormal(" (:double x) ")")))) (setf (get 'isnormal 'compiler::cmp-inline) t) ) #-c99 (defun abs (z) (declare (optimize (safety 2))) (check-type z number) (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)))))))) ((minusp z) (- z)) (z))) ;; (defdlfun (:fixnum "__gmpz_cmp") :fixnum :fixnum) ;; #.(let ((x (truncate fixnum-length char-length))) ;; `(defun mpz_cmp (x y) (|libgmp|:|__gmpz_cmp| (+ ,x (address x)) (+ ,x (address y)))));FIXME ;; (setf (get 'mpz_cmp 'compiler::cmp-inline) t) (defdlfun (:fixnum "memcpy") :fixnum :fixnum :fixnum) #.`(defun memcpy (a b c) (declare (fixnum a b c)) (lit :fixnum "{fixnum f=1;f;}");(side-effects) (,(mdlsym "memcpy") a b c)) (declaim (inline memcpy)) (defdlfun (:fixnum "memmove") :fixnum :fixnum :fixnum) #.`(defun memmove (a b c) (declare (fixnum a b c)) (lit :fixnum "{fixnum f=1;f;}");(side-effects) (,(mdlsym "memmove") a b c)) (declaim (inline memmove)) gcl-2.7.1/lsp/PaxHeaders/gcl_restart.lsp0000644000000000000000000000013114774225145015205 xustar0030 mtime=1743858277.045814259 30 atime=1744340056.368938532 29 ctime=1744351535.63890782 gcl-2.7.1/lsp/gcl_restart.lsp0000644000175000017500000001641014774225145014606 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;;; -*- 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)) (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 y) `(when ,x (setf (getf rr ,y) (list 'function ,x))))) (do-setf report :report-function) (do-setf interactive :interactive-function) (do-setf test :test-function) 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-nf 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 *debug-io* "~& ~4d ~a ~a ~%" (incf i) (cond ((eq x *debug-abort*) "(abort)") ((eq x *debug-continue*) "(continue)") ("")) x)) *debug-restarts*) nil) gcl-2.7.1/PaxHeaders/cmpnew0000644000000000000000000000013114776006046012571 xustar0030 mtime=1744309286.150034344 30 atime=1744351538.814879383 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/0000755000175000017500000000000014776006046012245 5ustar00cammcammgcl-2.7.1/cmpnew/PaxHeaders/gcl_collectfn.lsp0000644000000000000000000000013114774225213016161 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.476939222 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_collectfn.lsp0000644000175000017500000003435314774225213015570 0ustar00cammcamm;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;;;; ;;; Copyright (c) 1989 by William Schelter,University of Texas ;;;;; ;;; Copyright (c) 2024 Camm Maguire ;;; 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 ) (si::freeze-defstruct 'fn) (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) (declare (ignore 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)) (let ((sym (si::funid-sym (second *current-form*)))) (symbol-package sym)));;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::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 (or (si::si-classp (var-type v)) (si::structurep (var-type v)) (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 '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) (declare (ignore files)) ;; (setup-sys-proclaims) ;; (dolist (v files) ;; (mapcar 'load (directory v))) (write-sys-proclaims "sys-proclaim.lisp")) ;; (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 (truename *load-pathname*)));*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::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)))))))))) (defun get-packages-ansi (pl &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) (setq pl (sort (copy-list pl) (lambda (x y) (member (find-package y) (package-used-by-list (find-package x)))))) (get-packages-ansi pl st 'establish) (get-packages-ansi pl st 'export) (get-packages-ansi pl st 'shadow) (format st "~2%") (return-from get-packages-ansi nil)))) (dolist (p pl) (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 (pr `(unless (find-package ,(package-name p)) (make-package ,(package-name p) :use ',(mapcar 'package-name (package-use-list p)) ,@(when (package-nicknames p) `(:nicknames ',(package-nicknames p))))))) (export (let (ext (*package* p) imps) (do-external-symbols (sym p) (push sym ext) (unless (eq (symbol-package sym) p) (push sym imps))) (pr `(import ',imps ,(package-name p))) (pr `(export ',ext ,(package-name p))))) (shadow (print p) (let (in out (*package* (find-package "CL"))) (dolist (v (package-shadowing-symbols p)) (if (eq (symbol-package v) p) (push v in) (push v out)));FIXME push if (pr `(shadow ',in ,(package-name p))) (pr `(shadowing-import ',out ,(package-name p))) (let (imp) (do-symbols (v p) (unless (eq (symbol-package v) p) (push v imp))) (pr `(import ',imp ,(package-name p))))))))))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpmap.lsp0000644000000000000000000000013114774225213015465 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.472939196 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpmap.lsp0000755000175000017500000000241714774225213015073 0ustar00cammcamm;;; 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) (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.7.1/cmpnew/PaxHeaders/gcl_cmpif.lsp0000644000000000000000000000013114774225213015306 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.452939068 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpif.lsp0000644000175000017500000010742114774225213014712 0ustar00cammcamm;;; CMPIF Conditionals. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 '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 note-branch-elimination (test-form val elim-form) (eliminate-src elim-form) (keyed-cmpnote (list 'branch-elimination test-form) "Test form ~S is ~S,~%;; eliminating branch ~S~%" test-form val elim-form)) (defconstant +gen+ (make-var :name (gensym))) ;(defconstant +gen+ (gensym)) (defun tp-reduce (f1 f2 l1 l2) (labels ((c1 (c l2 &aux (d (cdr c))(m (cdr (or (assoc (car c) l2) (assoc +gen+ l2) '(nil t . t))))) (cons (car c) (cons (funcall f1 (car m) (car d)) (funcall f2 (cdr m) (cdr d)))))) (remove-duplicates (append (mapcar (lambda (x) (c1 x l2)) l1) (mapcar (lambda (x) (c1 x l1)) l2)) :key 'car))) ;; (defun tp-reduce (f1 f2 l1 l2 &optional r) ;; (labels ((m (l1 l2) (cdr (or (assoc (caar l1) l2) (assoc +gen+ l2) ;; (when (eq (caar l1) +gen+) (car l1)) '(nil t . t)))) ;; (c (l1 l2 &aux (c (car l1))(d (cdr c))(m (m l1 l2))) ;; (cons (car c) ;; (cons ;; (funcall f1 (car m) (car d)) ;; (funcall f2 (cdr m) (cdr d)))))) ;; (cond (l1 (tp-reduce f1 f2 (cdr l1) l2 (cons (c l1 l2) r))) ;; ((assoc (caar l2) r) (tp-reduce f1 f2 l1 (cdr l2) r)) ;; (l2 (tp-reduce f1 f2 l1 (cdr l2) (cons (c l2 r) r))) ;; (r)))) (defconstant +bool-inf-op-list+ '((> . <=) (>= . <) (< . >=) (<= . >) (= . /=) (/= . =))) (defconstant +bool-inf-sop-list+ '((> . <) (< . >) (<= . >=) (>= . <=) (= . =) (/= . /=))) (defun comp-type-propagator (f t1 t2 &rest r) (let ((z (let ((r (num-type-rel f t1 t2))) (cond ((car r) #t(member t)) ((cadr r) #t(member nil)) (#tboolean))))) (if r (type-or1 z (apply 'comp-type-propagator f t2 (car r) (cdr r))) z))) (defun max-bnd (x y op &aux (nx (if (atom x) x (car x))) (ny (if (atom y) y (car y)))) (cond ((or (eq x '*) (eq y '*)) '*) ((= nx ny) (if (atom x) x y)) ((funcall op nx ny) x) (y))) (defun real-bnds (t1) (num-type-bounds t1)) (defun two-tp-inf (fn t2 &aux (t2 (real-bnds (type-and #treal t2)))) (case fn (= (cmp-norm-tp `(real ,(or (car t2) '*) ,(or (cadr t2) '*)))) (/= (if (when (numberp (car t2)) (eql (car t2) (cadr t2))) (cmp-norm-tp `(and number (not (real ,@t2)))) #treal)) (> (cmp-norm-tp `(real ,(cond ((numberp (car t2)) (list (car t2))) ((car t2)) ('*))))) (>= (cmp-norm-tp `(real ,(or (car t2) '*)))) (< (cmp-norm-tp `(real * ,(cond ((numberp (cadr t2)) (list (cadr t2))) ((cadr t2)) ('*))))) (<= (cmp-norm-tp `(real * ,(or (cadr t2) '*)))))) (defmacro vl-name (x) `(var-name (car (third ,x)))) ;(defmacro vl-type (x) `(var-type (car (third ,x)))) ; Won't work, ref might be across a function boundary (defmacro vl-type (x) `(itp ,x)) (defmacro itp (x) `(info-type (second ,x))) (defmacro vlp (x) `(and (eq 'var (car ,x)) (llvar-p (car (third ,x))))) ;(defmacro vlp (x) `(and (eq 'var (car ,x)) (eq (var-kind (car (third ,x))) 'lexical))) ;; (defun get-object-value (c1x) ;; (when (and (eq 'location (car c1x)) (eq 'vv (caaddr c1x))) ;; (values (gethash (cadr (caddr c1x)) *objects-rev*)))) ;; (defvar *gen-nil* (list (cons +gen+ (cons nil t)))) ;; (defvar *gen-t* (list (cons +gen+ (cons t nil)))) ;; (defvar *inferred-tps* nil) ;; (defvar *inferred-op* nil) ;; (defvar *inferred-iop* nil) ;; (defun fmla-chain (op iop fx fy &optional res) ;; (let* ((*inferred-tps* res) ;; (*inferred-op* op) ;; (*inferred-iop* iop) ;; (r (tp-reduce op iop fx fy)) ;; (r (if *inferred-tps* (tp-reduce op iop r *inferred-tps*) r))) ;; (cond ((and (not (cdr fx)) (not (cdr fy))) r) ;; ((equal r res) r) ;; ((fmla-chain op iop fx fy r))))) ;; (defun intp (sym tp tf) ;; (let* ((a (if tf 'cadr 'cddr)) ;; (itp (funcall a (assoc sym *inferred-tps*)))) ;; (if itp (funcall (if tf *inferred-op* *inferred-iop*) tp itp) ;; tp))) (defun tppra (tp arg f r) (let ((s (info-type (cadr arg)))) (cons (type-and tp (two-tp-inf f s)) (type-and tp (two-tp-inf r s))))) ;; (defun tppra (tp arg f r) ;; (let* ((x (info-type (cadr arg))) ;; (s (cmp-norm-tp x)) ;; (sym (when (vlp arg) (vl-name arg)))) ;; (cons (type-and tp (two-tp-inf f (intp sym s t))) ;; (type-and tp (two-tp-inf r (intp sym s nil)))))) (defun fmla-if1 (f tf ff) (let* ((nf (mapcar (lambda (x) (cons (car x) (cons (cddr x) (cadr x)))) f)) (r1 (tp-reduce 'type-and 'type-or1 f tf));FIXME rewrite to carry only desired branch (r2 (tp-reduce 'type-and 'type-or1 nf ff)) (tr (tp-reduce 'type-or1 'type-and r1 r2)) (r1 (tp-reduce 'type-or1 'type-and nf tf)) (r2 (tp-reduce 'type-or1 'type-and f ff)) (fr (tp-reduce 'type-and 'type-or1 r1 r2))) (mapc (lambda (x) (setf (cddr x) (cddr (assoc (car x) fr)))) tr))) ;; (defun fmla-if1 (f tf ff) ;; (let* ((nf (mapcar (lambda (x) (cons (car x) (cons (cddr x) (cadr x)))) f)) ;; (r1 (fmla-chain 'type-and 'type-or1 f tf));FIXME rewrite to carry only desired branch ;; (r2 (fmla-chain 'type-and 'type-or1 nf ff)) ;; (tr (fmla-chain 'type-or1 'type-and r1 r2)) ;; (r1 (fmla-chain 'type-or1 'type-and nf tf)) ;; (r2 (fmla-chain 'type-or1 'type-and f ff)) ;; (fr (fmla-chain 'type-and 'type-or1 r1 r2)) ;; (tr (mapc (lambda (x) (setf (cddr x) (cddr (assoc (car x) fr)))) tr)));FIXME? check here? ;; (delete +gen+ tr :key 'car))) (defun fmla-if (f tf ff) (fmla-clean (fmla-if1 (fmla-infer-tp f) (fmla-infer-tp tf) (fmla-infer-tp ff)))) ;; (defun fmla-if (f tf ff) ;; (fmla-if1 (fmla-infer-tp f) (fmla-infer-tp tf) (fmla-infer-tp ff))) ;; (defun fmla-if (f tf ff) ;; (let* ((f (fmla-infer-tp f)) ;; (r1 (fmla-chain 'type-and 'type-or1 f (fmla-infer-tp tf))) ;; (f (mapcar (lambda (x) (cons (car x) (cons (cddr x) (cadr x)))) f)) ;; (r2 (fmla-chain 'type-and 'type-or1 f (fmla-infer-tp ff)))) ;; (delete +gen+ (fmla-chain 'type-or1 'type-and r1 r2) :key 'car))) ;; (defun fmla-switch (form &aux fm ntp ttp) ;; (let ((c (caddr form))) ;; (when (and (consp c) (eq (car c) 'inline)) ;; (let ((ca (caddr c))) ;; (when (eq ca 'tt3) ;; (let* ((f (fifth c)) ;; (v (when (and (consp f) (eq (car f) 'let*)) (cadddr f))) ;; (v (unless (cdr v) (when (and (consp (car v)) (eq (caar v) 'var)) (caaddr (car v))))) ;; (tt (sixth form))) ;; (do ((ints nil ints)) ((not (setq fm (pop tt))) (list* (var-name v) ttp ntp)) ;; (cond ((tag-p fm) (push (tag-name fm) ints)) ;; ((and (consp fm) (eq (car fm) 'return-from)) ;; (let ((tp (info-type (cadr (sixth fm))))) ;; (cond ((type>= #tnull tp) (setq ntp (type-or1 (ints-tt3 ints) ntp) ;; ints nil)) ;; ((type>= #t(not null) tp) ;; (setq ttp (type-or1 (ints-tt3 ints) ttp) ints nil))))))))))))) ;(defun merge-fmla (x) x) ;; (defun fmla-infer-inline (f) ;; (when (consp f) ;; (case (car f) ;; ((let let*) (sublis (mapcar 'cons ;; (mapcar 'var-name (third f)) ;; (mapcar (lambda (x) (when (and (consp x) (eq (car x) 'var)) ;; (var-name (car (third x))))) (fourth f))) ;; (fmla-infer-inline (fifth f)))) ;; (if (fmla-infer-inline (fourth f)));FIXME ;; (block ;; (merge-fmla (catch (third f) (fmla-infer-inline (fourth f))))) ;; (progn (fmla-infer-inline (car (last (third f))))) ;; (return-from ;; (throw (third f) (fmla-infer-inline (sixth f)))) ;; (switch ;; (mapc 'fmla-infer-inline (sixth f))) ;; (infer-tp (let ((tp (info-type (cadr (fifth f))))) ;; (cond ((type>= #tnull tp) (list* (var-name (third f)) #tt (fourth f))) ;; ((type>= #t(not null) tp) (list* (var-name (third f)) (fourth f) #tt)))))))) (defvar *infer-tags* nil) (defun fmla-default (fmla &aux (tp (info-type (cadr fmla)))(nn (type-and tp #t(not null)))(n (type-and tp #tnull))) (unless (and nn n) (list (cons +gen+ (cons (when nn t) (when n t)))))) (defun fmla-clean (fmla) (delete +gen+ fmla :key 'car)) (defun fmla-infer-tp (fmla) (when (unless *compiler-new-safety* (listp fmla)) (case (car fmla) ((inline decl-body let let*) (fmla-infer-tp (car (last fmla)))) (block (let ((*infer-tags* (cons (cons (third fmla) (fmla-infer-tp (fourth fmla))) *infer-tags*))) (labels ((fmla-walk (f) (cond ((atom f)) ((when (eq (car f) 'return-from) (eq (caddr f) (third fmla))) (fmla-infer-tp f)) (t (fmla-walk (car f)) (fmla-walk (cdr f)))))) (fmla-walk (fourth fmla))) (fmla-clean (cdar *infer-tags*)))) (progn (fmla-infer-tp (car (last (third fmla))))) (return-from (let ((x (assoc (third fmla) *infer-tags*))) (when x (let ((y (fmla-infer-tp (seventh fmla)))) (setf (cdr x) (fmla-if1 nil (cdr x) y)))))) (infer-tp (let* ((tp (info-type (cadr (fifth fmla)))) (vl (remove-if-not 'llvar-p (third fmla))) (i (cond ((type>= #tnull tp) (cons nil (fourth fmla)));FIXME nil tp ((type>= #t(not null) tp) (cons (fourth fmla) nil))))) (nconc (when i (mapcar (lambda (x) (cons x i)) vl)) (fmla-infer-tp (fifth fmla)))));FIXME (lit (mapcar (lambda (x) (list* x #t(not null) #tnull)) (local-aliases (get-top-var-binding (lit-bind fmla)) nil))) (if (apply 'fmla-if (cddr fmla))) (var (when (llvar-p (car (third fmla))) (list (cons (car (third fmla)) (cons #t(not null) #tnull))))) (setq (fmla-infer-tp (fourth fmla)));FIXME set var too, and in call global (call-global (let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+))) (sfn (cdr (assoc fn +bool-inf-sop-list+))) (srfn (cdr (assoc sfn +bool-inf-op-list+))) (args (if (eq (car fmla) 'inline) (fourth (fifth fmla)) (fourth fmla))) (l (length args)) (pt (rassoc fn +cmp-type-alist+)));FIXME +cmp-type-alist+ (get fn 'si::predicate-type) (cond ((and (= l 1) (vlp (first args)) pt) (list (cons (car (third (first args))) (cons (car pt) (tp-not (car pt)))))) ((and (= l 2) (eq fn 'typep) (vlp (first args)) (let ((tp (cmp-norm-tp (car (atomic-tp (info-type (cadr (second args)))))))) (when tp (list (cons (car (third (first args))) (cons tp (tp-not tp)))))))) ((and (= l 2) rfn) (nconc (when (vlp (first args)) (list (cons (car (third (first args))) (tppra (vl-type (first args)) (second args) fn rfn)))) (when (eq 'lit (car (first args))) (mapcar (lambda (x) (cons x (tppra (vl-type (first args)) (second args) fn rfn))) (local-aliases (get-top-var-binding (lit-bind (first args))) nil))) (when (vlp (second args)) (list (cons (car (third (second args))) (tppra (vl-type (second args)) (first args) sfn srfn)))) (when (eq 'lit (car (second args))) (mapcar (lambda (x) (cons x (tppra (vl-type (second args)) (first args) sfn srfn))) (local-aliases (get-top-var-binding (lit-bind (second args))) nil))))) ((fmla-default fmla))))) (otherwise (fmla-default fmla))))) (defvar *restore-vars* nil) (defun restrict-type (v ot lt) (setf (var-type v) ot) (unless (type>= lt ot) (let ((nt (type-and ot lt))) (keyed-cmpnote (list 'type 'type-restriction (var-name v)) "restricting type of ~s to ~s~%" (var-name v) (cmp-unnorm-tp nt)) (setf (var-type v) nt)))) (defun ignorable-pivot (pivot value) (let ((s (sgen "IGNORABLE-PIVOT"))) `(let ((,s ,pivot)) (declare (ignorable ,s)) ,value))) (defun fmla-is-changed (var fmla) (cond ((info-p fmla) (is-changed var fmla)) ((atom fmla) nil) ((or (fmla-is-changed var (car fmla)) (fmla-is-changed var (cdr fmla)))))) ;; (defun fmla-is-changed (name fmla) ;; (cond ((info-p fmla) (let ((v (car (member name *vars* :key (lambda (x) (when (var-p x) (var-name x))))))) ;; (is-changed v fmla))) ;; ((atom fmla) nil) ;; ((or (fmla-is-changed name (car fmla)) (fmla-is-changed name (cdr fmla)))))) (defun c1branch (tf r args info) (if (and (not tf) (endp (cddr args))) (list (c1nil) nil) (with-restore-vars ;FIXME eliminate if any variable restricts to nil (dolist (l r) (restrict-type (car l) (cadr l) (let ((l (caddr l))) (if tf (car l) (cdr l))))) (let (trv (b (c1expr* (if tf (cadr args) (caddr args)) info))) (dolist (l *restore-vars*) (push (if (var-p (car l)) (list (car l) (var-type (car l)) (var-store (car l))) (progn (keyed-cmpnote (list 'type-mod-unwind) "Winding type ~s at end of branch" (car l)) (list (car l) (mcpt (car l))))) trv)) (keep-warnings) (list b trv))))) (defun c-and (y x) (if (type>= #tnull (info-type (cadr y))) y (let ((x (fmla-c1expr x))) (list 'if (make-info :type (type-or1 (info-type (cadr x)) #tnull)) y x (c1nil))))) (defun c-or (y x) (if (type>= #t(not null) (info-type (cadr y))) y (let ((x (fmla-c1expr x))) (list 'if (make-info :type (type-or1 (info-type (cadr x)) #t(member t))) y (c1t) x)))) (defun c-not (x) (let ((x (fmla-c1expr x))) (cond ((type>= #tnull (info-type (cadr x))) (list 'progn (make-info :type #t(member t)) (list x (c1t)))) ((type>= #t(not null) (info-type (cadr x))) (list 'progn (make-info :type #tnull) (list x (c1nil)))) ((list 'if (make-info :type #tboolean) x (c1nil) (c1t)))))) (defun fmla-c1expr (fmla) (case (car fmla) (fmla-and (reduce 'c-and (cdr fmla) :initial-value (c1t))) (fmla-or (reduce 'c-or (cdr fmla) :initial-value (c1nil))) (fmla-not (c-not (fmla-c1expr (cadr fmla)))) (otherwise fmla))) (defun maybe-progn-fmla (fmla args) (c1progn (list fmla args) (list (fmla-c1expr fmla) (c1expr args)))) (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) (when (caddr args) (note-branch-elimination (car args) t (caddr args))) (c1expr (cadr args))) ((nil) (note-branch-elimination (car args) nil (cadr args)) (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) (otherwise (setq info (make-info)) (let* ((fmla (c1fmla f info)) (inf (fmla-clean (fmla-infer-tp fmla))) (inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf)) (fmlae (fmla-eval-const fmla)) (fmlae (if (notevery 'cadr inf) nil fmlae)) (fmlae (if (notevery 'cddr inf) t fmlae))) (when inf (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf)) "inferring types on form ~s, ~s" f (mapcar (lambda (x) (list (pop x) (cmp-unnorm-tp (pop x)) (cmp-unnorm-tp x))) inf))) (if (not (eq fmlae 'boolean)) (cond (fmlae (when (caddr args) (note-branch-elimination (car args) t (caddr args))) (maybe-progn-fmla fmla (cadr args))) (t (note-branch-elimination (car args) nil (cadr args)) (maybe-progn-fmla fmla (caddr args)))) (let (r) (dolist (l inf) (let ((v (car l))) (when v (push (list v (var-type v) (cdr l)) r)))) (unwind-protect (let* ((tbl (c1branch t r args info)) (fbl (c1branch nil r args info)) (tb (car tbl)) (fb (car fbl)) (tret (info-type (cadr tb))) (fret (info-type (cadr fb))) (trv (append (when tret (cadr tbl)) (when fret (cadr fbl))))) (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb)))) (do (rv) ((not (setq rv (pop r)))) (setf (var-type (car rv)) (cadr rv)) (if fret (unless tret (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv))))) (when tret (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv))))))) (or-branches trv) (list 'if info fmla tb fb)) (dolist (l r) (setf (var-type (car l)) (cadr l)))))))))) (defun t-and (x y) (cond ((eq x 'boolean) (when y 'boolean)) ((eq y 'boolean) (when x 'boolean)) ((and x y)))) (defun t-or (x y) (cond ((eq x 'boolean) (or (eq y t) 'boolean)) ((eq y 'boolean) (or (eq x t) 'boolean)) ((or x y)))) (defun t-not (x) (if (eq x 'boolean) 'boolean (not x))) (defun fmla-eval-const (fmla) (if *compiler-new-safety* 'boolean (case (car fmla) (fmla-and (reduce (lambda (y x) (t-and (fmla-eval-const x) y)) (cdr fmla) :initial-value t)) (fmla-or (reduce (lambda (y x) (t-or (fmla-eval-const x) y)) (cdr fmla) :initial-value nil)) (fmla-not (t-not (fmla-eval-const (cdr fmla)))) ((t nil) (car fmla)) (otherwise (if (consp (car fmla)) (fmla-eval-const (car fmla)) (cond ((type>= #tnull (info-type (second fmla))) nil) ;FIXME ((type>= #t(not null) (info-type (second fmla))) t) ('boolean))))))) (defun c1fmla-constant (fmla &aux f) (cond (*compiler-new-safety* fmla) ((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 fmla-tp (fmla) (case (car fmla) ((fmla-and fmla-or) (let ((tp (if (eq (car fmla) 'fmla-and) #tnull #t(not null))) (z (mapcar 'fmla-tp (cdr fmla)))) (reduce (lambda (y x) (if (type>= tp y) y (type-or1 x (type-and tp y)))) (cdr z) :initial-value (car z)))) (fmla-not (let ((tp (fmla-tp (cadr fmla)))) (cond ((type>= #tnull tp) #t(member t)) ((type>= #t(not null) tp) #tnull) (#tboolean)))) (otherwise (info-type (cadr fmla))))) ;; (defun fmla-and-or (fmlac info tp) ;; (let (r rp z) ;; (dolist (x fmlac r) ;; (with-restore-vars ;; (setq z (c1fmla x info)) ;; (do (l) ((not (setq l (pop *restore-vars*)))) ;; (setf (var-type (car l)) (type-or1 (var-type (car l)) (cadr l))))) ;; (setq rp (let ((tmp (cons z nil))) (if rp (cdr (rplacd rp tmp)) (setq r tmp)))) ;; (when (type>= tp (fmla-tp z)) ;; (return r))))) ;; (defun c1fmla (fmla info &aux *c1exit*) ;; (if (atom fmla) (c1expr* fmla info) ;; (case (car fmla) ;; (and (case (length (cdr fmla)) ;; (0 (c1t)) ;; (1 (c1fmla (cadr fmla) info)) ;; (t (cons 'FMLA-AND (fmla-and-or (cdr fmla) info #tnull))))) ;; (or (case (length (cdr fmla)) ;; (0 (c1nil)) ;; (1 (c1fmla (cadr fmla) info)) ;; (t (cons 'FMLA-OR (fmla-and-or (cdr fmla) info #t(not null)))))) ;; ((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 (let* ((cm (and (symbolp (car fmla)) (get (car fmla) 'si::compiler-macro-prop))) ;; (cm (and cm (funcall cm fmla nil)))) ;; (cond ((and cm (not (eq cm fmla))) (c1fmla cm info)) ;; ((let ((r (c1expr* fmla info))) ;; (if (type>= #tboolean (info-type (cadr r))) r ;; (let ((info (make-info :type #tboolean))) ;; (add-info info (cadr r)) ;; (list 'if info ;; (list 'call-global info 'eq (list r (c1nil))) ;; (c1nil) (c1t)))))))))))) (defconstant +fmla+ (list (make-c1exit (gensym)))) (defun exit-to-fmla-p nil (eq (last *c1exit*) +fmla+)) (defun co1or-arg-tp (arg) (let ((x (with-restore-vars (c1expr arg)))) (if (member-if 'is-ttl-tag (info-ref (cadr x))) #tt (info-type (cadr x))))) (defun co1or (fn args) (declare (ignore fn)) (let* ((tp (when (and args (exit-to-fmla-p)) #t(member t))) (arg (pop args)) (tp (or tp (co1or-arg-tp arg))) (atp (atomic-tp (type-and tp #t(not null))))) (when (atomic-type-constant-value atp);FIXME make sure this is never a binding, FIXME ignorable-form? (c1expr (if args `(if ,arg ',(car atp) (or ,@args)) arg))))) ;; (defun co1or (fn args) ;; (declare (ignore fn)) ;; (let* ((tp (when (and args (exit-to-fmla-p)) #t(member t))) ;; (arg (pop args)) ;; (tp (or tp (info-type (cadr (with-restore-vars (c1expr arg)))))) ;; (atp (atomic-tp (type-and tp #t(not null))))) ;; (when (atomic-type-constant-value atp);FIXME make sure this is never a binding ;; (c1expr `(if ,arg ',(car atp) ,@(when args `((or ,@args)))))))) ;; (defun co1or (fn args) ;; (declare (ignore fn)) ;; (with-restore-vars ;; (let* ((tp (when (and args (exit-to-fmla-p)) #t(member t))) ;; (arg (pop args)) ;; (tp (or tp (info-type (cadr (c1expr arg))))) ;; (atp (atomic-tp (type-and tp #t(not null))))) ;; (when (atomic-type-constant-value atp) ;; (keep-vars) ;; (c1expr `(if ,arg ',(car atp) (or ,@args))))))) (setf (get 'or 'co1special) 'co1or) (defun c1fmla (fmla info &aux (*c1exit* +fmla+)) (c1expr* fmla info)) (defun not-compiler-macro (form env) (declare (ignore env)) `(if ,(cadr form) nil t)) (setf (get 'not 'si::compiler-macro-prop) 'not-compiler-macro) (setf (get 'null 'si::compiler-macro-prop) 'not-compiler-macro) (defun c2if (fmla form1 form2) (let* ((v *value-to-go*) (rev (and (type>= #tnull (info-type (cadr form1))) (type>= #t(not null) (info-type (cadr form2))))) (reg (and (type>= #tnull (info-type (cadr form2))) (type>= #t(not null) (info-type (cadr form1))))) (vj (when (or rev reg) (and (consp v) (car (member (car v) '(jump-true jump-false)))))) (fj (eq vj (if rev 'jump-true 'jump-false))) (Flabel (next-label)) ; (Flabel (if vj (if fj (cadr v) (caddr v)) (next-label))) FIXME: This needs working side-effects propagation (Tlabel (if vj (if fj (caddr v) (cadr v)) (next-label)))) (let* ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*))) (*exit* Tlabel)) (CJF fmla Tlabel Flabel)) (unless vj (wt-label Tlabel)) (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1)) (wt-label Flabel) ; (unless vj (wt-label Flabel)) (c2expr form2))) ;; (defun c2if (fmla form1 form2 ;; &aux (Tlabel (next-label)) Flabel) ;; (cond ((and (eq (car form2) 'LOCATION);FIXME axe this ;; (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)))) (defun CJF (fmla Tlabel Flabel) (let ((*value-to-go* (list 'jump-false Flabel Tlabel))) (c2expr* fmla))) (defun CJT (fmla Tlabel Flabel) (let ((*value-to-go* (list 'jump-true Tlabel Flabel))) (c2expr* fmla))) ;; (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 Tlabel))) ;; (c2expr* fmla))))) ;; (OTHERWISE (let ((*value-to-go* (list 'jump-false Flabel Tlabel))) (c2expr* fmla))))) ;; (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 Flabel))) ;; (c2expr* fmla))))) ;; (OTHERWISE (let ((*value-to-go* (list 'jump-true Tlabel Flabel))) (c2expr* fmla))))) ;;; 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))) ;; ((let ((info (make-info)) ;; (nargs (append (mapcar (lambda (x) `(when ,x t)) (butlast args)) ;; (last args)))) ;; (list 'AND info (c1args nargs 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 co1or (fn args &aux (arg (pop args))) ;; (let* ((tp (info-type (cadr (c1expr arg)))) ;; (atp (atomic-tp (type-and tp #t(not null)))));(print (list arg args tp atp))(break) ;; (when (and atp (c1constant-value (setq atp (car atp)) nil)) ;; (c1expr `(if ,arg ',atp (or ,@args)))))) ;; (si:putprop 'or 'co1or 'co1special) ;; (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) (let* ((sym (sgen "SWITCH")) (op (pop args)) (args (mapcan (lambda (x &aux (k (pop x))(k (or (eq k 'otherwise) k))) (when k `(,@(if (listp k) k (list k)) (return-from ,sym (progn ,@x))))) args))) `(block ,sym (switch ,op ,@(if (member t args) args (nconc args `(t (return-from ,sym nil)))))))) ;; (defun convert-case-to-switch (args default) ;; (let ((sym (tmpsym)) 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 (switch ,(car args) ,@(nreverse body))))) (defun conv-kl (l s &aux (l (if (listp l) (remove-duplicates l) l))) (cond ((not l) nil) ((atom l) `(= ,s ,l)) ((not (cdr l)) `(= ,s ,(car l))) ((let* ((l (sort (copy-list l) '<)) (n (car l)) (x (car (last l))) (ll (let ((i (- n 1))) (mapl (lambda (x) (setf (car x) (incf i))) (make-list (length l)))))) (when (equal l ll) `(<= ,n ,s ,x)))))) (define-compiler-macro case (&whole form &rest args) (if (when *compiler-in-use* (type>= #tfixnum (nil-to-t (info-type (cadr (with-restore-vars (c1arg (car args)))))))) (let* ((s (pop args)) (oth (member-if (lambda (x &aux (x (car x))) (or (eq x t) (eq x 'otherwise))) args)) (rem (ldiff args oth)) (ff (when rem (conv-kl (caar rem) s)))) (flet ((f (x) (let ((d (cdar x))) (if (cdr d) (cons 'progn d) (car d))))) (cond ((unless (cdr rem) (when ff `(if ,ff ,(f rem) ,(f oth))))) ((convert-case-to-switch (cdr form)))))) form)) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpvs.lsp0000644000000000000000000000013114774225213015340 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.476939222 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpvs.lsp0000644000175000017500000000571014774225213014742 0ustar00cammcamm;;; CMPVS Value stack manager. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) "]")) ((= (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 ccb-vs-str (ccb-vs) (format nil "(base0[~a])->c.c_car" (- *initial-ccb-vs* ccb-vs))) (defun wt-ccb-vs (ccb-vs) (wt (ccb-vs-str ccb-vs))) (defun clink (vs &optional (loc nil locp)) (wt-nl) (wt-vs vs) (wt "=make_cons(") (if locp (wt loc) (wt-vs vs)) (wt ",") (wt-clink) (wt ");") (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 nil (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.7.1/cmpnew/PaxHeaders/gcl_cmpwt.lsp0000644000000000000000000000013114774225213015342 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.476939222 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpwt.lsp0000644000175000017500000002224114774225213014742 0ustar00cammcamm;;; CMPWT Output routines. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) (defstruct (fasd (:type vector)) stream table eof direction package index filepos table_length evald_forms ; list of forms eval'd. (load-time-eval) ) (si::freeze-defstruct 'fasd) (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 gcl. 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 ! */ )) ;(require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp") (eval-when (compile eval) ; (require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp") (defmacro put-op (op str) `(write-byte ,(or (position op *fasd-ops*) (error "illegal op")) ,str)) (defmacro put2 (n str) `(progn (write-bytei ,n 0 ,str) (write-bytei ,n 1 ,str))) (defmacro write-bytei (n i str) `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str)) ;(defmacro data-inits () `(first *data*)) ;(defmacro data-dl () `(second *data*)) ) (defun wt-comment (message &optional (symbol nil)) (princ " /* " *compiler-output1*) (let* ((mlist (and symbol (list (string symbol)))) (mlist (cons message mlist))) (dolist (s mlist) (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)) ((or (typep form 'fcomplex) (typep form 'dcomplex)) (wt "(" (realpart form) " + I * " (imagpart 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* nil) (defun memoized-hash-equal (x depth);FIXME implement all this in lisp (declare (fixnum depth)(inline si::hash-set)) (unless *run-hash-equal-data-checking* (return-from memoized-hash-equal 0)) (unless *hash-eq* (setq *hash-eq* (make-hash-table :test 'eq))) (address (or (gethash x *hash-eq*) (setf (gethash x *hash-eq*) (nani (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) (declare (ignore x));FIXME (incf *next-vv*)) (defun wt-data1 (expr) (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* (list tem)) (push tem *data*)) x) (defun add-dl (x &optional endp &aux (tem (cons (memoized-hash-equal x -1000) x))) (if endp (nconc (data-dl) (list tem)) (push tem (data-dl))) 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) (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-readably* (not *compiler-compile*)) ;;This forces the printer to add the float type in the .data file. (*READ-DEFAULT-FLOAT-FORMAT* 'long-float) (si::*print-package* t) (si::*print-structure* t)) (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*)) (cond (*compiler-compile*;FIXME, clean this up (setq *compiler-compile-data* (mapcar 'verify-datum (nreverse *data*))) (wt-data2 `(mapc 'eval *compiler-compile-data*))) ;; Carefully allow sharing across all data but preseve eval order ((wt-data2 `'(progn ,@(mapcar (lambda (x) (cons '|#,| (verify-datum x))) (nreverse *data*)))))) (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.7.1/cmpnew/PaxHeaders/gcl_cmputil.lsp0000644000000000000000000000013114774225213015665 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.472939196 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmputil.lsp0000644000175000017500000001723514774225213015274 0ustar00cammcamm;;; CMPUTIL Miscellaneous Functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 *error-output*) (si::error-format "ERROR: ") (apply #'si::error-format string args) (force-output *error-output*) (incf *error-count*) (throw *cmperr-tag* (c1nil))) (defmacro cmpck (condition string &rest args) `(if ,condition (cmperr ,string ,@args))) (defun too-many-args (name upper-bound n) (cmperr "~S requires at most ~R argument~:p, ~ but ~R ~:*~[were~;was~:;were~] supplied.~%" name upper-bound n)) (defun too-few-args (name lower-bound n) (cmperr "~S requires at least ~R argument~:p, ~ but only ~R ~:*~[were~;was~:;were~] supplied.~%" name lower-bound n)) (defvar *warning-note-stack*) (defvar *suppress-compiler-warnings* nil) (defmacro maybe-to-wn-stack (&rest body) (let ((cf (sgen "MTWSCF"))(sri (sgen "MTWSSRI"))) `(if (and (boundp '*warning-note-stack*) (not *note-keys*));FIXME (let ((,cf *current-form*)(,sri *src-inline-recursion*)) (push (lambda nil (let ((*current-form* ,cf) (*src-inline-recursion* ,sri)) ,@body)) *warning-note-stack*)) (progn ,@body)))) (defun output-warning-note-stack nil (when (boundp '*warning-note-stack*) (do ((*warning-note-stack* (nreverse *warning-note-stack*))) ((not *warning-note-stack*)) (funcall (pop *warning-note-stack*))))) (defun cmpwarn (string &rest args &aux (*print-case* :upcase)) (unless *suppress-compiler-warnings* (maybe-to-wn-stack (warn 'warning :function-name (print-current-form nil) :format-control "~?" :format-arguments (list string args)))) nil) (defun cmpstyle-warn (string &rest args &aux (*print-case* :upcase)) (unless *suppress-compiler-warnings* (maybe-to-wn-stack (warn 'style-warning :function-name (print-current-form nil) :format-control "~?" :format-arguments (list string args)))) nil) (defvar *suppress-compiler-notes* t) (defvar *note-keys* nil) (defun watch (key) (pushnew key *note-keys*)) (defun unwatch (&rest keys) (setq *note-keys* (when keys (nset-difference *note-keys* keys)))) (defun cmpnote (string &rest args &aux (*print-case* :upcase)) (maybe-to-wn-stack (print-current-form *debug-io*) (format *debug-io* ";; Note: ") (apply #'format *debug-io* string args) (terpri *debug-io*)) nil) (defun do-keyed-cmpnote (k string &rest args &aux (*print-case* :upcase)) (do ((k k (when (consp k) (cdr k)))) ((not k)) (let ((k (if (consp k) (car k) k))) (when (member k *note-keys* :test (lambda (x y) (or (eq x y) (eq 'all y)))) (apply 'cmpnote string args) (return))))) (defmacro keyed-cmpnote (key string &rest args) `(when *note-keys* (do-keyed-cmpnote ,key ,string ,@args))) (defun print-current-form (&optional (strm t) &aux (*print-length* 2)(*print-level* 2)(f *current-form*)) (when (or (eq *first-error* t) (not (eq (car *first-error*) *current-form*)) (not (eq (cdr *first-error*) *src-inline-recursion*))) (setq *first-error* (cons *current-form* *src-inline-recursion*)) (let ((args (list ";; When compiling ~s~%~{;; inlining ~s~%~}" (if (and (consp f) (eq (car f) '|#,|)) (cdr f) f) (mapcan (lambda (s) (unless (eq (caar s) f) (list (cons (name-sir (car s)) (cdr s))))) (butlast *src-inline-recursion*))))) (if (eq *error-output* strm) (apply 'si::error-format args) (apply 'format strm args))))) (defun undefined-variable (sym &aux (*print-case* :upcase)) (cmpwarn ";; The variable ~s is undefined.~%~ ;; The compiler will assume this variable is a global.~%" sym)) (defun baboon nil (cmperr "A bug was found in the compiler. Contact Taiichi.~%")) (defun cmp-eval (form) (multiple-value-bind (x y) (cmp-toplevel-eval `(eval ',form)) (cond (x (cmpwarn "The form ~s was not evaluated successfully. You are recommended to compile again.~%" form) `(error "Evaluation of ~s failed at compile time." ',form)) (y)))) ;(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))))) (defmacro macroexpand-helper (pre meth form) (let ((c (sgen "MHC"))(x (sgen "MHX"))) `(let ((,c (when (consp ,form) (car ,form)))) ,@(when pre `(,pre)) (cond ((not ,c) ,form) ((not (symbolp ,c)) ,form) ((not (cmp-macro-function ,c)) ,form);FIXME needed? ((let* ((,x (multiple-value-list (cmp-toplevel-eval `,,meth)))) (cond ((car ,x) (cmpwarn "The macro form ~s was not expanded successfully.~%" ,form) `(error "Macro-expansion of ~s failed at compile time." ',,form)) ((cadr ,x))))))))) (defun cmp-macroexpand (form) (macroexpand-helper nil `(macroexpand ',form ',(funs-to-macrolet-env)) form)) (defun cmp-macroexpand-1 (form) (macroexpand-helper nil `(macroexpand-1 ',form ',(funs-to-macrolet-env)) form)) (defun cmp-expand-macro (fd fname args) (let ((x (cons fname args))) (macroexpand-helper (and *record-call-info* (add-macro-callee fname)) `(funcall *macroexpand-hook* ',fd ',x ',(funs-to-macrolet-env)) x))) (defun cmp-expand-macro-w (fd x) (macroexpand-helper (and *record-call-info* (add-macro-callee (car x))) `(funcall *macroexpand-hook* ',fd ',x ',(funs-to-macrolet-env)) x)) (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))) (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.7.1/cmpnew/PaxHeaders/gcl_cmploc.lsp0000644000000000000000000000013114774225213015465 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.456939094 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmploc.lsp0000644000175000017500000004601214774225213015067 0ustar00cammcamm;;; CMPLOC Set-loc and Wt-loc. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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*) (defvar *values-to-go* nil) (defvar *multiple-value-exit-label* nil) ;;; 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 'string-value 'wt-string-value 'wt-loc) (si:putprop 'vs-address 'wt-vs-address 'wt-loc) (si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc) (si:putprop 'string-loc 'wt-string-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 'char-value 'wt-char-value 'wt-loc) (si:putprop 'char-loc 'wt-char-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 'fcomplex-value 'wt-fcomplex-value 'wt-loc) (si:putprop 'fcomplex-loc 'wt-fcomplex-loc 'wt-loc) (si:putprop 'dcomplex-value 'wt-dcomplex-value 'wt-loc) (si:putprop 'dcomplex-loc 'wt-dcomplex-loc 'wt-loc) (si:putprop 'gen-loc 'wt-gen-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 multiple-values-p () (and (consp *value-to-go*) (consp (car *value-to-go*)))) (defvar *extend-vs-top*) (defun set-loc (loc &aux fd) (cond ((eq *value-to-go* 'return) (set-return loc)) ((member *value-to-go* '(trash expr)) (let ((tr (eq *value-to-go* 'trash))) (cond ((and (consp loc) (rassoc (car loc) +inline-types-alist+) (cadr loc)) (wt-nl (if tr "(void)" "") "(") (wt-inline t (caddr loc) (cadddr loc)) (wt ")" (if tr ";" ""))) ((and (consp loc) (eq (car loc) 'SIMPLE-CALL)) (wt-nl (if tr "(void)" "") loc (if tr ";" "")))))) ((eq *value-to-go* 'top) (unless (eq loc 'fun-val) (set-top loc))) ((multiple-values-p) (let ((*values-to-go* *value-to-go*) *extend-vs-top*) (do ((loc loc nil)) ((null *values-to-go*)) (let ((*value-to-go* (pop *values-to-go*))) (set-loc loc))) (when *mvb-vals* (wt-nl) (when (and *extend-vs-top* (> (var-space *mv-var*) 0)) (let ((l (var-loc *mv-var*))) (wt-nl "for (vs_top=vs_topvs_top) _y--;vs_top=_y;}") (base-used) (unless (boundp '*extend-vs-top*) (baboon)) (setq *extend-vs-top* t *values-to-go* nil)) (wt "_z;})")) ((or (not (consp loc)) (not (symbolp (car loc)))) (baboon)) ((unless (eq (car loc) 'inline-cond) (rassoc (car loc) +inline-types-alist+)) (wt-gen-loc :object loc)) (t (let ((fd (get (car loc) 'wt-loc))) (when (null fd) (baboon)) (values (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)) ((set-top loc)))) (defun set-top (loc) (let ((vs-mark *vs*) (*vs* *vs*)) (wt-nl) (wt-vs (vs-push)) (wt "= " loc ";") (if (and (consp loc) (rassoc (car loc) +inline-types-alist+) (flag-p (cadr loc) sets-vs-top)) (wt-nl "vs_base=base+" vs-mark ";");;callee sets vs_top; obsolete ??? (wt-nl "vs_top=(vs_base=base+" vs-mark ")+" (- *vs* vs-mark) ";")) (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) " */")) (let* ((fn (or (car (rassoc cvar *c-vars*)) (cdr (assoc cvar *c-vars*)) t)) (fn (or (car (member fn +c-local-var-types+ :test 'type<=)) 'object)) (fn (cdr (assoc fn +wt-c-var-alist+)))) (unless fn (baboon)) (wt fn) (wt "(V" cvar ")"))) (defun vv-str (vv) (let ((vv (add-object2 vv))) (string-concatenate "((object)VV[" (write-to-string vv) "])"))) ;; (defun vv-str (vv) (si::string-concatenate "((object)VV[" (write-to-string vv) "])")) (defun wt-vv (vv) (wt (vv-str vv))) (defun kind-tp (x) (cadr (assoc x *c-types*))) (let ((fk (kind-tp 'fixnum))(ck (kind-tp 'char))) (defun wt-fixnum-loc (loc &aux x) (cond ((and (consp loc) (eq (car loc) 'var) (or (eq fk (var-kind (cadr loc))) (eq ck (var-kind (cadr loc)))));FIXME (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'cvar) (setq x (car (rassoc (cadr loc) *c-vars*))) (type>= #tfixnum x)) (wt loc)) ((and (consp loc) (member (car loc) +number-inlines+)) ; (wt "(fixnum)") (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (or (eq (car loc) 'fixnum-value) (eq (car loc) 'char-value))) ; (wt "(fixnum)") (cond ((= (caddr loc) most-negative-fixnum) (wt "(" (1+ most-negative-fixnum) "- 1)")) ((wt (caddr loc))))) ((and (consp loc) (eq (car loc) 'vs-address));???? (wt loc)) (t (wt (if *safe-compile* "fixint(" "fix(") loc ")"))))) ;; (defun wt-integer-loc (loc &aux (avma t)(first (and (consp loc) (car loc)))) ;; (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 ;; (cond ;; ((eq (var-kind (cadr loc)) #tinteger) (setq avma nil) (wt "V" (var-loc (cadr loc)))) ;; ((eq (var-kind (cadr loc)) #tfixnum) (wt "stoi(V" (var-loc (cadr loc))")")) ;; ((wt "otoi(" loc ")")))) ;; (otherwise (wt "otoi(" loc ")"))) ;; ; (and avma (not *restore-avma*)(wfs-error)) ;; ) (let ((fk (kind-tp 'fixnum))) (defun fixnum-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq fk (var-kind (cadr loc)))) (eq (car loc) 'INLINE-FIXNUM) (eq (car loc) 'fixnum-value))))) (defun wt-fixnum-value (vv fixnum-value) (if vv (wt (vv-str vv)) (wt "make_fixnum(" fixnum-value ")"))) (let ((fk (kind-tp 'string))) (defun wt-string-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) fk)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-STRING)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'string-value)) (wt (caddr loc))) (t (wt "object_to_string(" loc ")"))))) (let ((fk (kind-tp 'string))) (defun string-loc-p (loc);FIXME check all these unneeded (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) fk)) (eq (car loc) 'INLINE-STRING) (eq (car loc) 'string-value))))) (defun wt-string-value (vv string-value);FIXME check unneeded (declare (ignore string-value)) (wt (vv-str vv))) (defun wt-vs-address (v i) (wt "(fixnum)(" v "+" i ")")) (let ((ck (kind-tp 'character))) (defun wt-character-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) ck)) (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 ")"))))) (let ((ck (kind-tp 'character))) (defun character-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) ck)) (eq (car loc) 'INLINE-CHARACTER) (eq (car loc) 'character-value))))) (defun wt-character-value (vv character-code) (if vv (wt (vv-str vv)) (wt "code_char(" character-code ")"))) (defun wt-char-loc (loc) (wt-fixnum-loc loc)) (let ((ck (kind-tp 'char))) (defun char-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) ck)) (eq (car loc) 'INLINE-CHAR) (eq (car loc) 'char-value))))) (defun wt-char-value (vv char) (if vv (wt (vv-str vv)) (wt "make_fixnum(" char ")"))) (let ((lk (kind-tp 'long-float))) (defun wt-long-float-loc (loc &aux x) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) lk)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'cvar) (setq x (car (rassoc (cadr loc) *c-vars*))) (type>= #tlong-float x)) (wt 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 ")"))))) (let ((lk (kind-tp 'long-float))) (defun long-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) lk)) (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 ft-wrapper (key tt pp) ;; (if *compiler-new-safety* ;; (wt (strcat "((" key ")object_to_" (if pp "pointer" "dcomplex") "(")) ;; (wt (or (cdr (assoc tt +to-c-var-alist+)) "") "("))) ;; (defun tt-wrapper (ft) ;; (wt (or (cdr (assoc ft +wt-c-var-alist+)) "") "(")) ;; (defun cast-wrapper (key) key) (defun loc-kind (loc &aux (cl (when (listp loc) (car loc)))) (cond ((eq cl 'var) (let* ((var (cadr loc)) (kind (var-kind var))) (case kind (replaced (loc-kind (var-loc var))) ((global object lexical special) #tt) (otherwise kind)))) ((eq cl 'cvar) (or (car (member (or (car (rassoc (cadr loc) *c-vars*)) (cdr (assoc (cadr loc) *c-vars*)) #tt) +c-local-var-types+ :test 'type<=)) #tt)) ((car (rassoc cl +inline-types-alist+))) ((car (rassoc cl +value-types+))) (#tt))) (defun wt-lexical-var (loc) (let* ((var (pop loc)) (ccb (car loc))) (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))))));FIXME side-effect propagation (defun vv-value-loc (key loc &aux (ktp (get key 'cmp-lisp-type))) (unless (eq ktp t) (when (when (consp loc) (eq (car loc) 'vv)) (let* ((x (cadr loc)) (x (if (ltvp x) (eval (cdr x)) x))) (when (type>= ktp (object-tp x)) `(,(cdr (assoc ktp +value-types+ :test 'type<=)) nil ,x)))))) (defun wt-gen-loc (key loc &aux (loc (or (vv-value-loc key loc) loc)) p) (let* ((cl (when (consp loc) (car loc))) (fit (car (rassoc cl +inline-types-alist+))) (fvt (car (rassoc cl +value-types+))) (ft (loc-kind loc)) (tt (get key 'cmp-lisp-type)) (cast (if (member key '(:cnum :creal)) "" (strcat "(" key ")"))) (pp (find #\* cast))) (cond ((unless fvt (eq ft tt))) ((equal ft #tt) (if *compiler-new-safety* (let ((v (member key '(:char :int :fixnum)))) (if v (wt (setq p "object_to_") (strcat key)) (wt cast (setq p "object_to_") (if pp "pointer" "dcomplex")))) (wt (or (setq p (cdr (assoc tt +to-c-var-alist+ :test 'type<=))) cast))));FIXME prune to-c list ((equal tt #tt) (wt (or (setq p (cdr (assoc ft +wt-c-var-alist+))) ""))) ((and (type>= #tint tt) (type>= tt ft))) ((and (type>= #tcnum tt) (type>= #t(or character cnum) ft)) (wt cast)) ((baboon))) (when p (wt "(")) (cond ((not loc) (wt "Cnil")) ((eq loc t) (wt "Ct")) ((eq cl 'var) (case (var-kind (cadr loc)) ((special global) (wt "(" (vv-str (var-loc (cadr loc))) "->s.s_dbind)")) (lexical (wt-lexical-var (cdr loc))) (otherwise (cond ((integerp (var-loc (cadr loc))) (wt "V" (var-loc (cadr loc)))) ((and (consp (var-loc (cadr loc))) (rassoc (car (var-loc (cadr loc))) +value-types+)) (wt (caddr (var-loc (cadr loc))))) ((wt (var-loc (cadr loc)))))))) ((eq cl 'cvar) (wt "V" (cadr loc))) ((eq cl 'vv) (wt loc)) (fit (wt-inline-loc (caddr loc) (cadddr loc))) (fvt (cond ((= (caddr loc) most-negative-fixnum) (wt "(" (1+ most-negative-fixnum) "- 1)")) ((wt (caddr loc))))) ((baboon))) (when pp (unless *compiler-new-safety* (wt "->v.v_self"))) (when p (wt ")")) (when (and (equal tt #tt) (equal ft #tboolean)) (wt "?Ct:Cnil")))) (let ((sk (kind-tp 'short-float))) (defun wt-short-float-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) sk)) (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 ")"))))) (let ((sk (kind-tp 'short-float))) (defun short-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) sk)) (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))) (let ((fk (kind-tp 'fcomplex))) (defun wt-fcomplex-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) fk)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-FCOMPLEX)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'fcomplex-value)) (wt (caddr loc))) (t (wt "sfc(" loc ")"))))) (let ((fk (kind-tp 'fcomplex))) (defun fcomplex-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) fk)) (eq (car loc) 'INLINE-FCOMPLEX) (eq (car loc) 'fcomplex-value))))) (defun wt-fcomplex-value (vv fcomplex-value) (declare (ignore fcomplex-value)) (wt (vv-str vv))) (let ((dk (kind-tp 'dcomplex))) (defun wt-dcomplex-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) dk)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-DCOMPLEX)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'dcomplex-value)) (wt (caddr loc))) (t (wt "lfc(" loc ")"))))) (let ((dk (kind-tp 'dcomplex))) (defun dcomplex-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) dk)) (eq (car loc) 'INLINE-DCOMPLEX) (eq (car loc) 'dcomplex-value))))) (defun wt-dcomplex-value (vv dcomplex-value) (declare (ignore dcomplex-value)) (wt (vv-str vv))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpinline.lsp0000644000000000000000000000013114774225213016166 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.452939068 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpinline.lsp0000644000175000017500000014316314774225213015575 0ustar00cammcamm;;; CMPINLINE Open coding optimizer. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 eql-not-nil (x y) `(and ,x (eql ,x ,y))) ;; 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 s-print (n x a s) (print-unreadable-object (x s) (princ n s) (princ " " s) (princ x s) (format s " ~x" a))) (defstruct (info (:print-function (lambda (x s i) (s-print 'info (info-type x) (si::address x) s))) (:copier old-copy-info)) (type t) ;;; Type of the form. (flags 0 :type fixnum) (ch nil :type list) (ref-ccb nil :type list) (ref-clb nil :type list) (ref nil :type list) (ch-ccb nil :type list) ) (si::freeze-defstruct 'info) ;;; Old sp-change comment: Whether execution of the form may change the value of a special variable *VS*. (defconstant +iflags+ '(side-effects provisional compiler args volatile sp-change)) (defmacro iflag-p (flags flag) (let ((i (position flag +iflags+))) (unless i (baboon)) `(logbitp ,i ,flags))) (defmacro iflags (&rest flags) (the (unsigned-byte #.(length +iflags+)) (reduce (lambda (y x &aux (i (position x +iflags+))) (unless i (baboon)) (logior y (ash 1 i))) flags :initial-value 0))) (defmacro copy-ht (ht) `(copy-list ,ht));nil ? (defun copy-info (info) (let ((new-info (old-copy-info info))) (setf (info-ch new-info) (copy-ht (info-ch info)) (info-ref new-info) (copy-ht (info-ref info)) (info-ref-ccb new-info) (copy-ht (info-ref-ccb info)) (info-ref-clb new-info) (copy-ht (info-ref-clb info))) new-info)) ;; (defun copy-info (info) ;; (let ((new-info (old-copy-info info))) ;; (setf (info-ref new-info) (copy-ht (info-ref info)) ;; (info-ch new-info) (copy-ht (info-ch info)) ;; (info-blocks new-info) (copy-ht (info-blocks info)) ;; (info-tags new-info) (copy-ht (info-tags info))) ;; (when *make-fast-ref* ;; (setf (info-vref new-info) (copy-ht (info-vref info)) ;; (info-vref-ccb new-info) (copy-ht (info-vref-ccb info)) ;; (info-vref-clb new-info) (copy-ht (info-vref-clb info)))) ;; new-info)) ;; (defun copy-info (info) ;; (let ((new-info (old-copy-info info))) ;; (setf (info-ref new-info) (copy-ht (info-ref info)) ;; (info-ch new-info) (copy-ht (info-ch info)) ;; (info-blocks new-info) (copy-ht (info-blocks info)) ;; (info-tags new-info) (copy-ht (info-tags info)) ;; (info-vref new-info) (copy-ht (info-vref info)) ;; (info-vref-ccb new-info) (copy-ht (info-vref-ccb info)) ;; (info-vref-clb new-info) (copy-ht (info-vref-clb info)) ;; (info-bref new-info) (copy-ht (info-bref info)) ;; (info-bref-ccb new-info) (copy-ht (info-bref-ccb info)) ;; (info-bref-clb new-info) (copy-ht (info-bref-clb info)) ;; (info-tref new-info) (copy-ht (info-tref info)) ;; (info-tref-ccb new-info) (copy-ht (info-tref-ccb info)) ;; (info-tref-clb new-info) (copy-ht (info-tref-clb info)) ;; (info-fref new-info) (copy-ht (info-fref info)) ;; (info-fref-ccb new-info) (copy-ht (info-fref-ccb info)) ;; ; (info-fref-clb new-info) (copy-ht (info-fref-clb info)) ;; ) ;; new-info)) (defmacro push-ht (x ht) `(pushnew ,x ,ht :test 'eq)) (defmacro do-ht ((v ht) &rest body) `(dolist (,v ,ht) ,@body)) (defmacro in-ht (v ht) `(member ,v ,ht :test 'eq)) (defmacro adjustable-ht (ht) ht) (defmacro do-referred ((v info) &rest body) `(progn (do-ht (,v (info-ref-ccb ,info)) (when (var-p ,v) ,@body)) (do-ht (,v (info-ref-clb ,info)) (when (var-p ,v) ,@body)) (do-ht (,v (info-ref ,info)) (when (var-p ,v) ,@body)))) ;; (defmacro do-referred-cb ((v info) &rest body) ;; `(progn ;; (do-ht (,v (info-ref-ccb ,info)) (when (var-p ,v) ,@body)) ;; (do-ht (,v (info-ref-clb ,info)) (when (var-p ,v) ,@body)))) ;; (defmacro do-referred ((v info) &rest body) ;; `(do-ht (,v (info-ref ,info)) ,@body)) (defmacro do-changed ((v info) &rest body) `(do-ht (,v (info-ch ,info)) ,@body)) (defmacro is-referred (var info) `(or (in-ht ,var (info-ref-ccb ,info)) (in-ht ,var (info-ref-clb ,info)) (in-ht ,var (info-ref ,info)))) ;; (defmacro is-referred (var info) ;; `(in-ht ,var (info-ref ,info))) (defmacro is-changed (var info) `(in-ht ,var (info-ch ,info))) (defmacro push-referred (var info) `(push-ht ,var (info-ref ,info)));FIXME ;; (defmacro push-referred (var info) ;; `(push-ht ,var (info-ref ,info))) (defmacro push-changed (var info) `(push-ht ,var (info-ch ,info))) (defmacro changed-length (info) `(length (info-ch ,info))) ;; (defmacro referred-length (info) ;; `(length (info-ref ,info))) (defun imerge (x y list) (nunion x (intersection y list :test 'eq) :test 'eq)) (declaim (inline imerge)) (defun add-info (to-info from-info) ;; Allow nil from-info without error CM 20031030 (unless from-info (return-from add-info to-info)) (macrolet ((mrg (field) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r *vars*) (,field to-info) (imerge (,field to-info) r *blocks*) (,field to-info) (imerge (,field to-info) r *tags*) (,field to-info) (imerge (,field to-info) r *funs*)))))) (mrg info-ch) (mrg info-ref-ccb) (mrg info-ref-clb) (mrg info-ref)) (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) (setf (info-ref to-info) (nunion (info-ref to-info) (remove-if-not 'symbolp (info-ref from-info))));FIXME nunion asym (setf (info-ch-ccb to-info) (nunion (info-ch-ccb to-info) (info-ch-ccb from-info))) to-info) ;; (defun add-info (to-info from-info) ;; ;; Allow nil from-info without error CM 20031030 ;; (unless from-info (return-from add-info to-info)) ;; (macrolet ((mrg (field scrn) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r ,scrn))))) ;; (mrg1 (field) `(let* ((r (,field from-info))) ;; (when r ;; (setf (,field to-info) (imerge (,field to-info) r *vars*) ;; (,field to-info) (imerge (,field to-info) r *blocks*) ;; (,field to-info) (imerge (,field to-info) r *tags*) ;; (,field to-info) (imerge (,field to-info) r *funs*)))))) ;; (mrg info-ch *vars*) ;; (mrg1 info-ref-ccb) ;; (mrg1 info-ref-clb) ;; (mrg1 info-ref)) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) ;; (defun add-info (to-info from-info) ;; ;; Allow nil from-info without error CM 20031030 ;; (unless from-info (return-from add-info to-info)) ;; (macrolet ((mrg (field scrn) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r ,scrn))))) ;; (mrg1 (field) `(let* ((r (,field from-info))) ;; (when r ;; (setf (,field to-info) (imerge (,field to-info) r *vars*) ;; (,field to-info) (imerge (,field to-info) r *blocks*) ;; (,field to-info) (imerge (,field to-info) r *tags*) ;; (,field to-info) (imerge (,field to-info) r *funs*)))))) ;; (mrg info-ref *vars*) ;; (mrg info-ch *vars*) ;; (mrg info-blocks *blocks*) ;; (mrg info-tags *tags*) ;; (when *make-fast-ref* ;; (mrg1 info-vref-ccb) ;; (mrg1 info-vref-clb) ;; (mrg1 info-vref))) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) ;; (defun add-info (to-info from-info) ;; ;; Allow nil from-info without error CM 20031030 ;; (unless from-info (return-from add-info to-info)) ;; (macrolet ((mrg (field scrn) `(let* ((r (,field from-info))) (when r (setf (,field to-info) (imerge (,field to-info) r ,scrn)))))) ;; (mrg info-ref *vars*) ;; (mrg info-ch *vars*) ;; (mrg info-blocks *blocks*) ;; (mrg info-tags *tags*) ;; (mrg info-vref-ccb *vars*) ;; (mrg info-vref-clb *vars*) ;; (mrg info-vref *vars*) ;; (mrg info-bref-ccb *blocks*) ;; (mrg info-bref-clb *blocks*) ;; (mrg info-bref *blocks*) ;; (mrg info-tref-ccb *tags*) ;; (mrg info-tref-clb *tags*) ;; (mrg info-tref *tags*) ;; (mrg info-fref-ccb *funs*) ;; ; (mrg info-fref-clb *funs*) ;; (mrg info-fref *funs*)) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) ;; (setf (info-ref to-info) (imerge (info-ref to-info) (info-ref from-info) *vars*) ;; (info-ch to-info) (imerge (info-ch to-info) (info-ch from-info) *vars*) ;; (info-blocks to-info) (imerge (info-blocks to-info) (info-blocks from-info) *blocks*) ;; (info-tags to-info) (imerge (info-tags to-info) (info-tags from-info) *tags*) ;; (info-vref-ccb to-info) (imerge (info-vref-ccb to-info) (info-vref-ccb from-info) *vars*) ;; (info-vref-clb to-info) (imerge (info-vref-clb to-info) (info-vref-clb from-info) *vars*) ;; (info-vref to-info) (imerge (info-vref to-info) (info-vref from-info) *vars*) ;; (info-bref-ccb to-info) (imerge (info-bref-ccb to-info) (info-bref-ccb from-info) *blocks*) ;; (info-bref-clb to-info) (imerge (info-bref-clb to-info) (info-bref-clb from-info) *blocks*) ;; (info-bref to-info) (imerge (info-bref to-info) (info-bref from-info) *blocks*) ;; (info-tref-ccb to-info) (imerge (info-tref-ccb to-info) (info-tref-ccb from-info) *tags*) ;; (info-tref-clb to-info) (imerge (info-tref-clb to-info) (info-tref-clb from-info) *tags*) ;; (info-tref to-info) (imerge (info-tref to-info) (info-tref from-info) *tags*) ;; (info-fref-ccb to-info) (imerge (info-fref-ccb to-info) (info-fref-ccb from-info) *funs*) ;; ; (info-fref-clb to-info) (imerge (info-fref-clb to-info) (info-fref-clb from-info) *funs*) ;; (info-fref to-info) (imerge (info-fref to-info) (info-fref from-info) *funs*) ;; ) ;; (when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1)) ;; (setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info))) ;; to-info) (defconstant +c1nil+ (list 'LOCATION (make-info :type (object-type nil)) nil)) (defmacro c1nil () `+c1nil+) (defconstant +c1t+ (list 'LOCATION (make-info :type (object-type t)) t)) (defmacro c1t () `+c1t+) (defun args-info-changed-vars (var forms) (if (member (var-kind var) +c-local-var-types+) (dolist (form forms) (when (is-changed var (cadr form)) (return-from args-info-changed-vars t))) (case (var-kind var) ((LEXICAL 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)) (iflag-p (info-flags (cadr form)) sp-change)) (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)))) ;;; 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. (defun inc-inline-blocks() (cond ((consp *inline-blocks*) (incf (car *inline-blocks*))) (t (incf *inline-blocks*)))) ;; (defun loc-from-c2form (form type) ;; (case (car form) ;; (LOCATION (coerce-loc (caddr form) type)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (cond ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (eq type (var-kind (caaddr form)))) ;; (let* ((cvar (cs-push type t))(*value-to-go* `(cvar ,cvar))) ;; (wt-nl "{" (rep-type type) "V" cvar "= V" ;; (var-loc (caaddr form)) ";") ;; (inc-inline-blocks) ;; (list 'cvar cvar 'inline-args))) ;; ((let* ((temp (wt-c-push type))(*value-to-go* temp)) ;; (wt-nl temp "= ") ;; (wt-var (caaddr form) (cadr (caddr form))) ;; (wt ";") ;; (coerce-loc temp type))))) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (eq type (var-kind (caaddr form))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (wt-nl "V" temp " = " ;; (coerce-loc (cons 'var (caddr form)) type) ";") ;; (list 'cvar temp))) ;; ((coerce-loc (cons 'VAR (caddr form)) type)))) ;; (CALL-GLOBAL ;; (if (let ((fname (caddr form))) ;; (and (inline-possible fname) ;; (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (wt-nl "V" temp " = " (coerce-loc loc type) ";") ;; (list 'cvar temp))) ;; ((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 "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) (wt-loc loc))) ;; (t (setq cvar (cs-push type t)) ;; (wt-nl "{" (rep-type type) "V" cvar "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) ;; (funcall (or (cdr (assoc (promoted-c-type type) +wt-loc-alist+)) 'wt-loc) loc)) ;; (inc-inline-blocks))) ;; (wt ";") ;; (list 'cvar cvar 'inline-args))) ;; (t (coerce-loc loc type)))) ;; (let* ((temp (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push)))) ;; (*value-to-go* temp)) ;; (c2expr* form) ;; (coerce-loc temp type)))) ;; (ub (list 'gen-loc (caddr form) (loc-from-c2form (fourth form) type))) ;; (structure-ref(coerce-loc-structure-ref (cdr form) type)) ;; (SETQ ;; (let ((vref (caddr form)) ;; (form1 (cadddr form))) ;; (let ((*value-to-go* (cons 'var vref))) (c2expr* form1)) ;; (cond ((eq (car form1) 'LOCATION) ;; (coerce-loc (caddr form1) type)) ;; (t (loc-from-c2form (list 'VAR (cadr form) vref)) ;; (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)))))) ;; ((let ((temp ;; (cond ((not *c-gc*) (list 'vs (vs-push))) ;; ((eq type t) (list 'cvar (cs-push))) ;; ((list 'var ;; (make-var :type type :loc (cs-push type) ;; :kind (or (car (member (promoted-c-type type) +c-local-var-types+)) 'object)) ;; nil))))) ;; (let ((*value-to-go* temp)) ;; (c2expr* form) ;; (coerce-loc temp type)))))) (defun wt-push-loc (loc type &optional expr) (let* ((cv (cs-push type)) (*value-to-go* `(cvar ,cv))) (if expr (c2expr* loc) (wt-nl "V" cv "= " (coerce-loc loc type) ";")) (coerce-loc *value-to-go* type))) (defun lit-loc (key inl args bind safety oargs stores &aux (tp (get key 'cmp-lisp-type))) (declare (ignore bind safety oargs stores)) (let ((sig (list (mapcar (lambda (x) (info-type (cadr x))) args) tp))) (get-inline-loc (list (car sig) (cadr sig) (flags rfa) inl) args))) (defun ub-loc (v &aux (c (car v))) (ecase c (var (cons c (caddr v))) (lit (apply 'lit-loc (cddr v))) (location (caddr v))));FIXME (defun args-info-changed-info (i forms) (do-referred (v i) (when (var-p v) (when (args-info-changed-vars v forms) (return-from args-info-changed-info t))))) (defun inline-args (forms types &optional fun &aux locs ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) (nreverse locs)) (let* ((form (car forms)) (type (car types)) (type (adj-cnum-tp type (info-type (cadr form))))) (case (car form) (LOCATION (push (coerce-loc (caddr form) type) locs)) (VAR (cond ((args-info-changed-vars (caaddr form) (cdr forms)) (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ((and (member (var-kind (caaddr form)) +c-local-var-types+) (not (type>= (var-kind (caaddr form)) type))) ; (not (eq type (var-kind (caaddr form))))) (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ((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)) (sixth 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) +c-local-var-types+) (not (eq type (cadr ii))))) (push (wt-push-loc loc type) 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))))) (push (wt-push-loc loc type) locs)) ((push (coerce-loc loc type) locs)))) (push (wt-push-loc form type t) locs))) (lit (let* ((loc (apply 'lit-loc (cddr form))) (loc (if (or (args-info-changed-info (cadr form) (cdr forms)) (member-if (lambda (x) (iflag-p (info-flags (cadr x)) side-effects)) (cdr forms))) (wt-push-loc loc type) (coerce-loc loc type)))) (push loc locs))) (ub (push (list 'gen-loc (caddr form) (ub-loc (fourth form))) locs)) (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) (SETQ (let* ((vref (caddr form)) (form1 (cadddr form)) (v (car vref)) (vv (cons 'var vref)) (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) (cond ((eq vt vv) (let ((*value-to-go* vt)) (c2expr* form1)) (if (eq (car form1) 'LOCATION) (push (coerce-loc (caddr form1) type) locs) (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) types (list* type types)))) ((setq forms (list* form form1 (cdr forms)) types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (nreverse locs)) ;; (let* ((form (car forms)) ;; (type (car types)) ;; (type (adj-cnum-tp type (info-type (cadr form))))) ;; (case (car form) ;; (LOCATION (push (coerce-loc (caddr form) type) locs)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (type>= (var-kind (caaddr form)) type))) ;; ; (not (eq type (var-kind (caaddr form))))) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (push (wt-push-loc loc type) 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))))) ;; (push (wt-push-loc loc type) locs)) ;; ((push (coerce-loc loc type) locs)))) ;; (push (wt-push-loc form type t) locs))) ;; (lit (push (coerce-loc (apply 'lit-loc (cddr form)) type) locs)) ;; (ub (push (list 'gen-loc (caddr form) ;; (let* ((v (fourth form))(c (car v))) ;; (ecase c ;; (var (cons c (caddr v))) ;; (lit (apply 'lit-loc (cddr v))) ;; (location (caddr v))))) locs)) ;; (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) ;; (SETQ ;; (let* ((vref (caddr form)) ;; (form1 (cadddr form)) ;; (v (car vref)) ;; (vv (cons 'var vref)) ;; (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) ;; (cond ((eq vt vv) ;; (let ((*value-to-go* vt)) (c2expr* form1)) ;; (if (eq (car form1) 'LOCATION) ;; (push (coerce-loc (caddr form1) type) locs) ;; (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) ;; types (list* type types)))) ;; ((setq forms (list* form form1 (cdr forms)) ;; types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types ;; (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (nreverse locs)) ;; (let* ((form (car forms)) ;; (type (car types)) ;; (type (adj-cnum-tp type (info-type (cadr form))))) ;; (case (car form) ;; (LOCATION (push (coerce-loc (caddr form) type) locs)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (type>= (var-kind (caaddr form)) type))) ;; ; (not (eq type (var-kind (caaddr form))))) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (push (wt-push-loc loc type) 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))))) ;; (push (wt-push-loc loc type) locs)) ;; ((push (coerce-loc loc type) locs)))) ;; (push (wt-push-loc form type t) locs))) ;; (ub (push (list 'gen-loc (caddr form) ;; (let* ((v (fourth form))(tv (third v))) ;; (if (eq (car v) 'var) (cons (car v) tv) tv))) locs)) ;; (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) ;; (SETQ ;; (let* ((vref (caddr form)) ;; (form1 (cadddr form)) ;; (v (car vref)) ;; (vv (cons 'var vref)) ;; (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) ;; (cond ((eq vt vv) ;; (let ((*value-to-go* vt)) (c2expr* form1)) ;; (if (eq (car form1) 'LOCATION) ;; (push (coerce-loc (caddr form1) type) locs) ;; (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) ;; types (list* type types)))) ;; ((setq forms (list* form form1 (cdr forms)) ;; types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types ;; (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (nreverse locs)) ;; (let* ((form (car forms)) ;; (type (car types)) ;; (type (adj-cnum-tp type (info-type (cadr form))))) ;; (case (car form) ;; (LOCATION (push (coerce-loc (caddr form) type) locs)) ;; (VAR ;; (cond ((args-info-changed-vars (caaddr form) (cdr forms)) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (eq type (var-kind (caaddr form))))) ;; (push (wt-push-loc (cons 'var (caddr form)) type) locs)) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (push (wt-push-loc loc type) 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))))) ;; (push (wt-push-loc loc type) locs)) ;; ((push (coerce-loc loc type) locs)))) ;; (push (wt-push-loc form type t) locs))) ;; (ub (push (list 'gen-loc (caddr form) ;; (let* ((v (fourth form))(tv (third v))) ;; (if (eq (car v) 'var) (cons (car v) tv) tv))) locs)) ;; (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) ;; (SETQ ;; (let* ((vref (caddr form)) ;; (form1 (cadddr form)) ;; (v (car vref)) ;; (vv (cons 'var vref)) ;; (vt (if (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (eq (var-kind v) 'global)) vv *value-to-go*))) ;; (cond ((eq vt vv) ;; (let ((*value-to-go* vt)) (c2expr* form1)) ;; (if (eq (car form1) 'LOCATION) ;; (push (coerce-loc (caddr form1) type) locs) ;; (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms)) ;; types (list* type types)))) ;; ((setq forms (list* form form1 (cdr forms)) ;; types (list* type types))))));; want (setq types (list* type type (cdr types))) but type is first of types ;; (otherwise (push (wt-push-loc form type t) locs)))))) ;; (defun inline-args (forms types &optional fun &aux locs ii) ;; (do ((forms forms (cdr forms)) ;; (types types (cdr types))) ;; ((endp forms) (reverse locs)) ;; (let ((form (car forms)) ;; (type (car types))) ;; (let ((type (adj-cnum-tp type (info-type (cadr form))))) ;; (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)) +c-local-var-types+) ;; (eq type (var-kind (caaddr form)))) ;; (let* ((cvar (cs-push type t))(*value-to-go* `(cvar ,cvar))) ;; (wt-nl "{" (rep-type type) "V" cvar "= V" ;; (var-loc (caaddr form)) ";") ;; (push (list 'cvar cvar 'inline-args) locs) ;; (inc-inline-blocks))) ;; ((let* ((temp (wt-c-push type))(*value-to-go* temp)) ;; (wt-nl temp "= ") ;; (wt-var (caaddr form) (cadr (caddr form))) ;; (wt ";") ;; (push (coerce-loc temp type) locs))))) ;; ((and (member (var-kind (caaddr form)) +c-local-var-types+) ;; (not (eq type (var-kind (caaddr form))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (wt-nl "V" temp " = " ;; (coerce-loc (cons 'var (caddr form)) type) ";") ;; (push (list 'cvar temp) locs))) ;; ((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)) (sixth 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) +c-local-var-types+) ;; (not (eq type (cadr ii))))) ;; (let* ((temp (cs-push type))(*value-to-go* `(cvar ,temp))) ;; (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 "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) (wt-loc loc))) ;; (t (setq cvar (cs-push type t)) ;; (wt-nl "{" (rep-type type) "V" cvar "= ") ;; (let ((*value-to-go* `(cvar ,cvar))) ;; (funcall (or (cdr (assoc (promoted-c-type type) +wt-loc-alist+)) '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)))) ;; ; (ub (push (coerce-loc (cons 'var (third (fourth form))) (get (caddr form) 'lisp-type)) locs)) ;; (ub (push (list 'gen-loc (caddr form) (let* ((v (fourth form))(tv (third v))) (if (eq (car v) 'var) (cons (car v) tv) tv))) 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 ((not *c-gc*) (list 'vs (vs-push))) ;; ((eq type t) (list 'cvar (cs-push))) ;; ((list 'var ;; (make-var :type type :loc (cs-push type) ;; :kind (or (car (member (promoted-c-type type) +c-local-var-types+)) 'object)) ;; nil))))) ;; (let ((*value-to-go* temp)) ;; (c2expr* form) ;; (push (coerce-loc temp type) locs))))))))) (defun coerce-loc (loc type) (let ((tmp (car (rassoc (promoted-c-type type) *box-alist*)))) (if tmp (list 'gen-loc tmp loc) (let ((tl (cdr (assoc (promoted-c-type type) +coersion-alist+))));FIXME never reached (if tl (list tl loc) loc))))) ;; (defun coerce-loc (loc type) ;; (when (eq 'var (when (listp loc) (car loc))) (setf (var-type (cadr loc)) type));FIXME cmp-aref ;; (let ((tmp (car (rassoc (promoted-c-type type) *box-alist*)))) ;; (if tmp (list 'gen-loc tmp loc) ;; (let ((tl (cdr (assoc (promoted-c-type type) +coersion-alist+)))) ;; (if tl (list tl loc) 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 (reverse locs1))) (declare (fixnum n)) (if (member n saves) (let* ((loc (car l)) (loc1 loc) (coersion (and (consp loc) (cdr (rassoc (car loc) +coersion-alist+)))) (loc (if coersion (cadr loc) loc))); remove coersion (cond ((and (consp loc) (rassoc (car loc) +inline-types-alist+) (or (member (car loc) '(inline inline-cond)) (flag-p (cadr loc) allocates-new-storage) (flag-p (cadr loc) side-effect-p))) (wt-nl "{") (inc-inline-blocks) ;;FIXME -- make sure not losing specificity in coersion (let* ((ck (or (car (rassoc coersion +coersion-alist+)) 'object)) (cvar (cs-push ck t))) (push (list 'CVAR cvar) locs1) (unless ck (baboon)) (wt (rep-type ck) "V" cvar "= ") (funcall (cdr (assoc ck +wt-loc-alist+)) loc)) (wt ";")) (t (push loc1 locs1)))) (push (car l) locs1))))) (let ((others (and (stringp fun) (not (single-type-p (cadr ii))) (not (type>= (cadr ii) '*)) (mapcar 'inline-type (cddadr ii))))) (list (inline-type (cadr ii)) (caddr ii) (if others (cons fun others) fun) locs )) ) (defun inline-type (type) (or (cdr (assoc (promoted-c-type type) +inline-types-alist+)) 'inline)) (defun get-plist-inline (fname args return-type apnarg inline-list) (reduce (lambda (y x) (or y (inline-type-matches fname x args return-type apnarg))) inline-list :initial-value nil)) (defun get-inline-info (fname args return-type &optional apnarg &aux (sui (if *safe-compile* 'inline-safe 'inline-unsafe))) (setq args (mapcar (lambda (form) (info-type (cadr form))) args)) (cond ((get-plist-inline fname args return-type apnarg (get fname sui))) ((get-plist-inline fname args return-type apnarg (get fname 'inline-always))) ((cdr (add-fast-link fname (length args) apnarg))))) ;; (defun get-inline-info (fname args return-type &optional apnarg ;; &aux (sui (if *safe-compile* 'inline-safe 'inline-unsafe))) ;; (setq args (mapcar (lambda (form) (info-type (cadr form))) args)) ;; (cond ((get-plist-inline fname args return-type apnarg (get fname sui))) ;; ((get-plist-inline fname args return-type apnarg (get fname 'inline-always))) ;; ((cdr (add-fast-link fname apnarg))))) (defun adj-cnum-tp (tp ref) (if (and (type>= #tcnum tp) (not (type>= #tcnum (promoted-c-type tp)))) (let ((pr (promoted-c-type ref))) (when (and (type>= #tcnum pr) (type>= tp ref)) ref)) tp)) (defun mv-cast (arg-type type);FIXME (cond ((single-type-p type) arg-type) ((single-type-p arg-type) (list* (car type) (coerce-to-one-value arg-type) (make-list (length (cddr type))))) ((append arg-type (make-list (max 0 (- (length type) (length arg-type)))))))) (defun inline-type-matches (fname inline-info arg-types return-type &optional apnarg &aux rts (flags (third inline-info))) (declare (ignore fname)) (fix-opt inline-info) (when (let ((x (flag-p flags aa))) (if apnarg x (not x))) (when (flag-p flags itf) (let ((restp (apply (car inline-info) arg-types))) (return-from inline-type-matches (when restp `(,(car restp) ,(cadr restp) ,@(cddr inline-info)))))) (let* ((t1 (mapcar (lambda (x) (or x #tnull)) (cons return-type arg-types))) (t2 (cons (cadr inline-info) (car inline-info))) (last #tt) (ret t)) (when (dolist (arg-type t1 (or (equal t2 '(*)) (endp t2))) (when (endp t2) (return nil)) (let* ((s (unless ret (and (eq (car t2) '*) (not (cdr t2))))) (lst (if (unless (type<= last #topaque) s) #tt last));FIXME (cmp-norm-tp 'opaque) (type (if s lst (pop t2))) (arg-type (if ret (mv-cast arg-type type) (coerce-to-one-value arg-type)));FIXME (tp (adj-cnum-tp type arg-type))) (unless (type>= tp arg-type) (return nil)) (setq last type ret nil) (push tp rts))) (setq rts (nreverse rts)) (cons (cdr rts) (cons (car rts) (cddr inline-info))))))) (defun need-to-protect (forms types &aux ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) nil) (let ((form (car forms))) (case (car form) (LOCATION) (VAR (when (or (args-info-changed-vars (caaddr form) (cdr forms)) (when (member (var-kind (caaddr form)) +c-local-var-types+) (not (type>= (var-kind (caaddr form)) (car types))))) (return t))) (CALL-GLOBAL (let ((fname (caddr form))) (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) +c-local-var-types+) (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 (&optional type) (cond (*c-gc* (inc-inline-blocks) (let ((tem (cs-push type t))) (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-string 'wt-inline-string 'wt-loc) (si:putprop 'inline-integer 'wt-inline-integer 'wt-loc) (si:putprop 'inline-character 'wt-inline-character 'wt-loc) (si:putprop 'inline-char 'wt-inline-char 'wt-loc) (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc) (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc) (si:putprop 'inline-dcomplex 'wt-inline-dcomplex 'wt-loc) (si:putprop 'inline-fcomplex 'wt-inline-fcomplex 'wt-loc) (defun wt-inline-loc (fun locs &aux (i 0) (max 0) (maxv 0)) (declare (fixnum i max maxv)) (let* ((others (and (consp fun) (stringp (car fun)) (cdr fun))) (fun (if (and (consp fun) (stringp (car fun))) (car fun) fun))) (cond ((stringp fun) (when (char= (char fun 0) #\@) (setq i 1) (do () ((char= (char fun i) #\;) (incf i)) (incf i))) (do ((size (length fun))) ((>= i size)) (declare (fixnum size)) (let ((char (char fun i))) (declare (character char)) (cond ((char= char #\#) (let ((ch (char fun (the fixnum (1+ i)))) (n 0)) (cond ((eql ch #\n) (wt (length locs))) ((or (eql ch #\*) (eql ch #\?)) (let* ((f (char= (char fun (1- i)) #\()) (e (char= (char fun (+ 2 i)) #\))) (locs (nthcdr 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)))) ((eql ch #\v) (wt-fixnum-loc (cond ((eq *value-to-go* 'top) (list 'vs-address "base" (cdr (vs-push)))) ((and (not (eq *value-to-go* 'return)) (not (rassoc *value-to-go* +return-alist+)) (not *values-to-go*)) (list 'fixnum-value nil 0)) (*mv-var* (cond ((>= (var-known-init *mv-var*) 0) (setq *values-to-go* (nthcdr (var-known-init *mv-var*) *values-to-go*))) (t (unless (boundp '*extend-vs-top*) (baboon)) (setq *extend-vs-top* t *values-to-go* nil))) (list 'var *mv-var* nil)) ((list 'vs-address "base" (cdr (vs-push))))))) ((setq n (digit-char-p ch)) (do (m (ii (+ i 2) (1+ ii))) ((not (setq m (when (> (length fun) ii) (digit-char-p (setq ch (char fun ii)))))) (setq max (max max (1+ n))) (let ((*values-to-go* nil)) (wt-loc (nth n locs)))) (setq n (+ (* n 10) m) i (1+ i)))) ((wt ch)))) (incf i 2)) ((char= char #\@);FIXME better error checking (let* ((n (- (char-code (char fun (1+ i))) #.(char-code #\1))) (n (if (digit-char-p (char fun (+ i 2))) (+ (* 10 (1+ n)) (- (char-code (char fun (1+ (incf i)))) #.(char-code #\1))) n)) (pos (position #\@ fun :start (+ i 2))) (new-fun (subseq fun (+ i 2) pos)) (*value-to-go* (or (nth n *values-to-go*) (and (member *value-to-go* '(top return)) (list 'vs (vs-push))) 'trash)) (*values-to-go* nil)) (set-loc (list (nth n others) (flags) new-fun locs)) (setf maxv (max maxv (1+ n))) (setf i (1+ pos)))) (t (princ char *compiler-output1*) (incf i))))) (setq *values-to-go* (nthcdr maxv *values-to-go*))) ((values (apply fun locs)))))) (defun wt-inline (flags fun locs) (declare (ignore flags)) (wt-inline-loc fun locs)) (defun wt-inline-string (flags fun locs) (declare (ignore flags)) (when (zerop *space*) (wt "CMP")) (wt "make_simple_string(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-cond (flags fun locs) (declare (ignore flags)) (wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil") (wt ")")) (defun wt-inline-fixnum (flags fun locs) (declare (ignore flags)) (when (zerop *space*) (wt "CMP")) (wt "make_fixnum(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-integer (flags fun locs) (declare (ignore flags)) (wt "make_integer(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-character (flags fun locs) (declare (ignore flags)) (wt "code_char(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-char (flags fun locs) (declare (ignore flags)) (wt "make_fixnum(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-long-float (flags fun locs) (declare (ignore flags)) (wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-short-float (flags fun locs) (declare (ignore flags)) (wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-fcomplex (flags fun locs) (declare (ignore flags)) (wt "make_fcomplex(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-dcomplex (flags fun locs) (declare (ignore flags)) (wt "make_dcomplex(") (wt-inline-loc fun locs) (wt ")")) ;;; Borrowed from CMPOPT.LSP (defmacro can-allocate-on-stack () `(and (consp *value-to-go*) (eq (car *value-to-go*) 'var) (var-dynamic (second *value-to-go*)) (not (var-cb (second *value-to-go*))))) (defun wt-stack-list* (x l &optional n (st "Cnil") (lst "Cnil")) (let ((z (or n (length x)))) (when n (wt-nl "({ufixnum _z=" z ";!_z ? Cnil :")) (wt-nl "({object _b=OBJ_ALIGNED_STACK_ALLOC(" (if n "_z" z) "*sizeof(struct cons));") (wt-nl "register struct cons *_p=(void *)_b;") (cond (n (wt-nl "struct cons *_e=_p+(_z-1);") (wt-nl "for (;_p<_e;_p++) {_p->c_car=" st ";_p->c_cdr=(object)(_p+1);}") (wt-nl "_p->c_car=" lst ";_p->c_cdr=Cnil;_b;});})")) ((dolist (x x (wt-nl "_p[-1].c_cdr=" l ";_b;})")) (wt-nl "_p->c_car=" x ";_p->c_cdr=(object)(_p+1);_p++;")))))) (defun list-inline (&rest x &aux (*values-to-go* nil)) (assert x) (cond ((can-allocate-on-stack) (wt-stack-list* x nil)) ((endp (cdr x)) (wt "make_cons(" (car x) ",Cnil)")) (t (wt "list(" (length x)) (dolist (loc x (wt #\))) (wt #\, loc))))) (defun list*-inline (&rest x &aux (*values-to-go* nil)) (assert x) (if (can-allocate-on-stack) (wt-stack-list* (butlast x) (car (last 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 #\)))))) (defun make-list-inline (n &aux (*values-to-go* nil)) (if (can-allocate-on-stack) (wt-stack-list* nil nil n) (wt "make_list(" n ")"))) (defun cons-inline (x y &aux (*values-to-go* nil)) (if (can-allocate-on-stack) (wt-stack-list* (list x) y) (wt "make_cons(" x "," y ")"))) (defun c-cast (aet) (or (cdr (assoc aet +c-type-string-alist+)) (baboon))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpvar.lsp0000644000000000000000000000013114774225213015500 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.472939196 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpvar.lsp0000644000175000017500000006145114774225213015106 0ustar00cammcamm;;; CMPVAR Variables. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'var 'c2var 'c2) (si:putprop 'location 'c2location 'c2) (si:putprop 'setq 'c1setq 'c1special) (si:putprop 'setq 'c2setq 'c2) (si:putprop 'progv 'c1progv 'c1special) (si:putprop 'progv 'c2progv 'c2) ;; (si:putprop 'psetq 'c1psetq 'c1) ;; (si:putprop 'psetq 'c2psetq 'c2) (si:putprop 'var 'set-var 'set-loc) (si:putprop 'cvar 'set-cvar 'set-loc) (si:putprop 'var 'wt-var 'wt-loc) (defstruct (var (:print-function (lambda (x s i) (s-print 'var (var-name x) (si::address x) s)))) name ;;; Variable name. kind ;;; One of LEXICAL, SPECIAL, GLOBAL, REPLACED, FIXNUM, ;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, and OBJECT. ref ;;; Referenced or not. ;;; During Pass1, T, NIL, or IGNORE. ;;; During Pass2, the vs-address for the variable. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the ccb-vs for the variable, or NIL. loc ;;; For SPECIAL and GLOBAL, the vv-index for variable name. ;;; For others, this field is used to indicate whether ;;; to be allocated on the value-stack: OBJECT means ;;; the variable is declared as OBJECT, and CLB means ;;; the variable is referenced across Level Boundary and thus ;;; cannot be allocated on the C stack. Note that OBJECT is ;;; set during variable binding and CLB is set when the ;;; variable is used later, and therefore CLB may supersede ;;; OBJECT. ;;; For REPLACED, the actual location of the variable. ;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, and ;;; OBJECT, the cvar for the C variable that holds the value. ;;; Not used for LEXICAL. (dt t) ;;; Declared Type of the variable. (type t) ;;; Current Type of the variable. (mt t) ;;; Maximum type of the life of this binding tag ;;; Inner tag (to binding) being analyzed if any (register 0 :type unsigned-char) ;;; If greater than specified am't this goes into register. (flags 0 :type unsigned-char) ;;; If variable is declared dynamic-extent (space 0 :type char) ;;; If variable is declared as an object array of this size (known-init -1 :type char) ;;; Number of above known to be implicitly initialized store ;;; keep kind in hashed c1forms aliases ) (si::freeze-defstruct 'var) (defun var-dynamic (v);FIXME (/= 0 (logand 1 (var-flags v)))) (defun var-reffed (v) (/= 0 (logand 2 (var-flags v)))) (defun var-noreplace (v) (/= 0 (logand 4 (var-flags v)))) (defun var-set (v) (/= 0 (logand 8 (var-flags v)))) (defun var-aliased (v) (/= 0 (logand 16 (var-flags v)))) (defun set-var-dynamic (v) (setf (var-flags v) (logior 1 (var-flags v)))) (defun set-var-reffed (v) (setf (var-flags v) (logior 2 (var-flags v)))) (defun set-var-noreplace (v) (setf (var-flags v) (logior 4 (var-flags v)))) (defun set-var-set (v) (setf (var-flags v) (logior 8 (var-flags v)))) (defun set-var-aliased (v) (setf (var-flags v) (logior 16 (var-flags v)))) (defun unset-var-set (v) (setf (var-flags v) (logandc2 (var-flags v) 8))) (defun unset-var-aliased (v) (setf (var-flags v) (logandc2 (var-flags v) 16))) ;;; A special binding creates a var object with the kind field SPECIAL, ;;; whereas a special declaration without binding creates a var object with ;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure ;;; that the variable has a value. (defvar *vars* nil) (defvar *register-min* 4) ;criteria for putting in register. (defvar *undefined-vars* nil) (defvar *special-binding* nil) ;;; During Pass 1, *vars* holds a list of var objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *vars* when the compiler begins to process a closure. 'LB' will be pushed ;;; on *vars* when *level* is incremented. ;;; *GLOBALS* holds a list of var objects for those variables that are ;;; not defined. This list is used only to suppress duplicated warnings when ;;; undefined variables are detected. (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 ens-k-tp (tp) (or (third tp) (member-if (lambda (x) (when (member (car x) '(proper-cons si::improper-cons)) (member-if (lambda (x) (when (listp x) (or (ens-k-tp (car x)) (ens-k-tp (cadr x))))) (cdr x)))) (car tp)))) (defun ensure-known-type (tp) (if (when (listp tp) (ens-k-tp (third tp))) (car tp) tp)) (defun c1make-var (name specials ignores types &aux x) (let ((var (make-var :name name))) (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being bound." name) (dolist (v types) (when (eq (car v) name) (case (cdr v) (object (setf (var-loc var) 'object)) (register (setf (var-register var) (+ (var-register var) 100))) (dynamic-extent #+dynamic-extent (set-var-dynamic var)) (t (unless (and (not (get (var-name var) 'tmp));FIXME *compiler-new-safety*) (setf (var-type var) (ensure-known-type (nil-to-t (type-and (var-type var) (cdr v)))))))))) (cond ((or (member name specials) (si:specialp name)) (setf (var-kind var) 'SPECIAL) (setf (var-loc var) name) (when (and (not *compiler-new-safety*) (not (assoc name types)) (setq x (get name 'cmp-type))) (setf (var-type var) (ensure-known-type x))) (setq *special-binding* t)) (t (and (boundp '*c-gc*) *c-gc* (or (null (var-type var)) (eq t (var-type var))) (setf (var-loc var) 'object)) (setf (var-kind var) 'LEXICAL))) (let ((ign (member name ignores))) (when ign (setf (var-ref var) (if (eq (cadr ign) 'ignorable) 'IGNORABLE 'IGNORE)))) (setf (var-mt var) (var-type var)) (setf (var-dt var) (var-type var)) var)) (defvar *top-level-src* nil) (defvar *top-level-src-p* t) (defun mark-toplevel-src (src) (when *top-level-src-p* (pushnew src *top-level-src*)) src) (defun check-vref (var) (when *top-level-src-p* (when (and (eq (var-kind var) 'LEXICAL) (not (var-reffed var)) (not (var-ref var)));;; This field may be IGNORE or IGNORABLE here. (cmpstyle-warn "The variable ~s is not used." (var-name var))))) (defun var-cb (v) (or (var-ref-ccb v) (eq 'clb (var-loc v)))) (defun add-vref (vref info &optional setq) (cond ((cadr vref) (push (car vref) (info-ref-ccb info))) ((caddr vref) (push (car vref) (info-ref-clb info))) ((not setq) (push (car vref) (info-ref info))))) (defun make-vs (info) (mapcan (lambda (x) (when (var-p x) (list (cons x (var-bind x))))) (info-ref info))) (defun check-vs (vs &aux (b (member-if-not 'var-p *vars*))) (not (member-if-not (lambda (x &aux (v (pop x))(vv (member v *vars*))) (when vv (when (tailp b vv) (bind-match x v)))) vs))) (defun find-vs (form) (case (car form) ((var lit) (car (last form))))) (defun c1var (name) (let* ((info (make-info)) (vref (c1vref name)) (tmp (get-var (local-var vref))) (tmp (unless (eq tmp (car vref)) tmp)) (vref (if tmp (c1vref tmp) vref)) (c1fv (when (cadr vref) (c1inner-fun-var)))) (setf (info-type info) (if (or (cadr vref) (caddr vref)) (var-dt (car vref)) (var-type (car vref))) (var-mt (car vref)) (type-or1 (info-type info) (var-mt (car vref)))) (add-vref vref info) (when c1fv (add-info info (cadr c1fv))) (mapc (lambda (x) (setf (info-ch-ccb info) (nunion (info-ch-ccb info) (info-ch-ccb (cadr x)))));FIXME nunion asym (binding-forms (var-store (car vref)))) (let ((fmla (exit-to-fmla-p))) (cond ((when fmla (type>= #tnull (info-type info))) (c1nil)) ((when fmla (type>= #t(not null) (info-type info))) (c1t)) ((let ((tmp (get-vbind-form (local-var vref)))) (when (and tmp );FIXME (type>= (var-mt (car vref)) (var-mt (caaddr tmp))) (when (check-vs (find-vs tmp));(when (eq 'var (car tmp)) (car (last tmp))) (let* ((f (pop tmp))(i (copy-info (pop tmp)))) ; (setf (info-type i) (if (eq f 'var) (var-type (caar tmp)) (type-and (info-type i) (info-type info))));FIXME (setf (info-type i) (type-and (info-type i) (info-type info))) (when (eq f 'var) (setf (info-type i) (type-and (info-type i) (var-type (caar tmp))))) (list* f i tmp)))))) ((list 'var info vref c1fv (make-vs info))))))) (defun ref-obs (form obs sccb sclb s &aux (i (cadr form))) (mapc (lambda (x) (when (member x (info-ref-ccb i)) (funcall sccb x)) (when (member x (info-ref-clb i)) (funcall sclb x)) (when (member x (info-ref i)) (funcall s x))) obs)) (declaim (inline ref-obs)) (defun ref-vars (form vars) (ref-obs form vars (lambda (x) (when (eq (var-kind x) 'lexical) (setf (var-ref-ccb x) t))) (lambda (x) (when (eq (var-kind x) 'lexical) (setf (var-loc x) 'clb)) (setf (var-ref x) t)) (lambda (x) (setf (var-ref x) t (var-register x) (1+ (var-register x)))))) (defun inner-fun-var (&optional (v *vars*) f &aux (y v) (x (pop v))) (cond ((atom v) nil) ((is-fun-var x) (inner-fun-var v y)) ((eq x 'cb) f) ((inner-fun-var v f)))) (defun c1inner-fun-var nil (let ((*vars* (inner-fun-var))) (c1var (var-name (car *vars*))))) (defun local-var (vref &aux (v (pop vref))) (unless (or (car vref) (cadr vref)) v)) (defun get-vbind-form (form &aux (binding (get-vbind form))) (when binding (when (binding-repeatable binding) (binding-form binding)))) (defun var-bind (var &aux (st (when (var-p var) (when (eq 'lexical (var-kind var)) (var-store var))))) (unless (cdr st) (car st))) (defun get-vbind (form) (var-bind (typecase form ((cons (eql var) t) (when (check-vs (car (last form))) (local-var (caddr form)))) (var form)))) (defun lit-bind (x) (case (car x) (lit (sixth x)))) (defun get-bind (x) (typecase x ((cons (eql var) t) (when (check-vs (car (last x))) (var-bind (local-var (caddr x))))) ((cons (eql lit) t) (when (check-vs (car (last x))) (lit-bind x))) (var (var-bind x)) (binding x))) (defun repeatable-var-binding (form) (case (car form) ((var location lit) form))) (defun repeatable-binding-p (form &aux (i (cadr (repeatable-var-binding form)))) (when i (when (info-type i) (unless (iflag-p (info-flags i) side-effects) (unless (or (info-ref-clb i) (info-ref-ccb i)) t))))) (defun new-bind (&optional form) (make-binding :form form :repeatable (repeatable-binding-p form))) (defun or-bind (b l &aux (bi (cadr (binding-form b)))) (cond ((when (cdr l) (when bi (not (info-ch-ccb bi))));FIXME coalesce anonymous too? (pushnew b l :test (lambda (x y) (or (eq x y) (when (binding-form y) (type<= (info-type bi) (info-type (cadr (binding-form y))))))))) ((pushnew b l)))) (defun or-binds (l1 l2) (reduce (lambda (y x) (or-bind x y)) l1 :initial-value l2)) (defun bind-block (name) (or (eq name +mv+); FIXME c1 *mv-var* ; (eq name +first+) ; (eq name +fun+) ; (get name 'tmp) ; (eq name +nargs+) ;FIXME invalidate on call )) (defun push-vbind (var form &optional or) (unless (bind-block (var-name var)) (setf (var-store var) (or-bind (or (get-bind form) (new-bind form)) (when or (var-store var)))))) (defun push-vbinds (var forms); &optional or (mapc (lambda (x) (push-vbind var x t)) forms)) (defun bind-match (f1 f2 &aux (b1 (get-bind f1))) (when b1 (eq b1 (get-bind f2)))) (defun get-top-var-binding (bind) (labels ((f (l) (member bind l :key 'var-bind)) (r (l) (let* ((var (car l)) (nl (f (cdr l))) (nl (when (eq nl (member (car nl) *vars*)) nl)));FIXME impossible? (if (tailp nl (member-if-not 'var-p l)) var (r nl))))) (when bind ;FIXME defvar (r (f *vars*))))) (defun get-var (o &aux (vp (var-p o))) (or (get-top-var-binding (if vp (get-vbind o) o)) (when vp o))) (defun c1vref (name &optional setq &aux ccb clb) (dolist (var *vars* (let ((var (sch-global name))) (unless var (unless (symbolp name) (baboon)) (unless (or (si:specialp name) (constantp name)) (undefined-variable name)) (setq var (make-var :name name :kind 'GLOBAL :loc name :type (or (get name 'cmp-type) t) :ref t));FIXME (push var *undefined-vars*)) (list var ccb))) (cond ((eq var 'cb) (setq ccb t)) ((eq var 'lb) (setq clb t)) ((or (when (eq (var-name var) name) (not (member var *lexical-env-mask*))) (eq var name)) (unless setq (when (eq (var-ref var) 'IGNORE) (unless (var-reffed var) (cmpstyle-warn "The ignored variable ~s is used." name)))) (set-var-reffed var) (keyed-cmpnote (list 'var-ref (var-name var)) "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb))) (return-from c1vref (list* var (if (eq (var-kind var) 'lexical) (list ccb clb) '(nil nil)))))))) (defun c2var-kind (var) (when (and (eq (var-kind var) 'LEXICAL) (not (var-ref-ccb var)) (not (eq (var-loc var) 'clb))) (cond ((eq (var-loc var) 'object) (setf (var-type var) #tt) (var-loc var)) ;FIXME check ok; need *c-vars* and kind to agree ((car (member (var-type var) +c-local-var-types+ :test 'type<=))) ((and (boundp '*c-gc*) *c-gc* 'OBJECT))))) (defun c2var (vref c1fv stores) (declare (ignore c1fv stores)) (unwind-exit (cons 'var vref) nil 'single-value)) (defun c2location (loc) (unwind-exit loc nil 'single-value)) (defun wt-var (var ccb &optional clb) (declare (ignorable clb));FIXME (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))) ; (REPLACED (cond ((and (consp (var-loc var)) (info-p (cadr (var-loc var))))FIXME ; (let* ((*inline-blocks* 0)(v (c2expr (var-loc var))))(print v)(break) ; (unwind-exit (get-inline-loc `((t) t #.(flags) "(#0)") (list v)) ; nil 'single-value) ; (close-inline-blocks))) ; ((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 (let ((z (cdr (assoc (var-kind var) +wt-c-var-alist+)))) (unless z (baboon)) (when (and (equal #tfixnum (var-kind var)) (zerop *space*)) (wt "CMP")) (wt z) (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 &optional clb) (declare (ignore clb)) (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 ";")) (t (wt-nl "V" (var-loc var) "= ") (funcall (or (cdr (assoc (var-kind var) +wt-loc-alist+)) (baboon)) loc) (wt ";"))))) (defun set-cvar (loc cvar) (wt-nl "V" cvar "= ") (let* ((fn (or (car (rassoc cvar *c-vars*)) (cdr (assoc cvar *c-vars*)) t)) (fn (or (car (member fn +c-local-var-types+ :test 'type<=)) 'object)) (fn (cdr (assoc fn +wt-loc-alist+)))) (unless fn (baboon)) (funcall fn loc)) (wt ";")) (defun sch-global (name) (dolist (var *undefined-vars* nil) (when (or (eq var name) (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 name :type (or (get name 'cmp-type) 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))) ((do ((pairs args) forms) ((endp pairs) (c1expr (cons 'progn (nreverse forms)))) (cmpck (endp (cdr pairs)) "No form was given for the value of ~s." (car pairs)) (push (list 'setq (pop pairs) (pop pairs)) forms))))) (defun llvar-p (v) (when (eq (var-kind v) 'lexical) (let ((x (member v *vars*))) (when x (tailp (member-if-not 'var-p *vars*) x))))) (defun do-setq-tp (v form t1) (unless nil ; *compiler-new-safety* FIXME (when (llvar-p v) (setq t1 (ensure-known-type (coerce-to-one-value t1))) (let* ((tp (type-and (var-dt v) t1))) (unless (or tp (not (and (var-dt v) t1))) (cmpwarn "Type mismatches setting declared ~s variable ~s to type ~s from form ~s." (cmp-unnorm-tp (var-dt v)) (var-name v) (cmp-unnorm-tp t1) (car form))) (keyed-cmpnote (list (var-name v) 'type-propagation 'type) "Setting var-type on ~s from ~s to ~s, form ~s, max ~s" (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp) (car form) (cmp-unnorm-tp (var-mt v))) (when (member v *restore-vars-env*) (pushnew (list v (var-type v) (var-store v)) *restore-vars* :key 'car)) (setf (var-type v) tp) (unless (type>= (var-mt v) tp) (setf (var-mt v) (type-and (bbump-tp (type-or1 (var-mt v) tp)) (var-dt v)))))))) (defun set-form-type (form type &optional no-recur) (sft form type no-recur)) ;; (defun set-form-type (form type) (setf (info-type (cadr form)) (type-and type (info-type (cadr form))))) ; (sft form type)) FIXME cannot handle nil return types such as tail recursive calls (defun sft-block (form block type) (cond ((atom form)) ((and (eq (car form) 'return-from) (eq (third form) block)) (sft (car (last form)) type)) (t (sft-block (car form) block type) (sft-block (cdr form) block type)))) (defun sft (form type &optional no-recur);FIXME sft-block labels avoid mutual recursion (let ((it (info-type (cadr form)))) (unless (type>= type it) (let ((nt (type-and type it))) (unless nt (keyed-cmpnote (list 'nil-arg) "Setting form type ~s to nil" (cmp-unnorm-tp it))) (when (or (eq form (c1nil)) (eq form (c1t)));FIXME (unless (type= it nt) (return-from sft nil))) (setf (info-type (cadr form)) nt) (unless no-recur (case (car form) (block (sft-block (fourth form) (third form) type)) ((decl-body inline) (sft (car (last form)) type)) ((let let*) (sft (car (last form)) type) (mapc (lambda (x y) (sft y (var-type x))) (caddr form) (cadddr form))) (lit (mapc (lambda (x) (do-setq-tp x nil (type-and nt (var-type x)))) (local-aliases (get-top-var-binding (lit-bind form)) nil))) (var (do-setq-tp (caaddr form) nil (type-and nt (var-type (caaddr form))))) (progn (sft (car (last (third form))) type)))))))) ;; (if ;; (when (ignorable-form (third form));FIXME put third form into progn ;; (let ((tt (type-and type (nil-to-t (info-type (cadr (fourth form)))))) ;; (ft (type-and type (nil-to-t (info-type (cadr (fifth form))))))) ;; (unless tt ;; (sft (fifth form) type) ;; (setf (car form) 'progn (cadr form) (cadr (fifth form)) (caddr form) ;; (list (fifth form)) (cdddr form) nil)) ;; (unless ft ;; (sft (fourth form) type) ;; (setf (car form) 'progn (cadr form) (cadr (fourth form)) (caddr form) ;; (list (fourth form)) (cdddr form) nil))))) (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 t)) (when (member (var-kind (car name1)) '(special global));FIXME (setf (info-flags info) (logior (iflags side-effects) (info-flags info)))) ; (push-changed (car name1) info) (add-vref name1 info t) (setq form1 (c1arg form info)) (when (and (eq (car form1) 'var) (or (eq (car name1) (caaddr form1)) (bind-match form1 (car name1)))) (return-from c1setq1 form1)) (unless (and (eq (car form1) 'var) (eq (car name1) (caaddr form1))) (push-changed (car name1) info)) (when (eq (car form1) 'var) (unless (eq (caaddr form1) (car name1)) (pushnew (caaddr form1) (var-aliases (car name1))))) (let* ((v (car name1))(st (var-bind v))) (cond ((and (eq (var-kind v) 'lexical) (or (cadr name1) (caddr name1))) (setq type (info-type (cadr form1))) (push (cons (car name1) form1) (info-ch-ccb info))) (t (do-setq-tp v (list form form1) (info-type (cadr form1))) (setq type (var-type (car name1))) (push-vbind v form1) (keyed-cmpnote (list (var-name v) 'var-bind) "~s store set from ~s to ~s" v st (var-bind v))))) (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) (maybe-reverse-type-prop type form1) (let ((c1fv (when (cadr name1) (c1inner-fun-var)))) (when c1fv (add-info info (cadr c1fv))) (list 'setq info name1 form1 c1fv))) (defun untrimmed-var-p (v) (or (eq t (var-ref v)) (consp (var-ref v)) (var-cb v) (member (var-kind v) '(special global)))) (defun c2setq (vref form c1fv &aux (v (car vref))) (declare (ignore c1fv)) (cond ((untrimmed-var-p v) (let ((*value-to-go* (push 'var vref))) (cond ((member (var-kind v) '(special global));FIXME (let ((loc `(cvar ,(cs-push (var-type v))))) (let ((*value-to-go* loc)) (c2expr* form)) (set-loc loc))) ((c2expr* form)))) (case (car form) (LOCATION (c2location (caddr form))) (otherwise (unwind-exit vref)))) ((c2expr form)))) (defun c1progv (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'progv 2 (length args))) (list 'progv info (c1arg (pop args) info) (c1arg (pop args) info) (c1progn* args info))) (defun c2progv (symbols values body &aux (cvar (cs-push t t)) (*unwind-exit* *unwind-exit*)) (wt-nl "{object " *volatile* "symbols,values;") (wt-nl "bds_ptr " *volatile* "V" cvar "=bds_top;") (wt-nl "V" cvar "=V" cvar ";");FIXME lintian unused var (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(symbols->c.c_car)!=t_symbol)") (wt-nl "not_a_symbol(symbols->c.c_car);")) (wt-nl "if(endp(values))bds_bind(symbols->c.c_car,OBJNULL);") (wt-nl "else{bds_bind(symbols->c.c_car,values->c.c_car);") (wt-nl "values=values->c.c_cdr;}") (wt-nl "symbols=symbols->c.c_cdr;}") (setq *bds-used* t)) (c2expr body) (wt "}")) (defun wt-var-decl (var) (cond ((var-p var) (let ((n (var-loc var))) (wt *volatile* (register var) (rep-type (var-kind var)) "V" n ) (wt ";"))) (t (wfs-error)))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_lfun_list.lsp0000644000000000000000000000013114774225213016207 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.476939222 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_lfun_list.lsp0000644000175000017500000000545214774225213015614 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;; Modified data base including return values types ;; and making the arglists correct if they have optional args. ;; (in-package :compiler) (dolist (l '((((stream) string) . get-output-stream-string) (((simple-vector seqind) t) . svref) (((t *) string) . print) (((t *) string) . prin1) (((t *) string) . princ) (((si::function-identifier) boolean) . fboundp) (((structure) structure) . si::structure-def) (((t t t t t t t) pathname) . si::init-pathname) (((t t *) (or (integer -1 -1 ) seqind)) . si::string-match) ; (((t) t) . si::type-of-c) ; (((list) t) . si::cons-car) ; (((list) t) . si::cons-cdr) (((t t) cons) . cons) (((*) si::proper-list) . list) (((t *) list) . list*) (((fixnum) t) . si::nani) (((t) fixnum) . si::address);FIXME ; (((integer) fixnum) . si::mpz_bitlength) ; (((integer fixnum) integer) . si::shft) (((number number) number) . si::number-plus) (((number number) number) . si::number-minus) (((number number) number) . si::number-times) (((number number) number) . si::number-divide) (((real *) (returns-exactly real real)) . floor) (((real *) (returns-exactly real real)) . ceiling) (((real *) (returns-exactly real real)) . truncate) (((real *) (returns-exactly real real)) . round) ; (((cons t) cons) . rplaca) ; (((cons t) cons) . rplacd) ; (((symbol) boolean) . boundp) ; (((symbol) (or null package)) . symbol-package) ; (((symbol) string) . symbol-name) ; (((symbol) t) . symbol-value) (((symbol t t) t) . si::sputprop) ; (((symbol) (or cons function)) . symbol-function);fixme ;; (((array rnkind) seqind) . array-dimension) ;; (((array) seqind) . array-total-size) ;; (((array) symbol) . array-element-type) ;; (((array) rnkind) . array-rank) ; (((vector) seqind) . si::fill-pointer-internal) (((string) symbol) . make-symbol) ; (((integer integer) integer) . ash) (((float) (returns-exactly (integer 0) fixnum (member 1 -1))) . integer-decode-float);fixme ; (((t *) nil) . error);fixme (((*) string) . si::string-concatenate))) (let ((x (si::call (cdr l) t))) (cond (x (setf (car x) (list (mapcar 'cmp-norm-tp (caar l)) (cmp-norm-tp (cadar l)))) (si::normalize-function-plist x)) ((print (cdr l)))))) (dolist (l '(ceiling truncate round floor));FIXME (c-set-function-vv (symbol-function l) 0) (c-set-function-neval (symbol-function l) 1) ) (dolist (l '(eq eql equal equalp ldb-test logtest)) (setf (get l 'predicate) t)) (dolist (l '(ldb-test logtest)) (setf (get l 'predicate) t)) (declaim (notinline compile compile-file load open truename translate-pathname translate-logical-pathname probe-file)) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpspecial.lsp0000644000000000000000000000013114774225213016330 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.472939196 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpspecial.lsp0000644000175000017500000002220714774225213015732 0ustar00cammcamm;;; CMPSPECIAL Miscellaneous special forms. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'quote 'c1quote 'c1special) (si:putprop 'function 'c1function 'c1special) (si:putprop 'function 'c2function 'c2) (si:putprop 'the 'c1the 'c1special) (si:putprop 'eval-when 'c1eval-when 'c1special) (si:putprop 'declare 'c1declare 'c1special) (si:putprop 'compiler-let 'c1compiler-let 'c1special) (si:putprop 'compiler-let 'c2compiler-let 'c2) (defun c1quote (args) (when (endp args) (too-few-args 'quote 1 0)) (unless (endp (cdr args)) (too-many-args 'quote 1 (length args))) (c1constant-value (car args) t)) (defun c1eval-when (args) (when (endp args) (too-few-args 'eval-when 1 0)) (dolist (situation (car args) (c1nil)) (case situation ((eval :execute) (return-from c1eval-when (c1progn (cdr args)))) ((load :load-toplevel compile :compile-toplevel)) (otherwise (cmperr "The situation ~s is illegal." situation)))) ) (defun c1declare (args) (cmperr "The declaration ~s was found in a bad place." (cons 'declare args))) (defun c1the (args &aux info form dtype);FIXME rethink this whole function (when (or (endp args) (endp (cdr args))) (too-few-args 'the 2 (length args))) (unless (endp (cddr args)) (too-many-args 'the 2 (length args))) (setq form (c1expr (cadr args))) (setq info (copy-info (cadr form))) (setq dtype (cmp-norm-tp (cadr (si::ftype-to-sig (list nil (car args)))))) (when (exit-to-fmla-p) (setq dtype (type-or1 (when (type-and #tnull dtype) #tnull) (when (type-and #t(not null) dtype) #ttrue))));FIXME (when (equal dtype #tboolean) (unless (type>= dtype (info-type info)) (return-from c1the (c1expr `(when ,(cadr args) t))))) ; (setq type (type-and dtype (info-type info))) (setq form (list* (car form) info (cddr form))) (set-form-type form dtype (type>= #tboolean dtype));FIXME understand boolean exception ; (if (type>= #tboolean dtype) (setf (info-type (cadr form)) type) (set-form-type form dtype));FIXME ; (setf (info-type info) type) 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))) (defvar *fun-id-hash* (make-hash-table :test 'eq)) (defvar *fun-ev-hash* (make-hash-table :test 'eq)) (defvar *fun-tp-hash* (make-hash-table :test 'eq)) (defvar *fn-src-fn* (make-hash-table :test 'eq)) (defun coerce-to-funid (fn) (cond ((symbolp fn) fn) ((local-fun-p fn) fn) ((not (functionp fn)) nil) ((fn-get fn 'id)) ((si::function-name fn)))) ; ((portable-closure-src fn)) (defun find-special-var (l f) (when (consp l) (case (car l) (lambda (find-special-var (fifth l) f)) (decl-body (find-special-var (fourth l) f)) (let* (car (member-if f (third l))))))) (defun is-narg-le (l) (caadr (caddr l))) ;; (defun is-narg-le (l) ;; (find-special-var l 'is-narg-var)) (defun mv-var (l) (find-special-var l 'is-mv-var)) (defun fun-var (l) (find-special-var l 'is-fun-var)) (defun export-sig (sig) (uniq-sig `((,@(mapcar 'export-type (car sig))) ,(export-type (cadr sig))))) (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (regs (if (is-first-var (car regs)) (cdr regs) regs))) (export-sig `((,@(mapcar 'var-type regs) ,@(when (or (is-narg-le l) (member-if 'identity (cdr args))) `(*))) ,(info-type (cadar (last l)))))) (defun compress-fle (l y z) (let* ((fname (pop l)) (fname (or z fname)) (args (pop l)) (w (make-string-output-stream)) (out (pd fname args l)) (out (if y `(lambda-closure ,y nil nil ,@(cdr out)) out))) (if *compiler-compile* out (let ((ss (si::open-fasd w :output nil nil))) (si::find-sharing-top out (aref ss 1)) (si::write-fasd-top out ss) (si::close-fasd ss) (get-output-stream-string w))))) (defun mc nil (let ((env (cons nil nil))) (lambda nil env))) (defun afe (a f) (push a (car (funcall f))) f) (defun fn-get (fn prop) (cdr (assoc prop (car (funcall fn))))) (defun mf (id &optional fun) (let* ((f (mc))) ; (when (consp id) (setf (caddr (si::call f)) (compress-fle id nil nil))) (when fun (afe (cons 'fun fun) f)) (afe (cons 'id id) f) (when (or fun (consp id)) (afe (cons 'df (current-env)) f)) f)) (defun funid-to-fn (funid &aux fun) (cond ((setq fun (local-fun-p funid)) (fun-fn fun)) ; ((gethash funid *fn-src-fn*)) ; ((setf (gethash funid *fn-src-fn*) (mf funid))) ((symbolp funid) (or (gethash funid *fn-src-fn*) (setf (gethash funid *fn-src-fn*) (mf funid)))) ((mf funid)) )) (defvar *prov* nil) (defun c1function (args &optional (b 'cb) f &aux fd) (when (endp args) (too-few-args 'function 1 0)) (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) (let* ((funid (si::funid (car args))) (funid (mark-toplevel-src (if (consp funid) (effective-safety-src funid) funid))) (fn (afe (cons 'ce (current-env)) (funid-to-fn funid))) (tp (if fn (object-type fn) #tfunction)) (info (make-info :type tp))) (cond ((setq fd (c1local-fun funid t)) (add-info info (cadr fd)) `(function ,info ,fd)) ((symbolp funid) (setf (info-flags info) (logior (info-flags info) (iflags sp-change))) ; (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0)) `(function ,info (call-global ,info ,funid))) ((let* ((fun (or f (make-fun :name 'lambda :src funid :c1cb t :fn fn :info (make-info :type '*)))) (fd (if *prov* (list fun) (process-local-fun b fun funid tp)))) (add-info info (cadadr fd)) (when *prov* (pushnew funid *prov-src*) (setf (info-flags info) (logior (info-flags info) (iflags provisional)))) `(function ,info ,fd)))))) (defun update-closure-indices (cl) (mapc (lambda (x &aux (y (var-ref-ccb (car x)))) (setf (cadr x) (if (integerp y) (- y *initial-ccb-vs*) (baboon)) (car x) (var-name (car x)))) (second (third cl))) cl) (defun c2function (funob);FIXME (case (car funob) (call-global (unwind-exit (list 'symbol-function (caddr funob)))) (call-local (let* ((funob (caddr funob))(fun (pop funob))) (unwind-exit (if (cadr funob) (list 'ccb-vs (fun-ref-ccb fun)) (list 'vs* (fun-ref fun)))))) (otherwise (let* ((fun (pop funob)) (lam (car funob)) (cl (update-closure-indices (fun-call fun))) (sig (car cl)) (at (car sig)) (rt (cadr sig)) (clc (export-call-struct cl))) (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs* :key 'fourth) (cond (*clink* (let ((clc (cons '|#,| clc))) (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) (or (fun-vv fun) clc) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*)) (unless (fun-vv fun) (setf (fun-vv fun) clc)))) (t (unless (fun-vv fun) (setf (fun-vv fun) (cons '|#,| `(init-function ,clc ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) nil nil -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lam)))))) (unwind-exit (list 'vv (fun-vv 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 fname call argd sizes &rest r &aux (args (car r))) (declare (dynamic-extent r)) (declare (ignore args)) (wt "fSinit_function(") (wt-vv call) (wt ",(void *)" (c-function-name "LC" cfun fname) ",Cdata,") (wt-clink) (wt ",-1," argd "," sizes ")")) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpcatch.lsp0000644000000000000000000000013114774225213015772 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.444939017 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpcatch.lsp0000644000175000017500000001456314774225213015402 0ustar00cammcamm;;; CMPCATCH Catch, Unwind-protect, and Throw. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 :type #t* :flags (iflags sp-change volatile)))) (when (endp args) (too-few-args 'catch 1 0)) (let* ((tag (c1arg (pop args) info)) (in (mch)) (body (unwind-protect (c1progn args) (mapc (lambda (x &aux (v (pop x))) (setf (var-type v) (type-or1 (pop x) (var-type v)));FIXME do-setq-tp (push-vbinds v (car x)));FIXME c1throw/c1return-from in)))) (add-info info (cadr body)) (list 'catch info tag body))) (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) (add-libc "setjmp") (setq *frame-used* t) (wt-nl "frs_push(FRS_CATCH," loc ");")) (defun c1unwind-protect (args &aux (info (make-info :flags (iflags sp-change volatile))) form) (when (endp args) (too-few-args 'unwind-protect 1 0)) (setq form (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*funs* (cons 'lb *funs*)) (*vars* (cons 'lb *vars*))) (c1expr (car args)))) (or-ccb-assignments (list form)) (add-info info (cadr form)) (setf (info-type info) (info-type (cadr form))) (setq args (c1arg (cons 'progn (cdr args)))) (add-info info (cadr args)) (list 'unwind-protect info form args)) ;; (defun c1unwind-protect (args &aux (info (make-info :sp-change 1)) form) ;; (incf *setjmps*) ;; (when (endp args) (too-few-args 'unwind-protect 1 0)) ;; (setq form (let ((*blocks* (cons 'lb *blocks*)) ;; (*tags* (cons 'lb *tags*)) ;; (*funs* (cons 'lb *funs*)) ;; (*vars* (cons 'lb *vars*))) ;; (c1arg (car args)))) ;; (add-info info (cadr form)) ;; (setq args (c1progn (cdr args))) ;; (add-info info (cadr args)) ;; (list 'unwind-protect info form args)) ;; (defun c1unwind-protect (args &aux (info (make-info :sp-change 1)) form) ;; (incf *setjmps*) ;; (when (endp args) (too-few-args 'unwind-protect 1 0)) ;; (setq form (let ((*blocks* (cons 'lb *blocks*)) ;; (*tags* (cons 'lb *tags*)) ;; (*funs* (cons 'lb *funs*)) ;; (*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 (add-libc "setjmp") (setq *frame-used* t) (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_basec.c_cdr) vs_push(p->c.c_car);") (wt-nl "if (active) {") (wt-nl "unwind(fr,tag);") (unwind-exit nil) (wt-nl "} else {") (unwind-exit 'fun-val nil (if top-data (car top-data))) (wt "}}")) (defun c1no-value (args) (declare (ignore args)) (let ((f (copy-tree (c1nil)))) (setf (cadr f) (make-info :type #tnil)) f)) (si::putprop 'si::no-value 'c1no-value 'c1) (defun c1throw (args &aux (info (make-info :type #tnil :flags (iflags side-effects))) tag) (when (or (endp args) (endp (cdr args))) (too-few-args 'throw 2 (length args))) (unless (endp (cddr args)) (too-many-args 'throw 2 (length args))) (setq tag (c1arg (car args))) (add-info info (cadr tag)) (setq args (c1arg (cadr args))) (add-info info (cadr args)) (list 'throw info tag args)) ;; (defun c1throw (args &aux (info (make-info :type #tnil :flags (iflags side-effects))) tag) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'throw 2 (length args))) ;; (unless (endp (cddr args)) ;; (too-many-args 'throw 2 (length args))) ;; (setq tag (c1expr (car args))) ;; (add-info info (cadr tag)) ;; (setq args (c1expr (cadr args))) ;; (add-info info (cadr args)) ;; (list 'throw info tag args)) (defun c2throw (tag val &aux (*vs* *vs*) loc) (wt-nl "{frame_ptr fr;") (case (car tag) (LOCATION (setq loc (caddr tag))) (VAR (setq loc (cons 'var (third tag)))) (t (setq loc (list 'vs (vs-push))) (let ((*value-to-go* loc)) (c2expr* tag)))) (wt-nl "fr=frs_sch_catch(" loc ");") (wt-nl "if(fr==NULL) FEerror(\"The tag ~s is undefined.\",1," loc ");") (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(fr," loc ");") (unwind-exit nil) (wt-nl "}")) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpbind.lsp0000644000000000000000000000013114774225213015624 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.428938915 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpbind.lsp0000644000175000017500000000560714774225213015233 0ustar00cammcamm;;; CMPBIND Variable Binding. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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*. (defvar *new-env* nil) (defun c2bind (var) (case (var-kind var) (LEXICAL (when (var-ref-ccb var) (wt-nl) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push)))) (SPECIAL (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (var-loc var)) ",") (wt-vs (var-ref var)) (wt ");") (push 'bds-bind *unwind-exit*)) (t (wt-nl "V" (var-loc var) "=") (wt (or (cdr (assoc (var-kind var) +to-c-var-alist+)) (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) (clink (var-ref var) loc) (setf (var-ref-ccb var) (ccb-vs-push))) (t (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";")))) (SPECIAL (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (var-loc var)) "," loc ");") (push 'bds-bind *unwind-exit*)) (t (wt-nl "V" (var-loc var) "= ") (let ((wtf (cdr (assoc (var-kind var) +wt-loc-alist+)))) (unless wtf (baboon)) (funcall wtf loc)) (wt ";")))) (defun c2bind-init (var init) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (let* ((loc (list 'vs (var-ref var))) (*value-to-go* loc)) (c2expr* init)) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) ((let ((*value-to-go* (list 'vs (var-ref var)))) (c2expr* init))))) (SPECIAL (let* ((loc `(cvar ,(cs-push t))) (*value-to-go* loc)) (c2expr* init) (c2bind-loc var loc))) (t (let ((*value-to-go* (list 'var var nil))) (unless (assoc (var-kind var) +wt-loc-alist+) (baboon));FIXME??? (c2expr* init))))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmptop.lsp0000644000000000000000000000013114776006046015515 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.274034943 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmptop.lsp0000644000175000017500000021722614776006046015126 0ustar00cammcamm;;; CMPTOP Compiler top-level. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 *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) (defvar *volatile*) ;; Functions may use a block of C stack space. ;; (cs . i) will become Vcs[i]. (defvar *cs* 0) ;;; *objects* holds ( { object vv-index }* ). ;;; *function-links* ( {symbol vv-index} ) for function symbols needing link (defvar *global-funs* nil) ;;; *global-funs* holds ;;; ( { global-fun-name cfun }* ) (defvar *local-funs* nil) (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 ) (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 'macrolet 't1macrolet '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 'mflag 't3mflag 't3) ;(si:putprop 'defmacro 't2defmacro 't2) (si:putprop 'ordinary 't3ordinary 't3) (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 'defmacro 't3defmacro '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 mv) `(+ ,min (ash ,max 16) (ash (if ,mv 4 0) 8)));;fixme rationalize (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)(*bds-used* nil)(*frame-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")) (defun c-function-name (prefix num fname) (si::string-concatenate (string prefix) (if (stringp num) num (write-to-string num)) (let ((fname (string fname))) (si::string-concatenate "__" (dash-to-underscore fname) "__" (if (boundp '*compiler-input*) (subseq *init-name* 4) ""))))) (defvar *top-form* nil) (defun t1expr (form &aux (*current-form* form) (*top-form* form) (*first-error* t)) (catch *cmperr-tag* (when (consp form) (let ((fun (car form)) (args (cdr form)) fd) (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)) (values (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 (cmp-macro-function fun)) (t1expr (cmp-expand-macro-w fd form))) (t (t1ordinary form)))) ((consp fun) (t1ordinary form)) (t (cmperr "~s is illegal function." fun))))))) (defun declaration-type (type) (cond ((equal type "") "void") ((or (equal type "long ") (equal type "fixnum ")) "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*) (defvar *add-hash-calls*) (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* *add-hash-calls*) (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*) (t23expr *current-form* 't3)) ;;; 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)) (mapc (lambda (x) (add-init x)) *add-hash-calls*) #+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 (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) (dolist (x *function-links*) (let* ((num (second x)) (type (fourth x)) (type (if (link-arg-p type) type t)) (type (or type t));FIXME (args (fifth x)) (pc (eq type 'proclaimed-closure)) (newtype (cond (pc "") ((not type) "") ((rep-type type)))) (d (declaration-type newtype))) (when (eq type 'proclaimed-closure) (wt-h "static object *Lclptr"num";")) (if (and (not (null type)) (not (eq type 'proclaimed-closure)) (or args (not (eq t type)))) (progn (wt-h "static " d " LnkT" num "(object,...);") #-sgi3d (wt-h "static " d " (*Lnk" num ")() = (" d "(*)()) LnkT" num ";") #+sgi3d (wt-h "static " d " (*Lnk" num ")();")) (progn (wt-h "static " d " LnkT" num "();") #-sgi3d (wt-h "static " d " (*Lnk" num ")() = LnkT" num ";") #+sgi3d (wt-h "static " d " (*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))))))) (defvar *compile-ordinaries* nil) (defun t1progn (args) (cond ((equal (car args) ''compile) (let ((*compile-ordinaries* t)) (t1progn (cdr args)))) (t ; (dolist (form args) (t1expr form)) (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 function-symbol (name) (si::funid-sym name)) (defun function-string (name) (unless (symbolp name) (error "function names must be symbols~%")) (delete-if (lambda (x) (or (eq x #\@) (eq x #\/))) (si::string-concatenate (let ((p (symbol-package name))) (if p (package-name p) "")) "::" (symbol-name name)))) (defvar *compiler-auto-proclaim* t) (defvar *mlts* nil) (defmacro ndbctxt (&rest body) `(let ((*debug* *debug*) (*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*)) ,@body)) (defun is-declared-special (sym forms) (dolist (form forms) (cond ((stringp form)) ((and (consp form) (eq (car form) 'declare) (mapc (lambda (x) (and (consp x) (eq (car x) 'special) (member sym (cdr x)) (return t))) (cdr form))))))) (defun printable-tp (tp) (typecase tp (cons (and (printable-tp (car tp)) (printable-tp (cdr tp)))) ((or number array symbol character pathname) t))) (defun ensure-printable-tp (tp) (cond ((printable-tp tp) tp) ((listp tp) (car tp)) (#tt))) (defun portable-source (form &optional cdr) (cond ((atom form) form) (cdr (cons (portable-source (car form)) (portable-source (cdr form) t))) ((case (car form) ((let let* lambda) `(,(car form) ,(mapcar (lambda (x) (if (atom x) x `(,(car x) ,@(portable-source (cdr x) t)))) (cadr form)) ,@(let* ((r (delete-if (lambda (x) (or (not (si::specialp x)) (is-declared-special x (cddr form)))) (mapcar (lambda (x) (if (atom x) x (car x))) (cadr form)))));FIXME key name (when r `((declare (special ,@r))))) ,@(ndbctxt (portable-source (cddr form) t)))) ((quote function side-effects) form) (infer-tp `(,(car form) ,(cadr form) ,(ensure-printable-tp (caddr form)) ,@(portable-source (cdddr form) t))) (declare (let ((opts (mapcan (lambda (x) (if (eq (car x) 'optimize) (cdr x) (list x))) (remove-if-not (lambda (x) (and (consp x) (member (car x) '(optimize notinline)))) (cdr form))))) (when opts (local-compile-decls opts))) form) (the `(,(car form) ,(cadr form) ,@(portable-source (cddr form) t))) ((and or) `(,(car form) ,@(portable-source (cdr form) t))) ((check-type assert) form) ((flet labels macrolet) (let ((fns (mapcar 'car (cadr form)))) `(,(car form) ,(let ((*mlts* (if (eq (car form) 'labels) (append fns *mlts*) *mlts*))) (mapcar (lambda (x) `(,(car x) ,@(cdr (portable-source `(lambda ,@(cdr x)))))) (cadr form))) ,@(let ((*mlts* (append fns *mlts*))) (ndbctxt (portable-source (cddr form) t)))))) (multiple-value-bind `(,(car form) ,(cadr form) ,(portable-source (caddr form)) ,@(let ((r (remove-if (lambda (x) (or (not (si::specialp x)) (is-declared-special x (cdddr form)))) (cadr form)))) (when r `((declare (special ,@r))))) ,@(ndbctxt (portable-source (cdddr form) t)))) ((case ccase ecase) `(,(car form) ,(portable-source (cadr form)) ,@(mapcar (lambda (x) `(,(car x) ,@(portable-source (cdr x) t))) (cddr form)))))) ((let* ((fd (and (symbolp (car form)) (not (member (car form) *mlts*)) (or (unless (member (car form) *notinline*) (get (car form) 'si::compiler-macro-prop)) (macro-function (car form))))) (nf (if fd (cmp-expand-macro fd (car form) (cdr form)) form))) (portable-source nf (equal form nf)))))) ;(defvar *no-proxy-symbols* nil) (defun this-safety-level nil (cond (*compiler-push-events* 4) (*compiler-new-safety* 3) (*safe-compile* 2) (*compiler-check-args* 1) (0))) (defun pd (fname ll args) (multiple-value-bind (doc decls ctps args) (parse-body-header args) (let* ((nal (do (r (y ll)) ((or (not y) (eq (car y) '&aux)) (nreverse r)) (push (pop y) r))) (al (cdr (member '&aux ll))) (ax (mapcar (lambda (x) (if (atom x) x (car x))) al)) (dd (split-decls ax decls t)) (cc (split-ctps ax ctps))) (portable-source `(lambda ,nal ,@(when doc `(,doc)) ,@(nconc (nreverse (cadr dd)) (cadr cc));FIXME ,@(let* ((r args)(bname (blocked-body-name r))(fname (if (when bname (eq fname 'lambda)) bname fname)) (r (if (eq fname bname) (cddar r) r)) (r (if (or al (car dd)) `((let* ,al ,@(append (car dd) (car cc)) ,@r)) r))) `((block ,fname ,@r)))))))) (defvar *recursion-detected* nil) (defun split-decls (auxs decls &optional ro &aux ad dd) (dolist (l decls (list (nreverse ad) (nreverse dd))) (dolist (bb (cdr l)) (let ((b (if (member (car bb) '(type ftype)) (cdr bb) bb))) (cond ((eq (car b) 'optimize) (if ro (push `(declare ,b) dd) (push `(declare ,b) ad))) ((eq (car b) 'class);FIXME pcl (unless (<= (length b) 3) (cmperr "Unknown class declaration: ~s" b)) (if (member (cadr b) auxs) (push `(declare ,b) ad) (push `(declare ,b) dd))) ((multiple-value-bind (tt q) (list-split (cdr b) auxs) (let ((z (if (eq b bb) (list (car bb)) (list (car bb) (cadr bb))))) (when tt (push `(declare (,@z ,@tt)) ad)) (when q (push `(declare (,@z ,@q)) dd)))))))))) (defun split-ctps (auxs ctps) (let (ad dd) (dolist (l ctps) (if (member (cadr l) auxs) (push l ad) (push l dd))) (list (nreverse ad) (nreverse dd)))) (defun c1retnote (le) (case (car le) (call-global (list (third le) (export-type (info-type (second le))))) ((let let*) (list (car le) (export-type (info-type (second le))) (mapcar (lambda (x y) (list (var-name x) (c1retnote y))) (third le) (fourth le)) (c1retnote (fifth le)))) ((flet labels) (list (car le) (export-type (info-type (second le))) (mapcar (lambda (x y) (list (fun-name (car x)) (c1retnote y))) (third le) (fourth le)) (c1retnote (fifth le)))) (recur (list (car le) (export-type (info-type (second le))))) (progn (list (car le) (export-type (info-type (second le))) (mapcar 'c1retnote (car (last le))))) ((lambda decl-body) (list (car le) (export-type (info-type (second le))) (c1retnote (car (last le))))) (inline (list (car le) (caddr le) (export-type (info-type (second le))) (c1retnote (car (last le))))) (if (list (car le) (export-type (info-type (second le))) (c1retnote (fourth le)) (c1retnote (fifth le)))) (var (list (car le) (export-type (info-type (second le))) (var-name (car (third le))))) (location (list (car le) (export-type (info-type (second le))))) (return-from (list (car le) (c1retnote (car (last le))))) (tagbody `(,(car le) ,(export-type (info-type (second le))) ,@(mapcar (lambda(x) (unless (tag-p x) (c1retnote x))) (car (last le))))) (block `(,(car le) ,(export-type (info-type (second le))) ,@(mapcar 'c1retnote (last le)))) (otherwise (list (car le) 'foo)))) ;(defvar *callees* nil) (defconstant +nargs+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defconstant +fun+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defconstant +mv+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defconstant +first+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s)) (defun mll (ll) (let ((a (pop ll))) (cond ((not a) 0) ((eq a '&optional) (mll ll)) ((member a '(&rest &key)) 63) ((member a lambda-list-keywords) 0) ((1+ (mll ll)))))) (defun is-narg-var (v) (when (var-p v) (eq (var-name v) +nargs+))) (defun is-mv-var (v) (when (var-p v) (eq (var-name v) +mv+))) (defun is-fun-var (v) (when (var-p v) (eq (var-name v) +fun+))) (defun is-first-var (v) (when (var-p v) (eq (var-name v) +first+))) (dolist (l '(is-narg-var is-mv-var is-fun-var is-first-var)) (si::putprop l t 'cmp-inline)) (defun list-split (x y &optional iy niy (cx nil cxp));FIXME intersection/set-difference bootstrap (cond (cxp (if (or (not y) (eq cx (car y))) y (list-split x (cdr y) iy niy cx))) ((not x) (values iy niy)) (t (let* ((cx (car x)) (v (list-split x y iy niy cx))) (if v (push cx iy) (push cx niy)) (list-split (cdr x) y iy niy))))) (defun decl-safety (d &optional s) (cond ((consp (car d)) (max (decl-safety (car d) s) (decl-safety (cdr d) s))) ((eq (car d) 'declare) (decl-safety (cdr d) 1)) ((and s (= s 1) (eq (car d) 'optimize)) (decl-safety (cdr d) 2)) ((and s (= s 2) (eq (car d) 'safety)) (or (cadr d) 3)) (0))) (defun effective-safety (decls) (max (decl-safety decls) (this-safety-level))) (defun remove-ignore-decls (decls) (mapcar (lambda (x) (remove-if (lambda (y) (when (consp y) (eq (car y) 'ignore))) x)) decls)) (defun new-defun-args (args tag) (let* ((nm (si::funid-to-sym (car args))) (args (ttl-tag-src args tag nm)) (args (cdr args)) (ll (pop args)) (opts (member-if (lambda (x) (member x '(&optional &rest &key &aux))) ll)));FIXME centralize (multiple-value-bind (doc decls ctps args) (parse-body-header args) (let* ((regs (ldiff ll opts)) (dl (decl-safety decls)) (sl (effective-safety decls)) (s (> sl 0)) (od (split-decls regs decls)) (rd (remove-ignore-decls (pop od))) (oc (split-ctps regs ctps)) (rc (pop oc)) ;FIXME check-type must refer to top regular variable binding, but must be beneath argument number logic (oc (append (when s rc) (car oc))) (rc (mapcan (lambda (x) (when (eq (car x) 'check-type) `((declare (,@(when s `(hint)) ,(caddr x) ,(cadr x)))))) rc)) (rc (cons `(declare (optimize (safety ,dl))) rc)) (narg (when opts +nargs+));FIXME (cdr opts) (nr (length regs)) (regs (or regs (when narg (list +first+)))) (m (min 63 (mll ll))) (args `(,@(remove-ignore-decls (car od)) ,@oc ,@args)) (opts (if narg (cons narg opts) opts)) (args (if narg (cons `(declare ((integer ,(- m) ,m) ,narg)) args) args)) (rc (if narg (cons `(declare (hint (integer ,(- m) ,m) ,narg)) rc) rc)) (opts `(,+fun+ ,+mv+ ,@opts)) (args `((declare (ignorable ,+fun+ ,+mv+) (fixnum ,+mv+)) ,@args)) (vals `((fun-fun) (fun-valp) ,@(when narg `((vfun-nargs)))));FIXME (bl (list (blla opts vals nil args narg nr (when (eq (car regs) +first+) +first+))))) `(,nm ,regs ,@(when doc `(,doc)) ,@rd ,@rc ,@bl))))) (defun c1va-pop (args) (declare (ignore args)) `(location ,(make-info :type #tt :flags (iflags side-effects)) (inline 0 "va_arg(ap,object)" nil))) (setf (get 'va-pop 'c1) 'c1va-pop) (defun c1vfun-nargs (args) (declare (ignore args)) (list 'location (make-info :type #t(integer -63 63)) (list 'inline-fixnum 0 "fcall.argd" nil))) (setf (get 'vfun-nargs 'c1) 'c1vfun-nargs) (defun c1fun-valp (args) (declare (ignore args)) (list 'location (make-info :type #tfixnum) (list 'inline-fixnum 0 "fcall.valp" nil))) (setf (get 'fun-valp 'c1) 'c1fun-valp) (defun c1fun-fun (args) (declare (ignore args)) (list 'fun-fun (make-info :type #tt))) (defun c2fun-fun nil (unwind-exit (list 'fun-fun) nil 'single-value)) (defun wt-fun-fun nil (wt "fcall.fun;") (wt-nl "#undef base0") (wt-nl "#define base0 ") (wt *value-to-go*) (wt "->fun.fun_env") (wt-nl) (setq *level* 1)) (setf (get 'fun-fun 'c1) 'c1fun-fun) (setf (get 'fun-fun 'c2) 'c2fun-fun) (setf (get 'fun-fun 'wt-loc) 'wt-fun-fun) (defmacro side-effects nil nil) (defun c1side-effects (args) (declare (ignore args)) (mapc (lambda (x &aux (b (get-vbind x))) (when b (unless (eq 'var (car (binding-form b))) (setf (binding-repeatable b) nil)))) *vars*) (list 'side-effects (make-info :flags (iflags side-effects)))) (defun c2side-effects nil nil) (setf (get 'side-effects 'c1) 'c1side-effects) (setf (get 'side-effects 'c2) 'c2side-effects) (defun c1bind-reg-clv (args) (declare (ignore args)) (list 'bind-reg-clv (make-info :type #tt :flags (iflags side-effects)))) (defun c2bind-reg-clv (&aux x var) (do nil ((not (setq x (pop *reg-clv*) var (cadr x)))) (wt-nl) (setf (var-ref var) (vs-push));FIXME ? clb and ccb vars just appear in info-ref-ccb, only need push clb (wt-vs (var-ref var)) (wt "= " `(gen-loc :object (cvar ,(var-loc var))) ";") (when (var-ref-ccb var) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))))) ;; (defun c2bind-reg-clv (&aux x clb var) ;; (do nil ;; ((not (setq x (pop *reg-clv*) clb (pop x) var (car x))));FIXME ? eliminate clb var here ;; (wt-nl) ;; (setf (var-ref var) (vs-push));FIXME ? clb and ccb vars just appear in info-ref-ccb, only need push clb ;; (wt-vs (var-ref var)) (wt "= " (list 'cvar (var-loc var)) ";") ;; (when (var-ref-ccb var) ;; (clink (var-ref var)) ;; (setf (var-ref-ccb var) (ccb-vs-push))))) ;; (defun c2bind-reg-clv (&aux x clb var) ;; (do nil ;; ((not (setq x (pop *reg-clv*) clb (pop x) var (car x)))) ;; (wt-nl) ;; (cond (clb ;; (setf (var-ref var) (vs-push));FIXME ? ;; (wt-vs (var-ref var)) (wt "= " (list 'cvar (var-loc var)) ";")) ;; ((setf (var-ref var) (list 'cvar (var-loc var))))) ;; (when (var-ref-ccb var) ;; (clink (var-ref var)) ;; (setf (var-ref-ccb var) (ccb-vs-push))))) ;; (defun c2bind-reg-clv (&aux var) ;; (do nil ;; ((not (setq var (pop *reg-clv*)))) ;; (wt-nl) ;; (cond ((and (var-ref-ccb var) (not (eq 'clb (var-loc var)))) ;; (setf (var-ref var) (list 'cvar (var-loc var))) ;; (clink (var-ref var)) ;; (setf (var-ref-ccb var) (ccb-vs-push))) ;; ((setf (var-ref var) (vs-push));FIXME ;; (wt-vs (var-ref var)) (wt "= " (list 'cvar (var-loc var)) ";"))))) (setf (get 'bind-reg-clv 'c1) 'c1bind-reg-clv) (setf (get 'bind-reg-clv 'c2) 'c2bind-reg-clv) (defun c1ub (args) (let* ((key (pop args)) (info (make-info :type #topaque)) (c1?form (car args)) (narg (cond ((when (consp c1?form) (info-p (cadr c1?form)));FIXME is this dangerous? (add-info info (cadr c1?form)) c1?form) ((c1arg c1?form info))))) (list* 'ub info key (list narg)))) (setf (get 'ub 'c1) 'c1ub) (setf (get 'unbox 'c1) 'c1ub) (defvar *ars* (let ((i -1)) (mapl (lambda (x) (setf (car x) (concatenate 'string "#" (write-to-string (incf i))))) (make-list call-arguments-limit)))) (defvar *arps* (mapcar (lambda (x) (compile-regexp (concatenate 'string "(" x ")([^0-9]|$)"))) *ars*)) (defun arg-n (n) (the string (nth n *ars*)));FIXME assert (defun arg-pat (n) (nth n *arps*)) (defun argsub (str pat new) (declare (string str new)) (let ((x (string-match pat str))) (if (eql x -1) str (concatenate 'string (subseq str 0 (match-beginning 1)) new (argsub (subseq str (match-end 1)) pat new))))) (defun lit-string-merge (s ns i n j &aux (ns (lit-string-move ns 0 (1+ j) i))) (if (< j 0) (lit-string-move (argsub s (arg-pat i) ns) (1+ i) (1+ n) j) (argsub (lit-string-move s (1+ i) (1+ n) j) (arg-pat i) ns))) (defun lit-string-move (s i n j) (if (> n i) (cond ((eql j 0) s) ((< j 0) (lit-string-move (argsub s (arg-pat i) (arg-n (+ i j))) (1+ i) n j)) ((argsub (lit-string-move s (1+ i) n j) (arg-pat i) (arg-n (+ i j))))) s)) (defun ml (x &optional key) (case (car x) (ub (ml (car (last x)) (third x))) (location (let* ((fvt (or (car (assoc (info-type (cadr x)) +value-types+ :test 'type<=)) t)) (str (fm-to-string (caddr x)))) (when str (c1lit (list key (loc-str str key fvt)))))) (lit (let* ((fvt (get (third x) 'cmp-lisp-type))) (list* (pop x) (pop x) (pop x) (loc-str (pop x) key fvt) x))))) (defun fm-to-string (form) (typecase form ; (null "Cnil") ; (true "Ct") ((cons (eql vv) t) (fm-to-string (cadr form))) ((cons (member char-value fixnum-value character-value) t) (fm-to-string (caddr form))) ((eql most-negative-fixnum) #.(string-concatenate "(" (write-to-string (1+ most-negative-fixnum)) "- 1)")) (integer (format nil "~a" form)); string character (float (format nil "~10,,,,,,'eG" form)) ((complex float) (string-concatenate "(" (fm-to-string (realpart form)) " + I * " (fm-to-string (imagpart form)) ")")))) (defun loc-str (x key ft &aux p (tt (get key 'cmp-lisp-type))(cast (strcat "(" key ")"))(pp (find #\* cast))) (string-concatenate (cond ((member key '(:cnum :creal)) "") ((eq ft tt) "") ((equal ft t) (if *compiler-new-safety* (let ((v (member key '(:char :int :fixnum)))) (if v (si::string-concatenate (setq p "object_to_") (strcat key)) (si::string-concatenate cast (setq p "object_to_") (if pp "pointer" "dcomplex")))) (or (setq p (cdr (assoc tt +to-c-var-alist+ :test 'type<=))) cast))) ((eq tt t) (or (setq p (cdr (assoc ft +wt-c-var-alist+))) "")) ((and (type>= #tint tt) (type>= tt ft)) "") ((and (type>= #tcnum tt) (type>= #t(or character cnum) ft)) cast) ((baboon) "")) (if p "(" "") x (if p ")" ""))) (defun c1lit (args &optional c1args &aux (lev (this-safety-level)) (key (pop args))(tp (get key 'cmp-lisp-type :opaque))) (when (eq tp :opaque) (baboon)) (let* ((as *ars*) (inl (apply 'concatenate 'string (mapcar (lambda (x) (if (stringp x) x (if as (pop as) (baboon)))) args))) (info (make-info :type tp));FIXME boolean (nargs (mapcan (lambda (x) (unless (stringp x) (list (c1arg (cons 'ub x) info)))) (or c1args args))) (oargs nargs) (lna (length nargs))(i 0) (nargs (mapcan (lambda (x &aux (f (ml x))(ff (fifth f))(lff (length ff))) (cond (f (setq inl (lit-string-merge inl (fourth f) i lna (1- lff))) (setq lev (min lev 1));FIXME? ; (when (> lev (seventh f)) (setq lev (seventh f))); (break) (incf i lff)(copy-list ff));FIXME? ((incf i)(list x)))) nargs)) (form (list 'lit info key inl nargs nil lev oargs (make-vs info)))) (when (find #\= inl) (c1side-effects nil) (setf (info-flags info) (logior (iflags side-effects) (info-flags info)))) (setf (sixth form) (new-bind form)) form)) (defun c2lit (key inl args bind safety &rest r &aux (oargs (pop r)) (stores (car r)) (tp (get key 'cmp-lisp-type :opaque))) (declare (dynamic-extent r)) (let* ((*inline-blocks* 0) (*restore-avma* *restore-avma*) (*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-new-safety* *compiler-new-safety*) (*compiler-push-events* *compiler-push-events*)) (local-compile-decls `((safety ,safety))) (unwind-exit (lit-loc key inl args bind safety oargs stores) nil (cons 'values (if (equal tp #t(returns-exactly)) 0 1))) (close-inline-blocks))) ;; (defun c2lit (tp inl args) ;; (let* ((*inline-blocks* 0) ;; (*restore-avma* *restore-avma*)) ;; (unwind-exit (lit-loc tp inl args) nil (cons 'values (if (eq tp #t(returns-exactly)) 0 1))) ;; (close-inline-blocks))) ;; (defun c2lit (tp inl args) ;; (let* ((sig (list (mapcar (lambda (x) (info-type (cadr x))) args) tp)) ;; (*inline-blocks* 0) ;; (*restore-avma* *restore-avma*)) ;; (unwind-exit (get-inline-loc (list (car sig) (cadr sig) (flags rfa) inl) args) ;; nil (cons 'values (if (eq (cadr sig) #t(returns-exactly)) 0 1))) ;; (close-inline-blocks))) (setf (get 'lit 'c1) 'c1lit) (setf (get 'lit 'c2) 'c2lit) (defun ttl-ll (ll) (let ((a (member '&aux ll))) (ldiff ll a))) (defun do-l1-fun (name src e b &aux (wns *warning-note-stack*) (*recursion-detected* (cons (list name) *recursion-detected*))) (let* ((l (c1lambda-expr src)) (osig (car e)) (sig (lam-e-to-sig l)) (rd (cdar *recursion-detected*)) (rep (when rd (not (type<= (cadr sig) (cadr osig))))) (sig (if (and osig rep) (list (car sig) (bbump-tp (type-or1 (cadr osig) (cadr sig)))) sig))) (setf (car e) sig); (cadr e) *callees*) (cond (rep (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig) (setq *warning-note-stack* wns);FIXME try to use with-restore-vars (do-l1-fun name src e b)) (l)))) (defun get-clv (l &aux (i (cadr l))) (mapcan (lambda (v) (when (var-p v) (list (list v nil)))) (append (info-ref-ccb i) (info-ref-clb i)))) (defvar *top-tag* nil) (defun top-level-src-p nil (not (member *top-tag* *lexical-env-mask*))) (defun do-fun (name src e vis b) (let* ((*vars* (if b (cons b *vars*) *vars*)) (*funs* (if b (cons b *funs*) *funs*)) (*blocks* (if b (cons b *blocks*) *blocks*)) (*tags* (if b (cons b *tags*) *tags*)) (*top-tag* (make-tag)) (*tags* (cons *top-tag* *tags*)) (tag (make-ttl-tag)) (*prev-sri* (append *src-inline-recursion* *prev-sri*)) (*src-inline-recursion* (when vis (list (make-tagged-sir (list (sir-name name)) tag (ttl-ll (cadr src)))))) (*c1exit* (list (make-c1exit name))) (*current-form* `(defun ,name)) (l (do-l1-fun name (cdr (new-defun-args src tag)) e b)) (clv (get-clv l))) (setf (second e) (mapcan (lambda (x) (when (symbolp x) (list (cons x (get-sig x))))) (info-ref (cadr l))) (third e) (list src clv name) (fourth e) *function-filename* (fifth e) (logior (if (iflag-p (info-flags (cadr l)) side-effects) 0 2) (if (= (length clv) 0) 1 0)) (sixth e) name) (when *sig-discovery* (when (symbol-package name) (unless (eq name 'lambda) (push (cons name (apply 'si::make-function-plist e)) si::*sig-discovery-props*)))) l)) ;; top-level lex-ref walker ;; (defvar *unused* nil) ;; (defvar *lsyms* nil) ;; (defun decl-ref (x decls) ;; (dolist (d decls (specialp x)) ;; (dolist (c (cdr d)) ;; (case (car c) ;; ((ignore ignorable special) ;; (when (member x (cdr c) :test 'equal) ;; (return-from decl-ref t))))))) ;; (defun unused-bindings (form) ;; (if (atom form) ;; (let ((x (car (member-if (lambda (x) (when (car x) (eq (caar x) form))) *lsyms*)))) (when x (setf (cdar x) t))) ;; (case (car form) ;; ((let let* flet labels macrolet) ;; (multiple-value-bind (doc decls) (parse-body-header (cddr form)) ;; (declare (ignore doc)) ;; (let* ((c (mapcar (lambda (x) (if (atom x) (list x) x)) (cadr form))) ;; (b (mapcar (lambda (x) ;; (case (car form) ;; ((let let*) (list (cons (car x) (decl-ref (car x) decls)) nil)) ;; ((flet labels) (list nil (cons (car x) (decl-ref `(function ,(car x)) decls)))) ;; (macrolet (list nil x)))) ;; c)) ;; (d (cons *lsyms* (maplist 'identity b))) ;; (b (nreconc b *lsyms*))) ;; (mapc (lambda (x &aux (*lsyms* (case (car form) (let* (pop d))(labels b)(otherwise *lsyms*)))) ;; (unused-bindings (case (car form) ;; ((let let*) (cadr x)) ;; (otherwise (cons 'lambda (cdr x)))))) ;; c) ;; (let ((*lsyms* b)) (mapc 'unused-bindings (cddr form))) ;; (mapc (lambda (x) (unless (cdr (or (car x) (cadr x))) (push x *unused*))) ;; (ldiff b *lsyms*))))) ;; ((quote go declare)) ;; ((block return-from eval-when) (mapc 'unused-bindings (cddr form))) ;; (tagbody (mapc (lambda (x) (typecase x ((or integer symbol))(otherwise (unused-bindings x)))) (cdr form))) ;; (the (unused-bindings (caddr form))) ;; (setq (do ((form (cddr form) (cddr form)))((not form))(unused-bindings (car form)))) ;; (lambda (unused-bindings (blla (cadr form) nil '(foo) (cddr form)))) ;; (function (let ((x (cadr form))) ;; (etypecase x ;; ((or symbol (cons (member setf) (cons symbol null))) ;; (let ((x (car (member x *lsyms* :key 'caadr :test 'equal)))) ;; (when x (unless (cdadr x) (setf (cdadr x) t))))) ;; ((cons (member lambda) t) (unused-bindings x))))) ;; (otherwise (let* ((form (if (symbolp (car form)) form (cons 'funcall form)));? ;; (x (car (member (car form) *lsyms* :key 'caadr))) ;; (fd (or (let ((c (cadr x))) (when (consp (cdr c)) (eval (defmacro-lambda (pop c) (pop c) c)))) ;; (unless x (macro-function (car form))))) ;; (f1 (if fd (funcall fd form nil) form))) ;; (cond ((eq form f1) (when x (setf (cdadr x) t)) (mapc 'unused-bindings (cdr form))) ;; ((unused-bindings f1)))))))) ;; (defun get-unused-bindings (form &aux *unused*) ;; (unused-bindings form) ;; (mapc (lambda (x) ;; (cmpwarn "The ~a ~s is not used.~%" (if (car x) "variable" "function") (car (or (car x) (cadr x))))) ;; *unused*) ;; *unused*) ;; The entire purpose of this function is to detect unused variables in eliminated code ;; It could be expanded to support functions, blocks, and tags ;; It could be eliminated if the unused variable warning is eliminated. (defun lex-refs (form) (typecase form (null) (symbol (let ((x (car (member form *vars* :key (lambda (x) (when (var-p x) (var-name x))))))) (when x (set-var-reffed x)))) (cons (case (car form) ((let let*) (let* ((b (mapcar (lambda (x) (make-var :name (if (consp x) (car x) x))) (cadr form))) (d (cons *vars* (maplist 'identity b))) (b (nreconc b *vars*))) (mapc (lambda (x &aux (*vars* (if (eq 'let* (car form)) (pop d) *vars*))) (when (consp x) (lex-refs (cadr x)))) (cadr form)) (let ((*vars* b)) (mapc 'lex-refs (cddr form))))) ((flet labels macrolet) (let* ((m (eq (car form) 'macrolet)) (b (mapcar (lambda (x) (make-fun :name (car x) :src (unless m (si::block-lambda (cadr x) (car x) (cddr x))) :fn (if m (eval (defmacro-lambda (pop x) (pop x) x)) (lambda (&rest r) (declare (ignore r)) nil)))) (cadr form))) (b (nreconc b *funs*))) (mapc (lambda (x &aux (*funs* (if (eq 'labels (car form)) b *funs*))) (lex-refs (cons 'lambda (cdr x)))) (cadr form)) (let ((*funs* b)) (mapc 'lex-refs (cddr form))))) ((quote go declare)) ((block return-from eval-when) (mapc 'lex-refs (cddr form))) (tagbody (mapc (lambda (x) (typecase x ((or integer symbol))(otherwise (lex-refs x)))) (cdr form))) (the (lex-refs (caddr form))) (setq (do ((form (cddr form) (cddr form)))((not form))(lex-refs (car form)))) (lambda (lex-refs (blla (cadr form) nil '(foo) (cddr form)))) (function (let ((x (cadr form))) (typecase x ((cons (member lambda) t) (lex-refs x))))) (otherwise (let* ((form (if (symbolp (car form)) form (cons 'funcall form)));? (fd (cmp-macro-function (car form))) (f1 (if fd (funcall fd form nil) form))) (if (eq form f1) (mapc 'lex-refs (cdr form)) (lex-refs f1)))))))) (defun eliminate-src (src) (when *top-level-src-p* (lex-refs src))) (defun t1defun (args &aux *warning-note-stack* *top-level-src*) (when (or (endp args) (endp (cdr args))) (too-few-args 'defun 2 (length args))) (maybe-eval nil (cons 'defun args)) (let* ((fname (car args)) (fname (or (function-symbol fname) (cmperr "The function name ~s is not valid." fname))) (cfun (next-cfun)) (oal (get-arg-types fname)) (ort (get-return-type fname)) (osig (export-sig (list oal ort))) (e (or (gethash fname *sigs*) (setf (gethash fname *sigs*) (make-list 6)))) (lambda-expr (do-fun fname args e t nil)) (sig (car e)) (osig (if (equal '((*) *) osig) sig osig));FIXME (doc (cadddr lambda-expr))) (keyed-cmpnote (list 'return-type fname) "~s return type ~s" fname (c1retnote lambda-expr)) (unless (or (equal osig sig) (eq fname 'cmp-anon));FIXME (cmpstyle-warn "signature change on function ~s,~% ~s -> ~s~%" fname (si::readable-sig osig) (si::readable-sig sig)) (setq *new-sigs-in-file* (block nil (maphash (lambda (x y) (unless (eq x fname) (when (member fname (second y) :key 'car) (return (list x fname osig sig))))) *sigs*) nil))) (push (let* ((at (car sig)) (al (mapcar (lambda (x) (link-rt x nil)) at)) (rt (link-rt (cadr sig) nil))) (list fname al rt (if (single-type-p rt) (flags set ans) (flags set ans sets-vs-top)) (make-inline-string cfun at fname))) *inline-functions*) (push (list 'defun fname cfun lambda-expr doc nil nil) *top-level-forms*) (push (cons fname cfun) *global-funs*) (output-warning-note-stack))) (defun make-inline-string (cfun args fname) (format nil "~d(~a)" (c-function-name "LI" cfun fname) (make-inline-arg-str (list args (get-return-type fname))))) (defun cs-push (&optional type local) (let ((tem (next-cvar))) (let ((type (if (or (not type) (eq type 'object)) t type))) (when (or (not local) (not (eq type t))) (push (if local (cons tem type) (cons type 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))) (let ((x (promoted-c-type x))) (let ((x (position x +c-global-arg-types+ :test 'type<=))) (if x (1+ x) 0)))) (defun new-proclaimed-argd (args return) (do* ((type (f-type return) (f-type (pop args))) (i 0 (+ 2 i)) (ans type (logior ans (ash type i)))) ((or (>= i 32) (null args)) (the (unsigned-byte 32) ans)))) (defun type-f (x) (declare (fixnum x)) (if (zerop x) t (nth (1- x) +c-global-arg-types+))) (defun argsizes (args return &optional max pushed) (let* ((x (vald return)) (vv (or (> x 0) (when (zerop x) (not (single-type-p return))))) (x (if vv x (- x))) (la (length args)) (varg (eq (car (last args)) '*)) (la (if varg (1- la) la))) (let ((r (logior la (ash (or max la) 6) (ash x 12) (ash (if vv 1 0) 17) (ash (if varg 1 0) 18) (ash (if pushed 1 0) 19)))) (when (< r 0) (print r) (break)) r))) (defun vald (tp) (cond ((single-type-p tp) 0) ((type>= #t(values t) tp) 0) ((eq tp '*) (- multiple-values-limit 2)) ((> (length tp) multiple-values-limit) (baboon));FIXME ((eq (car tp) 'returns-exactly) (- 2 (length tp))) ((- (length tp) 2)))) (defun export-call-struct (l) `(apply 'make-function-plist ',(pop l) ',(pop l) ',(apply 'compress-fle (pop l)) ',l)) (defun volatile (info) (if (iflag-p (info-flags info) volatile) "VOL " "")) (defun set-volatile (info) (setf (info-flags info) (logior (iflags volatile) (info-flags info)))) (defun register (var) (cond ((and (equal *volatile* "") (>= (the fixnum (var-register var)) (the fixnum *register-min*))) "register ") (t ""))) (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)) 63) (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*))) ;FIXME obsolete ;; (defun collect-objects (le) ;; (cond ((atom le) nil) ;; ((and (eq (car le) 'location) (consp (caddr le)) (eq (caaddr le) 'vv)) ;; (list (or (car (member (cadr (caddr le)) *top-level-forms* :key 'cadr)) ;; (aref (data-vector) (cadr (caddr le)))))) ;; ((append (collect-objects (car le)) (collect-objects (cdr le)))))) (defun xa (l) (let ((v (is-narg-le l))) (if v (or (cadr (real-bnds (var-type v))) (baboon)) (length (caaddr l))))) (defun global-type-bump (tp) (let* ((mv (cmpt tp)) (tpp (nil-to-t (if mv (coerce-to-one-value tp) tp))) (tppn (car (member tpp `(,@+c-global-arg-types+ ,#tt ,#t*) :test 'type<=))));FIXME (if mv `(,(car tp) ,@(when (cdr tp) `(,tppn)) ,@(cddr tp)) tppn))) (defun t2defun (fname cfun lambda-expr doc sp &rest r &aux (macro-p (car r))) (declare (dynamic-extent r)(ignore cfun lambda-expr doc sp macro-p)) (cond ((get fname 'no-global-entry)(return-from t2defun nil))) (when (< *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 `(putprop ',fname ,doc 'function-documentation))) (let* ((e (gethash fname *sigs*)) (f (when (fast-link-proclaimed-type-p fname) (assert (assoc fname *inline-functions*)) t)) (sig (car e)) (at (pop sig)) (at (if f at (mapcar 'global-type-bump at))) (rt (car sig)) (rt (if f rt (global-type-bump rt))) (finit `(init-function ,(export-call-struct (gethash fname *sigs*)) ,(add-address (c-function-name "LI" cfun fname)) nil nil -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lambda-expr))))) (add-init `(fset ',fname ,(if macro-p `(cons 'macro ,finit) finit))))) (defun t3defun (fname cfun lambda-expr doc sp &rest r &aux (macro-p (car r)) inline-info ; (macro-p (equal `(mflag ,fname) (cadr (member *current-form* *top-level-forms*)))) (*current-form* (list 'defun fname)) (*volatile* (volatile (second lambda-expr)))) (declare (dynamic-extent r)) (let ((*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*) (*debug* *debug*)) (when (eq (car (caddr (cddr lambda-expr))) 'decl-body) (local-compile-decls (caddr (caddr (cddr lambda-expr))))) (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. ;; (push (list fname cfun (cadr inline-info) (caddr inline-info)) ;; *global-entries*)) ;;; Local entry (analyze-regs (cadr lambda-expr) 0) (mapc (lambda (x) (setf (var-type x) (global-type-bump (var-type x)))) (caaddr lambda-expr)) (setf (info-type (cadr (fifth lambda-expr))) (global-type-bump (info-type (cadr (fifth lambda-expr))))) (setf (caddr inline-info) (global-type-bump (cadr (lam-e-to-sig lambda-expr)))) (t3defun-aux 't3defun-local-entry (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object) fname cfun lambda-expr sp inline-info)) ((baboon))) (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))) (defvar *mv-var* nil) (defun t3defun-local-entry (fname cfun lambda-expr sp inline-info &aux specials *reg-clv* (requireds (caaddr lambda-expr)) nargs) (do ((vl requireds (cdr vl)) (types (cadr inline-info) (cdr types))) ((endp vl)) (cond ((eq (var-kind (car vl)) 'special) (push (cons (car vl) (var-loc (car vl))) specials)) ((var-cb (car vl)) (push (list (eq 'clb (var-loc (car vl))) (car vl)) *reg-clv*)) ; ((var-cb (car vl)) (push (car vl) *reg-clv*)) ((setf (var-kind (car vl)) (or (car (member (promoted-c-type (var-type (car vl))) +c-local-arg-types+)) 'object)))) (setf (var-loc (car vl)) (cs-push (var-type (car vl)) t))) (when (is-narg-le lambda-expr) (setq nargs (car (last requireds))) (setf (var-register nargs) 0)) (let* ((s (function-string fname)) (g (when (stringp cfun) (char= #\G (char cfun 0))))) (wt-comment (strcat (if g "global" "local") " entry for function ") s)) (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) nil nargs) (wt-h ";") (let* ((cm *reservation-cmacro*)) ;; (tri (tail-recursion-info fname nil lambda-expr)) ;; (*unwind-exit* (if tri (cons 'tail-recursion-mark *unwind-exit*) *unwind-exit*))) (wt-nl1 "{ ") (wt " VMB" cm " VMS" cm " VMV" cm) (when nargs (wt-nl "va_list ap;")(wt-nl "va_start(ap,V" (var-loc nargs) ");")) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) ; (dolist (v clv) (setf (var-ref v) (list 'cvar (var-loc v))) (c2bind v)) (dolist (v specials) (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (cdr v)) "," `(gen-loc :object (cvar ,(var-loc (car v)))) ");") (push 'bds-bind *unwind-exit*) (setf (var-kind (car v)) 'SPECIAL) (setf (var-loc (car v)) (cdr v))) (let ((*mv-var* (mv-var lambda-expr))) (c2expr (caddr (cddr lambda-expr))) (wt-V*-macros cm (caddr inline-info))) ;;; Make sure to return object if necessary ; (if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) (when nargs (wt-nl "va_end(ap);")) (wt-nl1 "}"))) (defvar *vararg-use-vs* nil) (defun set-up-var-cvs (var) (setf (var-ref var) (if *vararg-use-vs* (vs-push) (cvs-push)))) ;;Macros for conditionally writing vs_base ..preamble, and for setting ;;up the return. (defun wt-V*-macros (cm return-type) (push (cons cm *max-vs*) *reservations*) (let ((vstb (if (or *mv-var* (> *max-vs* 0) *base-used*) (concatenate 'string " register object * " *volatile* " base=vs_top;") "")) (bdsb (if *bds-used* (concatenate 'string " bds_ptr " *volatile* " old_bds_top=bds_top;") "")) (frsb (if *frame-used* (concatenate 'string " frame_ptr " *volatile* " old_frs_top=frs_top;") ""))) (wt-h "#define VMB" cm vstb bdsb frsb)) (wt-cvars) (cond (*sup-used* (wt-h "#define VMS" cm " register object *" *volatile* "sup=vs_top+" *max-vs* ";vs_top=sup;")) ((zerop *max-vs*) (wt-h "#define VMS" cm)) ((wt-h "#define VMS" cm " vs_top += " *max-vs* ";"))) (cond ((zerop *max-vs*) (wt-h "#define VMV" cm)) (*safe-compile* (wt-h "#define VMV" cm " vs_reserve(" *max-vs* ");")) ((wt-h "#define VMV" cm " vs_check;"))) (let ((vstu (cond (*mv-var* (let ((loc (write-to-string (var-loc *mv-var*)))) (concatenate 'string " if (V" loc ") {if ((b_)>=-1) vs_top=(object *)V" loc "+(b_);} else vs_top=base;"))) ((or (> *max-vs* 0) *base-used*) " vs_top=base;") (""))) (bdsu (if *bds-used* " for (;bds_top>old_bds_top;) bds_unwind1;" "")) (frsu (if *frame-used* " for (;frs_top>old_frs_top;) frs_pop();" ""))) (wt-h "#define VMRV" cm "(a_,b_)" vstu bdsu frsu " return((" (declaration-type (rep-type return-type)) ")a_);") (wt-h "#define VMR" cm "(a_) VMRV" cm "(a_,0);"))) (defun wt-requireds (requireds arg-types &optional first narg) (declare (ignore arg-types)) (flet ((wt (x) (wt x) (let ((*compiler-output1* *compiler-output2*)) (wt x)))) (dolist (v requireds (wt (if narg ",...)" ")"))) (setq narg (or narg (is-narg-var v))) (let* ((gt (global-type-bump (var-type v))) (cvar (cs-push gt t))) (when first (wt ",")) (setq first t) (setf (var-loc v) cvar) (wt *volatile*) (wt (register v)) (wt (rep-type gt)) (wt "V") (wt cvar))))) ;;Write the required args as c arguments, and declarations for the arguments. (defun wt-requireds-old (requireds arg-types) (do ((vl requireds (cdr vl))) ((endp vl)) (let ((cvar (cs-push (var-type (car vl)) t))) (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 ";")) (if prev-type (wt ";")) (wt *volatile* (register (car vl)) (rep-type (car types)));(var-kind (car vl))));(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) ) )) )))) (defun if1 (f) (when (info-type f) (flet ((tbp (l) (member-if (lambda (x) (or (tag-p x) (blk-p x))) l))) (not (or (info-ch f) (tbp (info-ref f)) (tbp (info-ref-ccb f)) (tbp (info-ref-clb f)) (/= 0 (logand (info-flags f) (iflags side-effects compiler)))))))) (defun ignorable-form (f) (case (car f) (function t) ((cadd-dladdress infer-tp) nil) (otherwise (if1 (cadr f))))) ;;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) +c-local-var-types+) (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 (seqind tem real-min this-min want have)) (tagbody START (do-referred (v info) (setq tem (var-register v)) (when (>= tem real-min) (incf have) (when (< tem this-min) (setq this-min tem)) (when (> have want) (go NEXT)))) (when (< have want) (decf real-min)) (do-referred (v info) (when (< (var-register v) real-min) (setf (var-register v) 0))) (return-from analyze-regs1 real-min) NEXT (setq have 0 real-min (1+ this-min) this-min 1000000) (go START)))) (defun find-block-by-name (form name) (cond ((atom form) nil) ((and (eq (car form) 'block) (blk-p (caddr form)) (eq (blk-name (caddr form)) name)) form) ((or (find-block-by-name (car form) name) (find-block-by-name (cdr form) name))))) (defun find-ttl (form name) (cond ((atom form) nil) ((and (consp (car form)) (eq (caar form) 'bind-reg-clv)) (cadr form)) ((or (find-ttl (car form) name) (find-ttl (cdr form) name))))) (defun ttl-to-top (form name) (cond ((atom form) form) ((not (eq (car form) 'lambda)) form) ((list (car form) (cadr form) (caddr form) (cadddr form) (find-ttl (fifth form) name))))) ;; (defun rcl (form fun vars name) ;; (cond ((var-p form) ;; ; (setf form (copy-var form)) ;; (when (eq (var-kind form) 'replaced) ;; (setf (var-kind form) (if (var-aliases form) (var-kind (car (var-aliases form))) 'object)))) ;; ((atom form)) ;; ((and (eq (car form) 'block) (blk-p (caddr form)) (eq (blk-name (caddr form)) name)) ;; (setf (cadddr form) (list 'call-local (fun-info fun) (list fun nil) vars))) ;; ((and (consp (car form)) (eq (caar form) 'bind-reg-clv)) ;; (setf (cadr form) (list 'call-local (fun-info fun) (list fun nil) vars))) ;; ((eq (car form) 'lambda) ;; (mapc (lambda (x) (setf (var-type x) (global-type-bump (var-type x)))) (caaddr form)) ;; (let* ((x (car (last form))) ;; (y (cadr x)) ;; (tp (info-type y))) ;; (setf (info-type y) (global-type-bump tp)) ;; (mapl (lambda (x) (mapl (lambda (y) (when (var-p (car y)) (setf (car y) (copy-var (car y))))) (car x))) (caddr form)) ;; (rcl x fun vars name))) ;; (t (rcl (car form) fun vars name) (rcl (cdr form) fun vars name)))) (defconstant +wt-c-rep-alist+ `((,#tnil ."object ") (,#tchar ."int8_t ") (,#tfixnum ."fixnum ") ; (,#tinteger ."GEN ") ; (,#tcharacter ."unsigned char ") (,#tlong-float ."double ") (,#tshort-float ."float ") (,#tfcomplex ."fcomplex ") (,#tdcomplex ."dcomplex ") (object . "object "))) ;; (defconstant +wt-c-rep-alist+ `((,#tchar ."int8_t ") ;; (,#tfixnum ."fixnum ") ;; ; (,#tinteger ."GEN ") ;; ; (,#tcharacter ."unsigned char ") ;; (,#tlong-float ."double ") ;; (,#tshort-float ."float ") ;; (,#tfcomplex ."fcomplex ") ;; (,#tdcomplex ."dcomplex ") ;; (object . "object "))) (defun rep-type (type &aux (type (if (eq type 'object) t type))) (let ((z (promoted-c-type type))) (or (cdr (assoc z +wt-c-rep-alist+)) "object "))) ;; (defun rep-type (type) ;; (let ((z (promoted-c-type type))) ;; (or (cdr (assoc z +wt-c-rep-alist+)) "object "))) ;; (defun t1defmacro (args &aux (w args) (n (pop args)) (ll (pop args))) ;; (t1expr `(defun ,n ,@(cdr (si::defmacro-lambda n ll args)))) ;; (maybe-eval (not (macro-function n)) (cons 'defmacro w));FIXME? ;; (push `(mflag ,n) *top-level-forms*)) (defun t1macrolet (args &aux (*funs* *funs*)) (when (endp args) (too-few-args 'macrolet 1 0)) (push-macrolet-env (car args)) (mapc 't1expr (cdr args))) (defun t1defmacro (args &aux (w args)(n (pop args)) (macp (when (listp n) (eq 'macro (car n))))(n (if macp (cdr n) n))) (t1expr `(defun ,n ,@(if macp args (cdr (si::defmacro-lambda n (pop args) args))))) (setf (car (last (car *top-level-forms*))) t) (maybe-eval (not (macro-function n)) (cons 'defmacro w));FIXME? ; (push `(mflag ,n) *top-level-forms*) ) (defun t3mflag (n) (declare (ignore n)) nil) ;; (defun t3mflag (n) ;; (add-init `(c-set-symbol-mflag ',n 1))) ;; (define-compiler-macro fset (&whole form &rest args) ;; (let* ((info (make-info)) ;; (nargs (with-restore-vars (c1args args info))) ;; (ff (cadr nargs))) ;; (if (and (car (atomic-tp (info-type (cadar nargs)))) (eq (car ff) 'function) (fun-p (caaddr ff)));FIXME ;; (let* ((fun (caaddr ff)) ;; (cl (fun-call fun))) ;; (when *sig-discovery* (apply 'si::add-hash (cmp-eval (car args)) (export-call cl))) ;; (list* 'fset1 info (car args) (cdr nargs))) form))) ;; (defun c1fset1 (args) (cons 'fset1 args)) ;; (defun c2fset1 (sym ff) ;; (let* ((fl (caddr ff)) ;; (fun (car fl)) ;; (cl (fun-call fun)) ;; (at (caar cl)) ;; (rt (cadar cl))) ;; (c2expr ff) ;; (add-init `(si::init-function ;; ,sym ;; ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa (cadr fl))))) ;; (push `(si::add-hash ,sym ,@(mapcar (lambda (x) `',x) (export-call cl))) *add-hash-calls*))) ;; (setf (get 'fset1 'c1) 'c1fset1) ;; (setf (get 'fset1 'c2) 'c2fset1) ;; (defun c1fset (args) ;; (let* ((info (make-info)) ;; (nargs (c1args (cdr args) info))) ;; (list* 'fset info (car args) nargs))) ;; (defun c2fset (sym f &aux (ff (if (eq 'function (car f)) (caddr f) f))) ;; (let* ((fun (car ff)) ;; (lam (cadr ff)) ;; (cl (fun-call fun)) ;; (at (caar cl)) ;; (rt (cadar cl))) ;; (c2expr f) ;; (add-init `(si::init-function ;; ,sym ;; ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun))) ;; nil nil -1 ,(new-proclaimed-argd at rt) ;; ,(argsizes at rt (xa lam)))))) (defvar *compiling-ordinary* nil) (defun compile-ordinary-p (form) (typecase form ((cons (member lambda) (cons proper-list proper-list)) t) (cons (or (compile-ordinary-p (car form)) (compile-ordinary-p (cdr form)))))) (defun compile-ordinaryp (form) (compile-ordinary-p (cddr (pd 'cmp-anon nil (list form))))) (defun t1ordinary (form) (cond ((unless *compiling-ordinary* (or *compile-ordinaries* (compile-ordinaryp form))) (maybe-eval nil form) ;; (let ((*compiling-ordinary* t)) ;; (t1expr `(funcall (lambda nil ,form nil)))) (let ((gen (gensym "progncompile"))(*compiling-ordinary* t)) (t1expr `(progn (defun ,gen nil (comment ',form) ,form nil) (,gen))))) (t (maybe-eval nil form) (let (*vars* *funs* *blocks* *tags*) (push (list 'ordinary form) *top-level-forms*) nil)))) (defun t3ordinary (form) (cond ((atom form)) ((constantp form)) ((add-init form)))) (defun t2declare (vv) (declare (ignore 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 '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 (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(" (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 (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 (caar s)) ");")) (*safe-compile* (wt-nl1 "super_funcall_no_event(" (vv-str (caar s)) ");")) (t (wt-nl1 "CMPfuncall(" (vv-str (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 (length y) 0) "," "") (cdr (assoc (get x 'cmp-lisp-type) +defentry-c-rep-alist+)))) tps :initial-value "")) (decl (concatenate 'string (string-downcase rt) " " m "(" decl ");")) (decl (if st "" decl)) (syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) args))) `(defun ,n ,syms (declare (optimize (safety 2))) ,@(mapcar (lambda (x y) `(check-type ,x ,(get y 'lisp-type))) syms tps) (lit ,(if (eq rt :void) :object rt) "({" ,decl ,@(when (eq rt :void) `("(")) ,m "(" ,@(mapcon (lambda (x y z) `((,(car z) ,(car y)) ,(if (cdr x) (if (consp (car x)) "+" ",") ""))) args syms tps) ")" ,@(when (eq rt :void) `(",Cnil)")) ";})")))) (defun t1defla (args) (declare (ignore args))) (defun parse-cvspecs (x &aux (cvspecs nil)) (dolist (cvs x (nreverse cvspecs)) (cond ((symbolp cvs) (push (list 'object (string-downcase (symbol-name cvs))) cvspecs)) ((stringp cvs) (push (list 'object cvs) cvspecs)) ((and (consp cvs) (member (car cvs) '(object char int float double))) (dolist (name (cdr cvs)) (push (list (car cvs) (cond ((symbolp name) (string-downcase (symbol-name name))) ((stringp name) name) (t (cmperr "The C variable name ~s is illegal." name)))) cvspecs))) (t (cmperr "The C variable specification ~s is illegal." cvs)))) ) ;; Add optional argument initial-ccb-vs here defaulting to ccb-vs. ;; Local functions will set this to the value of *initial-ccb-vs* ;; prevalent at the time of the local function creation. Closures ;; will let it default to ccb-vs, which will be the value of *ccb-vs* ;; prevalent at the time the environment stack was pushed and the ;; closure was created. CM 20031130 (defvar *reg-clv*) (defun t3local-fun (closure-p clink ccb-vs fun lambda-expr &optional (initial-ccb-vs ccb-vs) &aux (requireds (caaddr lambda-expr)) nargs specials *reg-clv* h at rt (level (if closure-p (if clink 0 -1) (fun-level fun))) (*volatile* (volatile (cadr lambda-expr)))) (declare (fixnum level)) (setq h (fun-call fun) at (caar h) rt (cadar h) at (mapcar 'global-type-bump at) rt (global-type-bump rt));FIXME (dolist (vl requireds) (cond ((eq (var-kind vl) 'special) (push (cons vl (var-loc vl)) specials)) ((var-cb vl) (push (list (eq 'clb (var-loc vl)) vl) *reg-clv*)) ; ((var-cb vl) (push vl *reg-clv*)) ((setf (var-kind vl) (or (car (member (promoted-c-type (var-type vl)) +c-global-arg-types+)) 'object)))) (setf (var-loc vl) (cs-push (var-type vl) t))) (wt-comment "local function " (if (fun-name fun) (fun-name fun) nil)) (wt-h "static " (declaration-type (rep-type rt)) (c-function-name (if closure-p "LC" "L") (fun-cfun fun) (fun-name fun)) "(") (wt-nl1 "static " (declaration-type (rep-type rt)) (c-function-name (if closure-p "LC" "L") (fun-cfun fun) (fun-name fun)) "(") (when (is-narg-le lambda-expr) (setq nargs (car (last requireds))) (setf (var-register nargs) 0)) (let (first) (unless closure-p (flet ((wt2 (x) (wt x) (let ((*compiler-output1* *compiler-output2*)) (wt x)))) (dotimes (i (1+ level)) (when first (wt2 ",")) (setq first t) (wt2 "object *") (wt2 *volatile*) (wt2 "base") (wt2 i)))) (wt-requireds requireds at first nargs)) (wt-h ";") (analyze-regs (cadr lambda-expr) 2) (let-pass3 ((*clink* clink) (*ccb-vs* ccb-vs) ;; Use new optional parameter to initialize ;; *initial-ccb-vs* for correct use in ;; wt-ccb-vs. CM 20031130 (*level* (1+ level)) (*initial-ccb-vs* initial-ccb-vs) (*exit* (or (cdr (assoc (promoted-c-type rt) +return-alist+)) 'return-object)) (*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*) (*debug* *debug*)) (when (eq (car (caddr (cddr lambda-expr))) 'decl-body) (local-compile-decls (caddr (caddr (cddr lambda-expr))))) (wt-nl1 "{ ") (let* ((cm *reservation-cmacro*)) ;; (tri (tail-recursion-info (fun-name fun) nil lambda-expr)) ;; (*unwind-exit* (if tri (cons 'tail-recursion-mark *unwind-exit*) *unwind-exit*))) (wt-nl "VMB" cm " VMS" cm " VMV" cm) (when nargs (wt-nl "va_list ap;")(wt-nl "va_start(ap,V" (var-loc nargs) ");")) (if *safe-compile* (wt-nl "vs_reserve(VM" cm ");") (wt-nl "vs_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) ; (when clv (wt-nl "#define base0 fcall.fun->fun.fun_env")) ; (dolist (v clv) (setf (var-ref v) (list 'cvar (var-loc v))) (c2bind v)) (dolist (v specials) (setq *bds-used* t) (wt-nl "bds_bind(" (vv-str (cdr v)) "," `(gen-loc :object (cvar ,(var-loc (car v)))) ");") (push 'bds-bind *unwind-exit*) (setf (var-kind (car v)) 'SPECIAL) (setf (var-loc (car v)) (cdr v))) (let ((*mv-var* (mv-var lambda-expr))) (c2expr (caddr (cddr lambda-expr))) (wt-V*-macros cm rt))) (wt-nl "#undef base0") (when nargs (wt-nl "va_end(ap);")) (wt-nl1 "}"))) (defun wt-cvars(&aux type ) (let (vars) (dolist (v *c-vars*) (when (integerp (cdr v)) (setq vars t) (let* ((t1 (car v)) (v (cdr v))) (cond ((eq type t1)(format *compiler-output2* " ,V~a" v)) (t (or (null type) (format *compiler-output2* ";")) (setq type t1) (if (eq (promoted-c-type type) 'integer) (format *compiler-output2* "IDECL1(V~a,V~abody,V~aalloc)" v v v) (format *compiler-output2* " ~a ~a V~a" *volatile* (rep-type type) v))))))) (when vars (format *compiler-output2* ";"))) (unless (or (not *vcs-used*) (= *cs* 0)) ; (format *compiler-output2* " object Vcs[~a]={Cnil" *cs*) ; (dotimes (temp (- *cs* 1) t) (format *compiler-output2* ",Cnil")) ; (format *compiler-output2* "};")) (format *compiler-output2* " ~a object Vcs[~a];" *volatile* *cs*))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpblock.lsp0000644000000000000000000000013114774225213016002 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.440938992 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpblock.lsp0000644000175000017500000001756314774225213015415 0ustar00cammcamm;;; CMPBLOCK Block and Return-from. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 (:print-function (lambda (x s i) (s-print 'blk (blk-name x) (si::address x) s)))) 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. type ) (si::freeze-defstruct 'blk) (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 ref-blks (form blks) (ref-obs form blks (lambda (x) (setf (blk-ref-ccb x) t)) (lambda (x) (setf (blk-ref-clb x) t)) (lambda (x) (setf (blk-ref x) t)))) (defun prune-mch (l &optional tag-conflict-p) (remove-if (lambda (x &aux (v (pop x))(tp (pop x))(st (pop x))(m (car x))) (and (type<= (var-type v) tp) (or (when tag-conflict-p (cdr st)) (subsetp (var-store v) st)) (if m (equal tp m) t))) l)) (defvar *c1exit* nil) (defun make-c1exit (n) (cons n (current-env))) (defun c1block (args &aux (info (make-info))(*c1exit* (cons (make-c1exit (car args)) *c1exit*))) (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 :exit *c1exit* :var (mapcan (lambda (x) (when (var-p x) (list (list x nil nil nil)))) *vars*))) (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args))))) (when (info-type (cadr body)) (or-mch (prune-mch (blk-var blk)))) (labels ((nb (b) (if (and (eq (car b) 'return-from) (eq blk (caddr b))) (nb (seventh b)) b))) (setq body (nb body))) (add-info info (cadr body)) (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk))) (ref-blks body (list blk)) (when (or (blk-ref-ccb blk) (blk-ref-clb blk)) (set-volatile info)) (when (info-type info) (mapc (lambda (x &aux (v (pop x))(tp (pop x))(st (pop x))(m (car x)) (tp (type-and tp (var-dt v))));FIXME, unnecessary? (unless (and (type= tp (var-type v)) (subsetp st (var-store v)) (subsetp (var-store v) st) (if m (equal m tp) t)) (keyed-cmpnote (list (var-name v) 'block-set) "Altering ~s at end of block ~s:~% type from ~s to ~s,~% store from ~s to ~s" v (blk-name blk) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp) (var-store v) st) (do-setq-tp v '(blk-set) tp) (push-vbinds v st))) (blk-var blk))) (cond ((or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))(list 'block info 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) (add-libc "setjmp") (setq *frame-used* t) (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) (blk-name blk)) (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") (wt-nl) (clink (blk-ref-clb blk)) (setf (blk-ref-ccb blk) (ccb-vs-push)) (add-libc "setjmp") (setq *frame-used* t) (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 &aux (name (car args)) ccb clb inner) (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))) (dolist (blk *blocks* (cmperr "The block ~s is undefined." name)) (case blk (cb (setq ccb t inner (or inner 'cb))) (lb (setq clb t inner (or inner 'lb))) (t (when (when (eq (blk-name blk) name) (not (member blk *lexical-env-mask*))) (let* ((*c1exit* (blk-exit blk)) (val (c1expr (cadr args))) (c1fv (when ccb (c1inner-fun-var)))) (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val)))) (when (info-type (cadr val)) (or-mch (prune-mch (blk-var blk)))) (return (list 'return-from (let ((info (copy-info (cadr val)))) (setf (info-type info) nil) (cond (ccb (pushnew blk (info-ref-ccb info))) (clb (pushnew blk (info-ref-clb info))) ((pushnew blk (info-ref info)))) (when c1fv (add-info info (cadr c1fv))) info) blk ccb clb c1fv val))))))));FIXME infer-tp here, or better in blk-var-null, etc. (defun c2return-from (blk ccb clb c1fv val) (declare (ignore c1fv)) (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);") (unwind-exit nil)) (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);}") (unwind-exit nil)) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpeval.lsp0000644000000000000000000000013114776006046015642 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.270034924 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpeval.lsp0000644000175000017500000026371414776006046015256 0ustar00cammcamm;;; CMPEVAL The Expression Dispatcher. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) :si) (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 readable-val (val) (cond ((not (arrayp val))) ((not (si::staticp val))))) (defun setq-p (form l) (cond ((eq form l)) ((atom form) nil) ((or (setq-p (car form) l) (setq-p (cdr form) l))))) (defun atomic-type-constant-value (atp &aux (a (car atp))) (when atp (typecase a ((or function cons array)) (otherwise (c1constant-value a (when (symbolp a) (symbol-package a))))))) ;; (defun atomic-type-constant-value (atp &aux (a (car atp))) ;; (when atp ;; (typecase ;; a ;; ((or function cons array)) ;; (otherwise ;; (unless (eq a +opaque+) ;; (if (when (symbolp a) (get a 'tmp)) ;FIXME cdr ;; (let ((a (get-var a))) ;; (when a (c1var a))) ;; (c1constant-value a (when (symbolp a) (symbol-package a))))))))) ;; (defun atomic-type-constant-value (atp &aux (a (car atp))) ;; (when atp ;; (typecase ;; a ;; ((or function cons array)) ;; (otherwise (c1constant-value a (when (symbolp a) (symbol-package a))))))) (defun c1expr-avct (res) (or (when (ignorable-form res) (atomic-type-constant-value (atomic-tp (info-type (cadr res))))) res)) (defun c1expr (form) (catch *cmperr-tag* (cond ((symbolp form) (cond ((constantp form) (let ((val (symbol-value form))) (or (c1constant-value val nil) `(location ,(make-info :type (object-type val)) (VV ,(add-constant form)))))) ; ((c1var form)))) ((c1expr-avct (c1var form))))) ;FIXME pcl ((consp form) (let ((fun (car form))) (c1expr-avct (cond ((symbolp fun) (c1symbol-fun form)) ((and (consp fun) (eq (car fun) 'lambda)) (c1symbol-fun (cons 'funcall 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))))) (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))));FIXME double cmp-eval with c1constant-value (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) ;; (eval (cons 'si::define-structure arg)) ;; (add-object2 (cons '|#,| (cons 'si::define-structure arg))) ;; nil) (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'. (inline-types-function itf) ;; car of ii is a function returning match info (sets-vs-top svt) (normalized-types nt) (apply-arg aa))) (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)) (defmacro flag-or (n flag) `(logior ,(ash 1 (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))) (cmpck (not (typep (car a ) 'fixnum)) "Obsolete optimization: use fix-opt ~s" opt) (when (listp (car opt)) (unless (flag-p (caddr opt) nt) (let ((s (uniq-sig (list (mapcar 'cmp-norm-tp (car opt)) (cmp-norm-tp (cadr opt)))))) (setf (car opt) (car s) (cadr opt) (cadr s) (caddr opt) (logior (caddr opt) (flags nt)))))) 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) (when (and (or (not *compiler-new-safety*) (member f '(unbox box))));FIXME (let* ((be (get f 'type-propagator)) (ba (and be ;(si::dt-apply be (cons f (mapcar 'coerce-to-one-valuea args))))));FIXME (apply be (cons f (mapcar 'coerce-to-one-value args))))));FIXME (when ba (return-from result-type-from-args ba))) (dolist (v '(inline-always inline-unsafe)) (let* ((w (get f v))) (if (and w (symbolp (caar w)) (flag-p (third (car w)) itf)) (return-from result-type-from-args (cadr (apply (caar w) args))) (dolist (w w) (fix-opt w) (when (and (flag-p (third w) result-type-from-args) (>= (length args) (- (length (car w)) (length (member '* (car w))))) (do ((a args (cdr a)) (b (car w) (if (and (eq (cadr b) '*) (endp (cddr b))) b (cdr b)))) ((null a) t) (unless (and (car a) (car b) (type>= (car b) (car a))) (return nil)))) (return-from result-type-from-args (second w))))))))) ;; (defun result-type-from-args (f args) ;; (when (and (or (not *compiler-new-safety*) (member f '(unbox box))));FIXME ;; (let* ((be (get f 'type-propagator)) ;; (ba (and be ;(si::dt-apply be (cons f (mapcar 'coerce-to-one-valuea args))))));FIXME ;; (apply be (cons f (mapcar 'coerce-to-one-value args))))));FIXME ;; (when ba ;; (return-from result-type-from-args (cmp-norm-tp ba)))) ;; (dolist (v '(inline-always inline-unsafe)) ;; (let* ((w (get f v))) ;; (if (and w (symbolp (caar w)) (flag-p (third (car w)) itf)) ;; (return-from result-type-from-args (cadr (apply (caar w) args))) ;; (dolist (w w) ;; (fix-opt w) ;; (when (and ;; (flag-p (third w) result-type-from-args) ;; (>= (length args) (- (length (car w)) (length (member '* (car w))))) ;; (do ((a args (cdr a)) ;; (b (car w) (if (and (eq (cadr b) '*) (endp (cddr b))) b (cdr b)))) ;; ((null a) t) ;; (unless (and (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 arg-appears (x y dep) ; (cond ((atom y) nil) ; ((consp (car y)) ; (or (arg-appears x (cdar y) t) (arg-appears x (cdr y) dep))) ; (t ; (or (and (eq x (car y)) dep) ; (arg-appears x (cdr y) dep))))) (defun cons-to-right (x) (and x (or (consp (car x)) (cons-to-right (cdr x))))) (defun needs-pre-eval (x) (or (and (consp (car x)) (not (eq (caar x) 'quote))) (and (atom (car x)) (not (constantp (car x))) (cons-to-right (cdr x))))) ; (arg-appears (car x) (cdr x) nil)))) (defun bind-before-cons (x y) (and y (consp (car y)) (atom (cadar y)) (if (eq x (cadar y)) (caar y) (bind-before-cons x (cdr y))))) (defun pull-evals-int (x form lets) (if (atom x) (list (nreverse form) (nreverse lets)) (let* ((s (if (needs-pre-eval x) (bind-before-cons (car x) lets) (car x))) (lets (if s lets (cons (list (tmpsym) (car x)) lets))) (s (or s (caar lets)))) (pull-evals-int (cdr x) (cons s form) lets)))) (defun pull-evals (form) (let ((form (pull-evals-int (cdr form) (list (car form)) nil))) (values (car form) (cadr form)))) (defun binary-nest-int (form len) (declare (fixnum len) (list form)) (if (> len 3) (binary-nest-int (cons (car form) (cons (list (car form) (cadr form) (caddr form)) (cdddr form))) (1- len)) form)) (defmacro let-wrap (lets form) `(if ,lets (list 'let* ,lets ,form) ,form)) (defun binary-nest (form env) (declare (ignore env)) (let ((len (length form))) (declare (fixnum len)) (if (> len 3) (let-wrap nil (binary-nest-int form len)) ;; (multiple-value-bind (form lets) (values form nil);(pull-evals form) ;; (let-wrap lets (binary-nest-int form len))) form))) (si::putprop '* 'binary-nest 'si::compiler-macro-prop) (si::putprop '+ 'binary-nest 'si::compiler-macro-prop) (si::putprop 'logand 'binary-nest 'si::compiler-macro-prop) (si::putprop 'logior 'binary-nest 'si::compiler-macro-prop) (si::putprop 'logxor 'binary-nest 'si::compiler-macro-prop) (si::putprop 'max 'binary-nest 'si::compiler-macro-prop) (si::putprop 'min 'binary-nest 'si::compiler-macro-prop) (si::putprop 'gcd 'binary-nest 'si::compiler-macro-prop) (si::putprop 'lcm 'binary-nest 'si::compiler-macro-prop) (si::putprop '- 'binary-nest 'si::compiler-macro-prop) (si::putprop '/ 'binary-nest 'si::compiler-macro-prop) (defun multiple-value-bind-expander (form env) (declare (ignore env)) (if (and (consp (caddr form)) (eq (caaddr form) 'values)) (let ((l1 (length (cadr form))) (l2 (length (cdaddr form)))) `(let (,@(mapcar 'list (cadr form) (cdaddr form)) ,@(when (> l1 l2) (nthcdr l2 (cadr form)))) ,@(when (> l2 l1) (nthcdr l1 (cdaddr form))) ,@(cdddr form))) form)) (si::putprop 'multiple-value-bind 'multiple-value-bind-expander 'si::compiler-macro-prop) ;FIXME apply-expander ;; (defun funcall-expander (form env &aux x);FIXME inlinable-fn? ;; (declare (ignore env)) ;; (cond ((and (consp (cadr form)) (eq (caadr form) 'lambda)) (cdr form)) ;; ((and (consp (cadr form)) (eq (caadr form) 'function) ;; (setq x (si::funid-p (cadadr form)))) ;; `(,x ,@(cddr form))) ;; ((constantp (cadr form)) `(,(cmp-eval (cadr form)) ,@(cddr form))) ;; (form))) ;; (si::putprop 'funcall 'funcall-expander 'si::compiler-macro-prop) (defun logical-binary-nest (form env) (declare (ignore env)) (if (> (length form) 3) (multiple-value-bind (form lets) (pull-evals form) (let (r) (do ((f (cdr form) (cdr f))) ((null (cdr f)) (let-wrap lets (cons 'and (nreverse r)))) (push (list (car form) (car f) (cadr f)) r)))) form)) (si::putprop '> 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '>= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '< 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '<= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop '= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char> 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char>= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char< 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char<= 'logical-binary-nest 'si::compiler-macro-prop) (si::putprop 'char= 'logical-binary-nest 'si::compiler-macro-prop) (defun logical-outer-nest (form env) (declare (ignore env)) (if (> (length form) 3) (multiple-value-bind (form lets) (pull-evals form) (let (r) (do ((f (cdr form) (cdr f))) ((null (cdr f)) (let-wrap lets (cons 'and (nreverse r)))) (do ((g (cdr f) (cdr g))) ((null g)) (push (list (car form) (car f) (car g)) r))))) form)) (si::putprop '/= 'logical-outer-nest 'si::compiler-macro-prop) (si::putprop 'char/= 'logical-outer-nest 'si::compiler-macro-prop) (defun incr-to-plus (form env) (declare (ignore env)) `(+ ,(cadr form) 1)) (defun decr-to-minus (form env) (declare (ignore env)) `(- ,(cadr form) 1)) (si::putprop '1+ 'incr-to-plus 'si::compiler-macro-prop) (si::putprop '1- 'decr-to-minus 'si::compiler-macro-prop) (defun plusp-compiler-macro (form env) (declare (ignore env)) (if (and (cdr form) (endp (cddr form))) `(> ,(cadr form) 0) form)) (si::putprop 'plusp 'plusp-compiler-macro 'si::compiler-macro-prop) (defun minusp-compiler-macro (form env) (declare (ignore env)) (if (and (cdr form) (endp (cddr form))) `(< ,(cadr form) 0) form)) (si::putprop 'minusp 'minusp-compiler-macro 'si::compiler-macro-prop) (defun zerop-compiler-macro (form env) (declare (ignore env)) (if (and (cdr form) (endp (cddr form))) `(= ,(cadr form) 0) form)) (si::putprop 'zerop 'zerop-compiler-macro 'si::compiler-macro-prop) (defun local-aliases (var excl &aux (bind (get-vbind var)) res) (when bind (let ((e (member-if-not 'var-p *vars*))) (do ((x *vars* (cdr x))) ((eq x e) res) (let ((cx (car x))) (unless (member cx excl) (when (eq bind (get-vbind cx)) (push cx res)))))))) (defun c1infer-tp (args) (let* ((n (pop args)) (v (c1vref n)) (x (car v)) (tpi (ensure-known-type (pop args))) (tp (type-and (var-type x) tpi)) (l (local-aliases x nil)) (tp (reduce 'type-and l :key 'var-type :initial-value tp)) (l (mapc (lambda (x) (do-setq-tp x nil tp)) l)) (res (c1expr (car args))) (ri (cadr res))) (if (exit-to-fmla-p) (let ((info (make-info))) (add-info info ri) (setf (info-type info) (info-type ri)) `(infer-tp ,info ,l ,tpi ,res)) res))) (defun c2infer-tp (x tp fm) (declare (ignore x tp)) (c2expr fm)) (si::putprop 'infer-tp 'c1infer-tp 'c1) (si::putprop 'infer-tp 'c2infer-tp 'c2) (defconstant +cnum-tp-alist+ `((,#tfixnum . ,(c-type 0)) (,#tbignum . ,(c-type (1+ most-positive-fixnum))) (,#tratio . ,(c-type 1/2)) (,#tshort-float . ,(c-type 0.0s0)) (,#tlong-float . ,(c-type 0.0)) (,#tfcomplex . ,(1+ si::c-type-max)) (,#tdcomplex . ,(+ 2 si::c-type-max)) (,#t(complex rational) . ,(c-type #c(0 1))))) (defconstant +hash-index-type+ #t(or (integer -1 -1) seqind)) (defun identity-expander (form env) (declare (ignore env)) (if (cddr form) form (cadr form))) (si::putprop 'identity 'identity-expander 'si::compiler-macro-prop) ;; (defun seqind-wrap (form) ;; (if *safe-compile* ;; form ;; `(the seqind ,form))) (defun fboundp-expander (form env) (declare (ignore env)) `(si::fboundp-sym (si::funid-sym ,(cadr form)))) (si::putprop 'fboundp 'fboundp-expander 'si::compiler-macro-prop) ;; (defun maphash-expander (form env) ;; (declare (ignore env)) ;; (let ((block (tmpsym))(tag (gensym)) (ind (gensym)) (key (gensym)) (val (gensym))) ;; `(block ;; ,block ;; (let ((,ind -1)) ;; (declare (,+hash-index-type+ ,ind)) ;; (tagbody ;; ,tag ;; (when (< (setq ,ind (si::next-hash-table-index ,(caddr form) (1+ ,ind))) 0) ;; (return-from ,block)) ;; (let ((,key (si::hash-key-by-index ,(caddr form) ,ind)) ;; (,val (si::hash-entry-by-index ,(caddr form) ,ind))) ;; (funcall ,(cadr form) ,key ,val)) ;; (go ,tag)))))) ;; (si::putprop 'maphash 'maphash-expander 'si::compiler-macro-prop) ;; (defun array-row-major-index-expander (form env &optional (it 0)) ;; (declare (fixnum it)(ignorable env)) ;; (let ((l (length form))) ;; (cond ((= l 2) 0) ;; ((= l 3) (seqind-wrap (caddr form))) ;; (t (let ((it (1+ it)) ;; (fn (car form)) ;; (ar (cadr form)) ;; (first (seqind-wrap (caddr form))) ;; (second (seqind-wrap (cadddr form))) ;; (rest (cddddr form))) ;; (array-row-major-index-expander ;; `(,fn ,ar ,(seqind-wrap ;; `(+ ;; ,(seqind-wrap ;; `(* ,first (array-dimension ,ar ,it))) ,second)) ,@rest) ;; nil it)))))) ;;(si::putprop 'array-row-major-index 'array-row-major-index-expander 'si::compiler-macro-prop) ;; (defmacro with-pulled-array (bindings form &body body) ;FIXME ;; `(let ((,(car bindings) (cadr ,form))) ;; (let ((,(cadr bindings) `((,(tmpsym) ,,(car bindings))))) ;; (let ((,(caddr bindings) (or (caar ,(cadr bindings)) ,(car bindings)))) ;; ,@body)))) ;; (defun aref-expander (form env) ;; (declare (ignore env)) ;; (with-pulled-array ;; (ar lets sym) form ;; (let ((isym (tmpsym))) ;; (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(cddr form))))))) ;; (let-wrap lets `(compiler::cmp-aref ,sym ,isym)))))) ;; (si::putprop 'aref 'aref-expander 'si::compiler-macro-prop) ;; (si::putprop 'row-major-aref 'aref-expander 'si::compiler-macro-prop) ;; (defun aset-expander (form env) ;; (declare (ignore env)) ;; (let ((form (if (eq (car form) 'si::aset-wrap) form ;; (cons (car form) (append (cddr form) (list (cadr form)))))));FIXME ;; (with-pulled-array ;; (ar lets sym) form ;; (let ((isym (tmpsym))) ;; (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(butlast (cddr form)))))))) ;; (let-wrap lets `(compiler::cmp-aset ,sym ,isym ,(car (last form))))))))) ;; (si::putprop 'si::aset 'aset-expander 'si::compiler-macro-prop) ;; (si::putprop 'si::aset-wrap 'aset-expander 'si::compiler-macro-prop) ;FIXME -- test and install this and svref, CM 20050106 ;(si::putprop 'svset 'aset-expander 'si::compiler-macro-prop) ;; (defun array-dimension-expander (form env) ;; (declare (ignore env)) ;; (with-pulled-array ;; (ar lets sym) form ;; (let-wrap lets `(compiler::cmp-array-dimension ,sym ,(caddr form))))) ;;(si::putprop 'array-dimension 'array-dimension-expander 'si::compiler-macro-prop) (defmacro inlinable-fn (a) `(or (constantp ,a) (and (consp ,a) (member (car ,a) '(function lambda))))) (define-compiler-macro or (&whole form) (cond ((endp (cdr form)) nil) ((endp (cddr form)) (cadr form)) ((cmp-macroexpand `(,(pop form) ,(pop form) (or ,@form)))))) (defvar *basic-inlines* nil) (defun comment (x) x) (defun c1comment (args) (list 'comment (make-info :type t :flags (iflags side-effects)) (let ((x (car args))) (if (constantp x) (cmp-eval x) x)))) (defun c2comment (comment &aux (comment-string (comment-string comment))) (when *annotate* (wt-nl "/*")(princ comment-string *compiler-output1*)(wt "*/"))) (si::putprop 'comment 'c1comment 'c1) (si::putprop 'comment 'c2comment 'c2) (defvar *inl-hash* (make-hash-table :test 'eq)) (defun ibtp (t1 t2 &aux (a1 (atomic-tp t1))(a2 (atomic-tp t2))) (if (unless (type-and t1 t2) (and a1 a2 (listp t1) (listp t2) (equal (car t1) (car t2)))) (car t1) (type-or1 t1 t2))) (defun coalesce-inl (cl inl tps rt &aux (lev (this-safety-level))) (when (> lev (third inl)) (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-coalesce) "Coalescing safety ~s: ~s ~s" (car cl) (third inl) lev) (setf (third inl) lev)) (unless (type<= rt (cdr (fifth inl))) (let ((n (ibtp (cdr (fifth inl)) rt))) (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-coalesce) "Coalescing return-type ~s: ~s ~s" (car cl) (cdr (fifth inl)) n) (setf (cdr (fifth inl)) n))) (mapl (lambda (x y &aux (cx (car x))(cy (car y))) (unless (type<= cy cx) (let ((n (ibtp cx cy))) (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-coalesce) "Coalescing arg-type ~s: ~s ~s" (car cl) cx n) (setf (car x) n)))) (car inl) tps)) (defun can-coalesce (x tr inl tps) (and (equal tr (second x)) (string= (car (last inl)) (car (last x))) (>= (car inl) (third x)) (eql (length tps) (length (car x))) (every 'type>= tps (car x)))) (defun remove-comment (s &aux (b (string-match #v"/\\*" s))(e (string-match #v"\\*/" s))) (if (< -1 b e) (string-concatenate (subseq s 0 b) (remove-comment (subseq s (+ e 2)))) s)) (defun lit-inl2 (form &aux (lf (eq 'lit (car form)))) (list (this-safety-level) (mapcar (lambda (x) (assert (eq (car x) 'ub)) (third x)) (when lf (fifth form))) (cons (when lf (third form)) (info-type (cadr form))) (if lf (remove-comment (fourth form)) ""))) (defun cl-to-fn (cl) (when (null (cdr (last cl))) (let ((fn (car cl))) (when (symbolp fn) (unless (local-fun-p fn) fn))))) (defun get-inl-list (cl &optional set &aux (fn (cl-to-fn cl))) (when fn (or (gethash fn *inl-hash*) (when set (setf (gethash fn *inl-hash*) (list nil)))))) (defun inls-match (cl fms &aux (lev (this-safety-level)) (tps (mapcar (lambda (x) (info-type (caddr x))) fms))) (when (member-if-not 'atomic-tp tps) (car (member tps (car (get-inl-list cl)) :test (lambda (x y &aux (cy (car y))) (when (<= lev (third y)) (when (eql (length x) (length cy)) (every 'type<= x cy)))))))) (defun ?add-inl (cl fms fm) (unless (or (member-if 'atomic-tp fms :key (lambda (x) (info-type (caddr x)))) (atomic-tp (info-type (cadr fm))) (exit-to-fmla-p)); (inls-match cl fms) (let* ((tps (mapcar (lambda (x) (info-type (caddr x))) fms)) (tr (mapcar (lambda (x &aux (v (car (last x)))) (when (and (consp v) (eq (car v) 'var)) (position (cddr v) fms :key 'cdddr :test 'equalp)));FIXME (if (eq (car fm) 'var) (list (list fm)) (fifth fm)))) (nat (let ((i -1)) (mapcan (lambda (x &aux (y (incf i))) (unless (atomic-tp x) (list y))) tps)))) (unless (or (member nil tr) (set-difference nat tr)) (let* ((pl (get-inl-list cl t)) (inl (lit-inl2 fm)) (z (member-if (lambda (x) (can-coalesce x tr inl tps)) (car pl)))) (cond (z (coalesce-inl cl (car z) tps (cdr (third inl))) (setf (cdr z) (remove-if (lambda (x) (can-coalesce x tr inl tps)) (cdr z)))) (pl (let ((x (list* tps tr inl))) (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-add) "Adding inl-hash ~s: ~s" (car cl) x) (push x (car pl)))))))))) (defun prepend-comment (form s) (if *annotate* (si::string-concatenate "/* " (prin1-to-string form) " */" (remove-comment s)) s)) (defun apply-inl (cl fms &aux (inl (inls-match cl fms))) (when inl (let* ((c1fms (mapcar (lambda (x) (cdr (nth x fms))) (second inl)))) (unless (member-if-not (lambda (x) (case (car x) (var (eq (var-kind (caaddr x)) 'lexical)) ((lit location) t))) c1fms) (cond ((zerop (length (car (last inl)))) (let* ((x (car c1fms))(h (pop x)) (i (copy-info (pop x)))) (setf (info-type i) (type-and (cdr (fifth inl)) (info-type i))) (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-apply) "Applying var inl-hash ~s" (car cl)) (list* h i x))) ((let ((x (c1lit (list (car (fifth inl)) (prepend-comment (cons 'applied cl) (car (last inl)))) (mapcar 'list (fourth inl) c1fms)))) (setf (info-type (cadr x)) (type-and (cdr (fifth inl)) (info-type (cadr x)))) (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-apply) "Applying inl-hash ~s: ~s: ~s" (car cl) (fourth x)) x))))))) (defun dump-inl-hash (f) (with-open-file (s f :direction :output) (prin1 '(in-package :compiler) s) (terpri s) (maphash (lambda (x y) (prin1 `(setf (gethash ',x *inl-hash*) (list (list ,@(mapcar (lambda (z) `(list (mapcar 'uniq-tp ',(mapcar 'export-type (pop z))) ',(pop z) ',(pop z) ',(pop z) (cons ',(caar z) (uniq-tp ',(cdar z))) ,(cadr z))) (car y))))) s) (terpri s)) *inl-hash*)) nil) (defun show-inls (fn) (mapcar (lambda (x) (list (mapcar 'cmp-unnorm-tp (car x)) (third x) (car (last x)))) (car (gethash fn *inl-hash*)))) (defun c1inline (args env inls) (let* ((cl (pop args))(fm (pop args))) (or (apply-inl cl inls) (let* ((nargs (under-env env (c1let-* (cdr fm) t inls)))) (case (car nargs) ((var lit) (?add-inl cl inls nargs) (when (stringp (fourth nargs)) (setf (fourth nargs) (prepend-comment cl (fourth nargs)))) nargs) (otherwise (list 'inline (copy-info (cadr nargs)) cl nargs))))))) (defvar *annotate* nil) (defun comment-string (comment) (when *annotate* (mysub (mysub (write-to-string comment :length 3 :level 3) "/*" "_*") "*/" "*_"))) (defun c2inline (comment expr &aux (comment-string (comment-string comment))) (when *annotate* (wt-nl "/*")(princ comment-string *compiler-output1*)(wt "*/")) (c2expr expr) (when *annotate* (wt-nl "/* END ")(princ comment-string *compiler-output1*)(wt "*/"))) (si::putprop 'inline 'c1inline 'c1) (si::putprop 'inline 'c2inline 'c2) ;; (defun c1size (form) ;; (cond ((atom form) 0) ;; ((1+ (+ (c1size (car form)) (c1size (cdr form))))))) ;; (defvar *inline-forms* nil) ;; (defun copy-vars (form) ;; (cond ((var-p form) (setf (var-store form) (var-kind form))) ;; ((consp form) (copy-vars (car form)) (copy-vars (cdr form))))) ;; (defun set-vars (form) ;; (cond ((var-p form) (setf (var-kind form) (var-store form))) ;; ((consp form) (set-vars (car form)) (set-vars (cdr form))))) ;; (defun global-ref-p (form) ;; (cond ((and (var-p form) (member (var-kind form) '(global special)))) ;; ((atom form) nil) ;; ((or (global-ref-p (car form)) (global-ref-p (cdr form)))))) ;; (defun closure-p (form) ;; (and (eq (car form) 'function) ;; (eq (caaddr form) 'lambda) ;; (or (do-referred (s (cadr (caddr form))) ;; (unless (member s (caaddr (caddr form))) (return t))) ;; (global-ref-p form)))) ;; (defun vv-p (form) ;; (cond ((atom form) nil) ;; ((and (eq (car form) 'location) (listp (caddr form)) ;; (or (eq (caaddr form) 'vv) ;; (and (member (caaddr form) '(fixnum-value character-value long-float-value short-float-value fcomplex-value dcomplex-value)) ;; (cadr (caddr form)))))) ;; ((or (vv-p (car form)) (vv-p (cdr form)))))) ;;FIXME ;(dolist (l '(typep coerce constantly complement open load delete-package import compile compile-file ; error cerror warn break get-setf-method make-list)) ; (si::putprop l t 'cmp-no-src-inline)) ;; (defvar *prop-hash* nil) ; (make-hash-table :test 'equal)) (defvar *src-inline-recursion* nil) (defvar *prev-sri* nil) (defvar *src-hash* (make-hash-table :test 'eq)) ;; (defun src-inlineable (form) ;; (let ((n (car form))) ;; (and (symbolp n) ;; (not (get n 'cmp-no-src-inline)) ;; (fboundp n) ;; (or (gethash n *src-hash*) ;; (setf (gethash n *src-hash*) ;; (let ((fn (symbol-function n))) (when (functionp fn) (function-lambda-expression fn))))) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package 'c))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) 'lisp) ;; (when (eq n s) (eq k :external))))))) ;; (defun mark-for-hash-inlining (fms) ;; (let ((i 0) ;; (c1t (c1t)) ;; (c1nil (c1nil))) ;; (mapl (lambda (x) ;; (when (car x) ;; (when (or (eq (car x) c1t) (eq (car x) c1nil)) ;; (setf (car x) (list (caar x) (copy-info (cadar x)) (caddar x)))) ;; (setf (info-unused1 (cadar x)) (incf i)))) fms))) ;; (defun inline-hasheable (form fms c1) ;; (let ((cp (member-if 'closure-p fms)) ;; (vvp (vv-p (if (eq (car (fourth c1)) 'let*) (cddddr (fourth c1)) c1))) ;; (rec (and (boundp '*recursion-detected*) (eq *recursion-detected* t)))) ;; (when cp (keyed-cmpnote 'inline-hash "not hashing ~s due to closure~%" form)) ;; (when vvp (keyed-cmpnote 'inline-hash "not hashing ~s due to vv objs~%" form)) ;; (when rec (keyed-cmpnote 'inline-hash "not hashing ~s due to recursion~%" form)) ;; (not (or cp vvp rec)))) ;; (defun info-form-alist (o n) ;; (mapcan (lambda (o) ;; (when o ;; (let ((n (car (member (info-unused1 (cadr o)) n :key (lambda (x) (when x (info-unused1 (cadr x)))))))) ;; (when n (list (cons o n)))))) o)) ;; (defun array-replace (x y z) ;; (do ((i 0 (1+ i))) ((>= i (length x))) ;; (when (eq y (aref x i)) ;; (setf (aref x i) z)))) ;; (defun info-replace-var (x y z) ;; (array-replace (info-referred-array x) y z) ;; (array-replace (info-changed-array x) y z)) ;; (defun info-replace-var (x y z) ;; (nsubst z y (info-ref x)) ;; (nsubst z y (info-ch x))) ;; (defun info-var-match (i v) ;; (or (is-referred v i) (is-changed v i))) ;; (defun collect-matching-vars (ov f) ;; (cond ((var-p f) (when (or (member f ov) (list-split (var-aliases f) ov)) (list f))) ;; ((info-p f) (let (r) ;; (dolist (ov ov r) ;; (when (info-var-match f ov) (push ov r))))) ;; ((atom f) nil) ;; ((nunion (collect-matching-vars ov (car f)) (collect-matching-vars ov (cdr f)))))) ;; (defun collect-matching-info (ov f) ;; (cond ((info-p f) (when (member-if (lambda (x) (info-var-match f x)) ov) (list f))) ;; ((atom f) nil) ;; ((nunion (collect-matching-info ov (car f)) (collect-matching-info ov (cdr f)))))) ;; (defun fms-fix (f fms) ;; (let* ((vv (collect-matching-vars (third f) fms)) ;; (ii (collect-matching-info vv fms)) ;; (nv (mapcar 'copy-var vv)) ;; (a (mapcar 'cons vv nv)) ;; (nv (mapc (lambda (x) (setf (var-aliases x) (sublis a (var-aliases x)))) nv)) ;; (ni (mapcar 'copy-info ii)) ;; (ni (mapc (lambda (x) (mapc (lambda (y z) (info-replace-var x y z)) vv nv)) ni))) ;; (sublis (nconc a (mapcar 'cons ii ni)) fms))) ;; (defun get-inline-h (form prop fms) ;; (let ((h (when *prop-hash* (gethash prop *prop-hash*)))) ;; (when h ;; (unless (acceptable-inline h form (cddr prop)) ;; (return-from get-inline-h (cons nil (cdr h)))) ;; (let* ((f (car h)) ;; (fms (fms-fix (fourth f) fms)) ;; (al (info-form-alist (car (last h)) fms)) ;; (nfs (mapcar 'cdr al)) ;; (oi (cadr f)) ;; (info (make-info)) ;; (al (cons (cons oi info) al)) ;; (al (cons (cons (caddr f) (with-output-to-string (s) (princ form s))) al))) ;; (set-vars f) ;; (setf (info-type info) (info-type oi)) ;; (dolist (l nfs) (add-info info (cadr l))) ;; (cons (sublis al f) (cdr h)))))) ;; (defun acceptable-inline (h form tpis) ;; (let* ((c1 (car h)) ;; (sz (cadr h)) ;; (d (and c1 ;; (inline-possible (car form)) ;; (or (< sz (* 1000 (- 3 (max 0 *space*)))) ;; (and (< *space* 3) (member-if (lambda (x) (and (atomic-tp (car x)) (functionp (cadar x)))) tpis)))))) ;; (if d ;; (keyed-cmpnote 'inline "inlining ~s ~s~%" form (not (not h))) ;; (keyed-cmpnote 'inline "not inlining ~s ~s ~s ~s~%" form sz (* 1000 (- 3 (max 0 *space*))) tpis)) ;; d)) ;; (defun fms-callees (fms) ;; (mapcan ;; (lambda (x) ;; (when (eq (car x) 'function) ;; (let ((fun (caaddr x))) ;; (when (fun-p fun) ;; (cadr (fun-call fun)))))) fms)) ;; (defun push-callees (fms) ;; (let ((fc (fms-callees fms))) ;; (setq *callees* (nunion *callees* fc :test 'eq :key 'car)))) ;; (defun bind-all-vars-int (form nf bindings) ;; (cond ((null form) ;; (list bindings (nreverse nf))) ;; ((consp (car form)) ;; (let ((lwf (bind-all-vars-int (cdar form) (list (caar form)) bindings))) ;; (bind-all-vars-int (cdr form) (cons (cadr lwf) nf) (car lwf)))) ;; (t ;; (let* ((sym (if (symbolp (car form)) (cdr (assoc (car form) bindings)) (car form))) ;; (bindings (if sym bindings (cons (cons (car form) (tmpsym)) bindings))) ;; (sym (or sym (cdar bindings)))) ;; (bind-all-vars-int (cdr form) (cons sym nf) bindings))))) ;; (defun bind-all-vars (form) ;; (if (atom form) form ;; (let ((res (bind-all-vars-int (cdr form) (list (car form)) nil))) ;; (if (car res) ;; (list 'let* (mapcar (lambda (x) (list (cdr x) (car x))) (nreverse (car res))) ;; (cadr res)) ;; (cadr res))))) ;; (defun if-protect-fun-inf (form env) ;; (declare (ignore env)) ;; (cons (car form) ;; (cons (cadr form) ;; (cons (bind-all-vars (caddr form)) ;; (if (cadddr form) (list (bind-all-vars (cadddr form)))))))) ;(defvar *callees* nil) (defun maybe-reverse-type-prop (dt f) (unless *safe-compile*;FIXME push-vbind/c1var copy (when (consp f) (eq (car f) 'lit)) (set-form-type f (coerce-to-one-value dt)))) ;; (defun maybe-reverse-type-prop (dt f) ;; (unless *safe-compile* ;; (set-form-type f dt))) (defun cll (fn) (car (member (sir-name fn) *src-inline-recursion* :key 'caar))) (defun inline-sym-src (n) (and (inline-possible n) (or (inline-asserted n) (get n 'consider-inline) (multiple-value-bind (s k) (find-symbol (symbol-name n) :cl) (when (eq n s) (eq k :external)))) (or (local-fun-src n) (let ((fn (when (fboundp n) (symbol-function n)))) (when (functionp fn) (unless (typep fn 'funcallable-std-instance);FIXME really just need to check/handle for closure (values (or (gethash fn *src-hash*) (setf (gethash fn *src-hash*) (function-lambda-expression fn)))))))))) ;; (defun inline-sym-src (n) ;; (and (inline-possible n) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package :c))) ;; (eq (symbol-package n) (load-time-value (find-package :libm))) ;; (eq (symbol-package n) (load-time-value (find-package :libc))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) :cl) ;; (when (eq n s) (eq k :external)))) ;; (or (local-fun-src n) ;; (let ((fn (when (fboundp n) (symbol-function n)))) ;; (when (functionp fn) ;; (unless (typep fn 'generic-function) ;; (values (or (gethash fn *src-hash*) (setf (gethash fn *src-hash*) (function-lambda-expression fn)))))))))) ;; (defun inline-sym-src (n) ;; (and (inline-possible n) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package 'c))) ;; (eq (symbol-package n) (load-time-value (find-package "libm"))) ;; (eq (symbol-package n) (load-time-value (find-package "libc"))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) 'lisp) ;; (when (eq n s) (eq k :external)))) ;; (or (local-fun-src n) ;; (let ((fn (when (fboundp n) (symbol-function n)))) ;; (when (functionp fn) (values (function-lambda-expression fn))))))) ;; (defun inline-sym-src (n) ;; (and (inline-possible n) ;; (or (inline-asserted n) ;; (eq (symbol-package n) (load-time-value (find-package 'c))) ;; (multiple-value-bind (s k) (find-symbol (symbol-name n) 'lisp) ;; (when (eq n s) (eq k :external)))) ;; (or (local-fun-src n) ;; (gethash n *src-hash*) ;; (setf (gethash n *src-hash*) ;; (let ((fn (when (fboundp n) (symbol-function n)))) ;; (when (functionp fn) (function-lambda-expression fn))))))) (defun inline-src (fn) (unless *compiler-new-safety* (when (> *speed* 0) (cond ((symbolp fn) (inline-sym-src fn)) ((functionp fn) (local-fun-src fn)) ((and (consp fn) (eq (car fn) 'lambda)) fn))))) (defun ttl-tag-src (src tag &optional block &aux (h (pop src)) (ll (pop src))) (multiple-value-bind (doc decls ctps body) (parse-body-header src) (let* ((aux (member '&aux ll));FIXME centralize with new-defun-args (ll (ldiff ll aux)) (non-aux (mapcan (lambda (x &aux (lp (listp x))) (cons (if lp (if (listp (car x)) (cadar x) (car x)) x) (when (when lp (cddr x)) (list (caddr x))))) ll)) (non-aux (set-difference non-aux '(&optional &rest &key &allow-other-keys))) (od (split-decls non-aux decls)) (rd (cons `(declare (optimize (safety ,(decl-safety decls)))) (pop od))) (oc (split-ctps non-aux ctps)) (rc (pop oc)) (n (blocked-body-name body)) (body (if n (cddar body) body)) (n (or n block)) ;rebind args beneath ttl tag for tail recursion with closures (bind (when block (mapcar 'list non-aux non-aux))) (bind (nconc bind (cdr aux))) ; (bind (nconc (mapcar 'list non-aux non-aux) (cdr aux))) (body `(block ,n (tagbody ,tag (return-from ,n (let* ,bind ,@(when block rd) ,@(car od) ,@(when block rc) ,@(car oc) ,@body)))))) `(,h ,ll ,@(when doc (list doc)) ,@rd ,@rc ,body)))) ;; (defun ttl-tag-src (src &optional (tag (tmpsym)) (block (tmpsym)) &aux (h (pop src)) (ll (pop src))) ;; (setf (get tag 'ttl-tag) t) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header src) ;; (let* ((aux (member '&aux ll));FIXME centralize with new-defun-args ;; (ll (ldiff ll aux)) ;; (regs (mapcar (lambda (x) (cond ((symbolp x) x) ((symbolp (car x)) (car x)) ((cadar x)))) ll)) ;; (regs (set-difference regs '(&optional &rest &key &allow-other-keys))) ;; (od (split-decls regs decls)) ;; (rd (cons `(declare (optimize (safety ,(decl-safety decls)))) (pop od))) ;; (oc (split-ctps regs ctps)) ;; (rc (pop oc)) ;; (n (blocked-body-name body)) ;; (body (if n (cddar body) body)) ;; (n (or n block)) ;; (body `(block ,n (tagbody ,tag (return-from ,n (let* ,(cdr aux) ,@(car od) ,@(car oc) ,@body)))))) ;; `(,h ,ll ,@(when doc (list doc)) ,@rd ,@rc ,body)))) ;; (defun ttl-tag-src (src &optional (tag (tmpsym)) block &aux (h (pop src)) (ll (pop src))) ;; (setf (get tag 'ttl-tag) t) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header src) ;; (let* ((aux (member '&aux ll)) ;; (ll (ldiff ll aux)) ;; (aux (cdr aux)) ;; (auxv (mapcar (lambda (x) (if (consp x) (car x) x)) aux)) ;; (ad (split-decls auxv decls)) ;; (od (cadr ad)) ;; (ad (car ad)) ;; (ac (split-ctps auxv ctps)) ;; (oc (cadr ac)) ;; (ac (car ac)) ;; (n (blocked-body-name body)) ;; (body (if n (cddar body) body)) ;; (n (or n block)) ;; (body `(block ,n (tagbody ,tag (return-from ,n (let* ,aux ,@ad ,@ac ,@body)))))) ;; `(,h ,ll ,@(when doc (list doc)) ,@od ,@oc ,body)))) (defvar *int* nil) (defmacro ttm (fn &body body) `(let* ((st (get-internal-real-time)) (res ,@body) (end (- (get-internal-real-time) st)) (dd (or (cdr (assoc ,fn *int*)) (cdar (push (list ,fn 0 0) *int*))))) (incf (car dd)) (incf (cadr dd) end) res)) (defun mi4 (fn args la src env inls) (c1inline (list (cons fn (append args la)) (blla (cadr src) args la (cddr src))) env inls)) (defun sir-tag (sir) (cadar (member-if (lambda (x) (and (eq (caar x) (car sir)) (cdddr x))) (reverse *src-inline-recursion*)))) (defun discrete-tp (tp &optional (i 0)) (when (< i 5);FIXME (cond ((atomic-tp tp)) ((when (consp tp) (eq (car tp) 'or)) (not (member-if-not (lambda (x) (discrete-tp x (incf i))) (cdr tp))))))) ;; This function regulates the heuristic balance between compiler ;; speed and type precision primarily via tagbody iteration. The ;; algorithm is essentially a guess at a surrounding type which might ;; not be overflowed on subsequent compilation iteration. More ;; sophisticated ideas include bumping based on the type increment ;; instead of the type-or, and collecting bounding information during ;; the compilation pass. Type inferencing on the branch pivot is not ;; currently effective mostly because they are frequently not ;; available on the first pass e.g. with atomic integer types. ;; Several GCL programs nest tagbodys very deeply (e.g. axiom/fricas), ;; so even a single extra iteration can be exponentially expensive. (defun bbump-tp (tp) (cond ((car (member tp '(#tnull #t(and fixnum (integer 1)) #t(and fixnum (integer 0)) #t(or null (and fixnum (integer 1))) #t(or null (and fixnum (integer 0)))) :test 'type<=))) ((discrete-tp tp) tp) ((bump-tp tp)))) (defun cln (x &optional (i 0)) (if (atom x) i (cln (cdr x) (1+ i)))) (defun new-type-p (a b) (cond ((binding-p a) nil);;FIXME ???? ((binding-p b) nil) ((eql a b) nil) ((atom a)) ((atom b)) ((or (new-type-p (car a) (car b)) (new-type-p (cdr a) (cdr b)))))) (defun tm (a b &aux (ca (cons-count a))) (when (< ca (if (< ca (cons-count b)) 50 32));FIXME, catch si::+array-typep-alist+ (new-type-p a b))) ;; (defun arg-types-match (tps sir &optional ctp) ;; (if tps ;; (and (= (length tps) (length sir));FIXME unroll strategy ;; (every (lambda (x y) ;; (or (type>= x y) ;; (and (type>= #tinteger x) (type>= #tinteger y)) ;; (when ctp ;; (let ((ax (car (atomic-tp x)))(ay (car (atomic-tp y)))) ;; (when (consp ay) ;(setq aax ax aay ay) ;(print (list aax aay))(break) ;; (not ;; (tm ay ax) ;; ; (when (and (consp ax) (<= (length ax) 15)) (tailp ay ax)) ;; )))))) tps sir)) ;; (not (member-if 'atomic-tp sir)))) ;; (defun top-tagged-sir (sir &aux tagged-sir) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tagged-sir x)))) ;; *src-inline-recursion*) ;; tagged-sir) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) ;; (p (member n *src-inline-recursion* :key 'caar))) ;; (when p ;; (when (or (arg-types-match (cdaar p) tp) ;; (member-if (lambda (x) (when (eq n (caar x)) (arg-types-match (cdar x) tp t))) (cdr p))) ;; (let ((tagged-sir (unless (or (tail-recursion-possible f) (member-if 'atomic-tp tp)) ;; (top-tagged-sir sir)))) ;; (if tagged-sir ;; (throw tagged-sir *src-inline-recursion*) ;; t))))) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; (let ((p (member-if (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp (prog1 sub (setq sub t)))))) ;; *src-inline-recursion*))) ;; (when p ;; (cond ((tail-recursion-possible f) t) ;; ((member-if 'atomic-tp tp) t) ;; ((throw (car p) *src-inline-recursion*)))))) ;; (defun arg-types-match (tps sir &optional ctp) ;; (if t;tps ;; (and (= (length tps) (length sir));FIXME unroll strategy ;; (every (lambda (x y) ;; (or (si::type= x y) ;; (and (type>= #tinteger x) (type>= #tinteger y)) ;; ;; (when ctp ;; ;; (let ((ax (car (atomic-tp x)))(ay (car (atomic-tp y)))) ;; ;; (when (consp ay) ;(setq aax ax aay ay) ;(print (list aax aay))(break) ;; ;; (not ;; ;; (tm ay ax) ;; ;; ; (when (and (consp ax) (<= (length ax) 15)) (tailp ay ax)) ;; ;; )))) ;; )) tps sir)) ;; (progn (break "foo")(not (member-if 'atomic-tp sir))))) ;; (defun too-complicated-p (sir) ;; (> ;; (max (count (car sir) *src-inline-recursion* :key 'caar) ;; (reduce (lambda (y x &aux (x (car (atomic-tp x)))) ;; (max y (if (listp x) (length x) 0))) ;; (cdr sir) :initial-value 0)) ;; 20)) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; ; (print (list n (count n *src-inline-recursion* :key 'caar))) ;; ;; (let ((x (mapcan (lambda (x) (when (consp x) (list x (length x)))) ;; ;; (remove nil (mapcar (lambda (x) (car (atomic-tp x))) tp))))) ;; ;; (when x (print x))) ;; (let* ((p (member-if (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp)))); (prog1 sub (setq sub t)) ;; *src-inline-recursion*)) ;; (ts (top-tagged-sir sir)) ;; (c (when ts (when (too-complicated-p sir) (list ts)))) ;; ; (c (when ts (when (member-if 'complicated-cons-type-p tp) (list ts)))) ;; (p (or p c))) ;; (when p ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ((unless c (member-if 'atomic-tp tp)) (break "bar") t) ;; ((throw (car p) *src-inline-recursion*)))))) ;; (defun arg-types-match (tps sir) ;; (and (= (length tps) (length sir)) ;; (every (lambda (x y) ;; (or (si::type= x y) ;; (and (type>= #tinteger x) (type>= #tinteger y)))) ;; tps sir))) ;; (defun too-complicated-p (sir) ;; (mapc (lambda (x) (when (eq (car sir) (caar x)) ;; (when (cddr x) ;; (when (some (lambda (x y &aux (x (car (atomic-tp x)))(y (car (atomic-tp y)))) ;; (and (consp x) (consp y) (tailp x y) (> (length y) 20))) ;; (cdr sir) (cdar x)) ;; ; (print sir)(break) ;; (return-from too-complicated-p t))))) ;; *src-inline-recursion*) ;; (> ;; (count (car sir) *src-inline-recursion* :key 'caar) ;; 20)) ;; (defun top-tagged-sir (sir &aux tagged-sir tts) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tts tagged-sir tagged-sir x)))) ;; *src-inline-recursion*) ;; tagged-sir) ;; (defun top-tagged-sir (sir &aux tagged-sir tts) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tts tagged-sir tagged-sir x)))) ;; *src-inline-recursion*) ;; tts) ;; (defun top-tagged-sir (sir &aux tagged-sir tts) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq tts tagged-sir tagged-sir x)))) ;; *src-inline-recursion*) ;; (if (member-if 'atomic-tp tagged-sir) tts tagged-sir)) ;; (defun top-tagged-sir (sir &aux last-tagged-sir penultimate-tagged-sir) ;; (mapc (lambda (x) ;; (when (eq (caar x) (car sir)) ;; (when (cdddr x) ;; (setq penultimate-tagged-sir last-tagged-sir last-tagged-sir x)))) ;; *src-inline-recursion*) ;; (or (unless (member-if 'atomic-tp (cdr last-tagged-sir)) last-tagged-sir) ;; penultimate-tagged-sir)) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; (let* ((p (member-if (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp)))) ;; *src-inline-recursion*)) ;; (ts (top-tagged-sir sir)) ;; (c (when ts (when (too-complicated-p sir) (list ts)))) ;; (p (or p c))) ;; (when p ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ((unless c (member-if 'atomic-tp tp)) t) ;; ((throw (car p) *src-inline-recursion*)))))) ;; (defun last-or-penultimate (sir filter &aux (n (car sir)) last penultimate) ;; (mapc (lambda (x) (when (and (eq n (caar x)) (cdddr x) (funcall filter x)) ;; (setq penultimate last last x))) ;; *src-inline-recursion*) ;; (or last ;(unless (member-if 'atomic-tp last) last) ;inline at least one of these ;; penultimate)) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) sub) ;; (let* ((p (last-or-penultimate sir (lambda (x) (arg-types-match (cdar x) tp)))) ;; (c (unless p ;; (when (too-complicated-p sir) ;; (last-or-penultimate sir 'identity)))) ;; (p (or p c))) ;; (when p ;; (or (unless c (tail-recursion-possible f)) ;; (unless c (member-if 'atomic-tp tp)) ;; (throw p *src-inline-recursion*))))) ;; (defun top-tagged-sir (sir &aux last penul) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq penul last last x)))) ;; *src-inline-recursion*) ;; (cond ((member-if 'atomic-tp (car last)) penul) ;; ((eql (length (car last)) (length (car penul))) last);types t? ;; (penul))) ;; (defun top-tagged-sir (sir &aux last penul) ;; (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (setq penul last last x)))) ;; *src-inline-recursion*) ;; (cond ;((member-if 'atomic-tp (car last)) penul) ;; ;((eql (length (car last)) (length (car penul))) last);types t? ;; (penul))) ;; (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp))) ;; (let* ((p (car (member-if ;; (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp)))) ;; *src-inline-recursion*))) ;; (c (unless p (when (too-complicated-p sir) (top-tagged-sir sir)))) ;; (p (or p c))) ;; (when p ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ((unless c (member-if 'atomic-tp tp)) t) ;; ((throw p *src-inline-recursion*)))))) (defvar *src-loop-unroll-limit* 20) (defun arg-types-match (tps sir) (and (= (length tps) (length sir)) (every (lambda (x y) (or (type= x y) (and (type>= #tinteger x) (type>= #tinteger y)) (let ((cx (car (atomic-tp x)))(cy (car (atomic-tp y)))) (and (consp cx) (consp cy) (if (tailp cy cx) (> (labels ((l (x i) (if (consp x) (l (cdr x) (1+ i)) i))) (l cx 0)) *src-loop-unroll-limit*) (tailp cx cy)))))) tps sir))) (defun prior-inline-similar-types (n tp) (car (member-if (lambda (x) (when (eq n (caar x)) (when (cdddr x) (arg-types-match (cdar x) tp)))) *src-inline-recursion*))) (defun inline-too-complex (sir list &aux (i 0) last penul) (mapc (lambda (x) (when (eq (caar x) (car sir)) (when (cdddr x) (incf i) (setq penul last last x)))) list) (when (> i *src-loop-unroll-limit*) (let ((p (cond ;(last) ((member-if 'atomic-tp (cdar last)) penul) ((eql (length (car last)) (length (car penul))) last);types t? (penul)))) (if p (throw p list) t)))) (defun prev-sir (sir &aux (f (name-sir sir))(tp sir)(n (pop tp)) p) (cond ((setq p (prior-inline-similar-types n tp)) (or (tail-recursion-possible f) (throw p *src-inline-recursion*))) ((inline-too-complex sir *src-inline-recursion*)) ((inline-too-complex sir *prev-sri*)))) ;; (let* ((p (car (member-if ;; (lambda (x) ;; (when (eq n (caar x)) ;; (when (cdddr x) ;; (arg-types-match (cdar x) tp t)))) ;; *src-inline-recursion*))) ;; ; (p (when p (or (top-tagged-sir sir) p)));ldiff ;; (c (unless p (when (too-complicated-p sir) (top-tagged-sir sir)))) ;; (p (or p c))) ;; (when p ;; ;; (print (list n (caar c) (count (car sir) *src-inline-recursion* :key 'caar) (length *src-inline-recursion*) ;; ;; (or (unless c (tail-recursion-possible f)) (unless c (member-if 'atomic-tp tp))) )) ;; (cond ((unless c (tail-recursion-possible f)) t) ;; ; ((unless c (member-if 'atomic-tp tp)) t) ;; ((throw p *src-inline-recursion*)))))) (defun make-tagged-sir (sir tag ll &optional (ttag nil ttag-p)) (list* sir tag ll (when ttag-p (list ttag)))) (defun maybe-cons-tagged-sir (tagged-sir src env &aux (id (name-sir (car tagged-sir)))) (cond ((and (eq src (local-fun-src id)) (not (let ((*funs* (if env (fifth env) *funs*)));FIXME? (eq src (local-fun-src id))))); flet not labels *src-inline-recursion*) ((cons tagged-sir *src-inline-recursion*)))) (defun maybe-cons-sir (sir tag ttag src env &aux (id (name-sir sir))) (cond ((and (eq src (local-fun-src id)) (not (let ((*funs* (if env (fifth env) *funs*)));FIXME? (eq src (local-fun-src id))))) *src-inline-recursion*) ((cons (list sir tag (cadr src) ttag) *src-inline-recursion*)))) (defun sir-name (id) (cond ((local-fun-p id)) ((symbolp id) id) ((alloc-spice))));FIXME, do not push anonymous? (defun name-sir (sir &aux (f (car sir))) (if (fun-p f) (fun-name f) f)) (defun infer-tp-p (f) (cond ((eq f 'infer-tp)) ((atom f) nil) ((or (infer-tp-p (car f)) (infer-tp-p (cdr f)))))) (defun cons-count (f) (cond ((atom f) 0) ((+ 1 (cons-count (car f)) (cons-count (cdr f)))))) (defun type-fm (fun fms) (case fun ((si::tpi typep coerce) (cadr fms)) (si::num-comp (caddr fms)) (make-sequence (car fms)))) (defun constant-type-p (tp) (typecase tp (symbol t) (binding nil) (atom t) (cons (and (constant-type-p (car tp)) (constant-type-p (cdr tp)))))) (defun known-type-p (fm) (let ((tp (atomic-tp (info-type (cadr fm))))) (when tp (constant-type-p (car tp))))) (defun maybe-inline-src (fun fms src &aux fm) (when src (cond ((member fun *inline*)) ((setq fm (type-fm fun fms)) (known-type-p fm)) ((member fun '(row-major-aref si::row-major-aset si::row-major-aref-int si::set-array array-element-type si::0-byte-array-self si::set-0-byte-array-self));FIXME (flet ((tst (tp) (not (or (type>= tp #tarray) (type>= tp #tvector))))) (tst (info-type (if (eq fun 'si::row-major-aset) (cadadr fms) (cadar fms)))))) ; ((< (cons-count src) 30)) ((not (symbolp fun))) ((let* ((n (symbol-package fun))(n (when n (package-name n)))(p (find-package :lib))) (when n (or (when p (find-symbol n p)) (string-equal "CSTRUCT" n)))));FIXME ((local-fun-p fun)) ((intersection-p '(&key &rest) (cadr src))) ((member-if-not (lambda (x) (type>= (car x) (cdr x))) (mapcar (lambda (x y) (cons (info-type (cadr x)) (coerce-to-one-value y))) fms (get-arg-types fun)))) ((when (exit-to-fmla-p) (infer-tp-p src))) ((< (cons-count src) 50)))));100 (dolist (l '(upgraded-array-element-type row-major-aref row-major-aset si::set-array array-element-type)) (setf (get l 'consider-inline) t)) ;; (defun maybe-inline-src (fun fms src) ;; (when src ;; (or ;; (not (symbolp fun)) ;; (inline-asserted fun) ;; (not (get fun 'consider-inline)) ;; (let* ((y (get-arg-types fun)) ;; (y (or (car y) #tt)) ;; (y (if (eq y '*) #tt y)) ;; (x (info-type (cadar fms))) ;; (x (if (eq x #tvector) #tarray x)) ;; (x (if (or (type>= #tarray x) (atomic-tp x)) x #tt)));FIXME ;; (not (type>= x y)))))) (defun mi3a (env fun fms) (under-env env (let ((src (inline-src fun))) (when (maybe-inline-src fun fms src) src)))) (defun mi3 (fun args la fms ttag envl inls &aux (src (mi3a (pop envl) fun fms)) (env (car envl))) (when src (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms)))) (unless (prev-sir sir) (let* ((tag (make-ttl-tag));(tmpsym) (tsrc (ttl-tag-src src tag)) (tagged-sir (make-tagged-sir sir tag (cadr src) ttag)) (*src-inline-recursion* (maybe-cons-tagged-sir tagged-sir src env)) (*top-level-src-p* (member src *top-level-src*))) (catch tagged-sir (mi4 fun args la tsrc env inls))))))) (defun mod-env (e l) (setq *lexical-env-mask* (nconc (remove-if (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) *lexical-env-mask*));FIXME l) (defvar *lexical-env-mask* nil) (defmacro under-env (env &rest forms &aux (e (tmpsym))) `(let* ((,e ,env) (*lexical-env-mask* (pop ,e)) (*vars* (mod-env (pop ,e) *vars*)) (*blocks* (mod-env (pop ,e) *blocks*)) (*tags* (mod-env (pop ,e) *tags*)) (*funs* (mod-env (pop ,e) *funs*))) ,@forms)) (defun barrier-cross-p (fun &aux (f (local-fun-p fun))) (not (tailp (member-if-not 'fun-p *funs*) (member f *funs*)))) (defun tail-recursion-possible (fun &aux (f (assoc fun *c1exit*))) (when f (unless (barrier-cross-p fun) (do ((l *vars* (cdr l))(e (caddr f))) ((eq l e) t) (let ((v (car l))) (when (var-p v) (unless (eq 'lexical (var-kind v)) (unless (member v *lexical-env-mask*) (return nil))))))))) (defun mi2 (fun args la fms envl) (let* ((sir (cll fun)) (tag (cadr sir)) (targs (if la (append args (list la)) args)) (inls (mapcar 'cons targs fms)) (inl (mi3 fun args la fms tag envl inls))) (cond ((info-p (cadr inl)) (keyed-cmpnote (list 'inline (if (fun-p fun) (fun-name fun) fun)) "inlining ~s ~s ~s" fun (mapcar (lambda (x) (info-type (cadr x))) fms) la) inl) (inl (setq inl (mapcar (lambda (x) (name-sir (car x))) (ldiff inl *src-inline-recursion*))) (keyed-cmpnote (list* 'inline 'inline-abort inl) "aborting inline of ~s" inl) (setq *notinline* (nunion inl *notinline*));FIXME too extreme? nil) ((and sir (tail-recursion-possible fun)) (keyed-cmpnote (list 'tail-recursion fun) "tail recursive call to ~s replaced with iteration" fun) (c1let-* (cdr (blla-recur tag (caddr sir) args la)) t inls))))) ;; (defun mi2 (fun args la fms envl) ;; (let* ((sir (cll fun)) ;; (tag (cadr sir)) ;; (targs (if la (append args (list la)) args)) ;; (*inline-forms* (mapcar 'cons targs fms)) ;; (inl (mi3 fun args la fms tag envl))) ;; (cond (inl ;; (mapc (lambda (x) (add-info (cadr inl) (cadr x))) fms);FIXME ;; (when (eq (car (fifth inl)) 'let*) ;; (setf (cadr (fifth inl)) (copy-info (cadr inl)))) ;; (keyed-cmpnote (list 'inline fun) "inlining ~s ~s ~s" fun args la) ;; inl) ;; ((and sir (member fun *c1exit*)) ;; (keyed-cmpnote (list 'tail-recursion fun) ;; "tail recursive call to ~s replaced with iteration" fun) ;; (c1expr (blla-recur tag (caddr sir) args la)))))) ;; (defun mi2 (fun args la fms envl) ;; (let* ((sir (cll fun)) ;; (tag (cadr sir)) ;; (targs (if la (append args (list la)) args)) ;; (*inline-forms* (mapcar 'cons targs fms)) ;; (inl (mi3 fun args la fms tag envl))) ;; (cond (inl ;; (mapc (lambda (x) (add-info (cadr inl) (cadr x))) fms);FIXME ;; (when (eq (car (fifth inl)) 'let*) ;; (setf (cadr (fifth inl)) (copy-info (cadr inl)))) ;; (keyed-cmpnote (list 'inline fun) "inlining ~s ~s ~s" fun args la) ;; inl) ;; ((and sir (member fun *c1exit*)) ;; (keyed-cmpnote (list 'tail-recursion fun) ;; "tail recursive call to ~s replaced with iteration" fun) ;; (c1expr (blla-recur tag (caddr sir) args la)))))) ;(defvar *provisional-inline* nil) (defun make-c1forms (fn args last info) (let* ((at (get-arg-types fn)) (nargs (c1args args info)) (c1l (when last (c1arg last info))) (nargs (if (when last (not (type>= #tnull (info-type (cadr c1l))))) (progn (add-info info (cadr c1l)) (nconc nargs (list c1l))) nargs)) (nat (mapcar (lambda (x) (info-type (cadr x))) nargs)) (ss (gethash fn *sigs*));FIXME? (at (if (and ss (not (car ss))) nat at))) (mapc (lambda (x) (setf (info-type (cadr x)) (coerce-to-one-value (info-type (cadr x))))) nargs) (unless (or last (local-fun-p fn) (eq fn (when (consp *current-form*) (cadr *current-form*))));FIXME (let* (p (m (do ((a at (if (eq (car a) '*) a (cdr a))) (r args (cdr r)) (f nargs (cdr f))) ((or (endp f) (endp a)) (or f (and a (not (eq (car a) '*))))) (unless (or (eq '* (car a)) (type-and (car a) (info-type (cadar f)))) (setq p t))))) (when m (funcall (if (eq (symbol-package fn) #.(find-package 'cl)) 'cmpwarn 'cmpstyle-warn) "Wrong number of args in call to ~s:~% ~a ~a ~a~%" fn (cons fn args) (mapcar 'cmp-unnorm-tp at) (mapcar 'cmp-unnorm-tp nat))) (when p (keyed-cmpnote (list fn 'inline) "inlining of ~a prevented due to argument type mismatch:~% ~a ~a ~a~%" fn (cons fn args) (mapcar 'cmp-unnorm-tp at) (mapcar 'cmp-unnorm-tp nat))) (when (or p m) (setf (info-type info) nil)))) (do ((a at (if (eq '* (car a)) a (cdr a))) (r args (cdr r)) (f (if last (butlast nargs) nargs) (cdr f))) ((or (endp f) (endp a)) nargs) (maybe-reverse-type-prop (car a) (car f))))) (defun make-ordinary (fn &aux *c1exit*);FIXME *c1exit* (let* ((s (sgen "ORDS"))(g (sgen "ORDG")) (e (c1let-* `(((,s ,g)) ;(check-type ,s (not list)) FIXME bootstrap (if (functionp ,s) ,s (funcallable-symbol-function ,s)) ; (coerce ,s 'function) ) t (list (cons g fn)))); (coerce ,s 'function) ; (e (c1let-* `(((,s ,g)) (etypecase ,s ((and symbol (not boolean)) (fsf ,s)) (function ,s))) t (list (cons g fn)))); (coerce ,s 'function) (info (make-info))) (add-info info (cadr e)) (list 'ordinary info e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (e (c1let-* `(((,s ,g)) (etypecase ,s (symbol (fsf ,s)) (function ,s))) t (list (cons g fn)))) ;; (info (make-info))) ;; (add-info info (cadr e)) ;; (list 'ordinary info e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (e (c1let-* `(((,s ,g)) (etypecase ,s (symbol (fsf ,s)) (function ,s))) t nil (list (cons g fn)))) ;; (info (make-info))) ;; (add-info info (cadr e)) ;; (list 'ordinary info e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (*inline-forms* (list (cons g fn))) ;; (e (c1expr `(let* ((,s ,g)) (etypecase ,s (symbol (fsf ,s)) (function ,s)))))) ;; (list 'ordinary (cadr e) e))) ;; (defun make-ordinary (fn) ;; (let* ((s (tmpsym))(g (tmpsym)) ;; (*inline-forms* (list (cons g fn))) ;; (e (c1expr `(let* ((,s ,g)) (if (symbolp ,s) (fsf ,s) ,s))))) ;; (list 'ordinary (cadr e) e))) ;; (defun or-ccb-assignments (fms) ;; (mapc (lambda (v) ;; (when (var-p v) ;; (let ((tp (get (var-store v) 'ccb-tp)));FIXME setq tp nil? ;; (when tp ;; (do-setq-tp v '(ccb-ref) (type-or1 (var-type v) (get (var-store v) 'ccb-tp))) ;; (setf (var-store v) +opaque+))))) *vars*)) (defun bump-cons-tp (tp &aux (c (type-and tp #tcons))(p (type-and tp #tproper-cons))) (type-or1 tp (if (type>= p c) #tproper-cons #tcons))) (defun do-ccb-ch (ccb-ch) (mapc (lambda (x &aux (v (pop x))) (do-setq-tp v '(ccb-ch) (type-or1 (var-type v) (bump-cons-tp (info-type (cadr x))))) (push-vbind v x t)) ccb-ch)) (defun or-ccb-assignments (fms) (mapc (lambda (x) (do-ccb-ch (info-ch-ccb (cadr x)))) fms)) (defun mi6 (fn fms) (or-ccb-assignments fms) (unless (and (symbolp fn) (get fn 'c1no-side-effects)) (dolist (f fms) (when (and (consp f) (eq (car f) 'var)) (let* ((ft (info-type (cadr f))) (p (when (and ft (type>= #tcons ft)) #tcons)) (p (when (and p (type>= #tproper-cons ft)) #tproper-cons))) (when (and p (not (type>= ft p))) (bump-pcons (caaddr f) p))))))) ;; (defun mi6 (fn fms) ;; (unless (and (symbolp fn) (get fn 'c1no-side-effects)) ;; (dolist (f fms) ;; (when (and (consp f) (eq (car f) 'var)) ;; (let* ((ft (info-type (cadr f))) ;; (p (when (and ft (type>= #tcons ft)) #tcons)) ;; (p (when (and p (type>= #tproper-cons ft)) #tproper-cons))) ;; (when (and p (not (type>= ft p))) ;; (bump-pcons (caaddr f) p))))))) (defun binding-forms (st) (mapcan (lambda (x &aux (z (binding-form x))) (when z (list z))) st)) (defun global-var-stores (&aux z) (reduce (lambda (y x) (or-binds (when (var-p x) (unless (eq (var-kind x) 'lexical) (var-store x))) y)) *vars* :initial-value z)) (defun mi5 (fn info fms la &aux (ll (when la (list (length fms)))) fd) (when (iflag-p (info-flags info) side-effects) (c1side-effects nil)) (mi6 fn fms) (let ((r (assoc fn *recursion-detected*))) (when r (setf (cdr r) t))) (cond ((consp fn) (let ((ord (make-ordinary fn))) (add-info info (cadr ord)) (or-ccb-assignments (list fn)) `(,(if la 'apply 'funcall) ,info ,ord ,fms))) ((setq fd (c1local-fun fn)) (add-info info (cadr fd)) (setf (info-type info) (info-type (cadr fd))) (let ((fm (fifth fd))) (when fm (or-ccb-assignments (list fm))) `(call-local ,info ,(nconc (caddr fd) ll) ,(cadddr fd) ,fm ,fms)));FIXME (t (or-ccb-assignments (binding-forms (global-var-stores))) (push fn (info-ref info)) `(call-global ,info ,fn ,fms nil ,@ll)))) ;; (defun mi5 (fn info fms la &aux (ll (when la (list (length fms)))) fd) ;; (mi6 fn fms) ;; (when (eq fn (cadr *current-form*)) (setq *recursion-detected* t)) ;; (cond ((consp fn) ;; (let ((ord (make-ordinary fn))) ;; (add-info info (cadr ord)) ;; `(,(if la 'apply 'funcall) ,info ,ord ,fms))) ;; ((setq fd (c1local-fun fn)) ;; (add-info info (cadr fd)) ;; (setf (info-type info) (if (eq (info-type (cadr fd)) 'boolean) #tboolean (info-type (cadr fd))));FIXME ;; `(call-local ,info ,(nconc (caddr fd) ll) ,(cadddr fd) ,(fifth fd) ,fms));FIXME ;; (`(call-global ,info ,fn ,fms nil ,@ll)))) ;; (defun mi5 (fn info fms la ;; &aux (nlast (when la (type>= #tnull (info-type (cadr (car (last fms))))))) ;; (fms (if nlast (butlast fms) fms)) ;; (la (unless nlast la)) ;; (ll (when la (list (length fms))))) ;; (mi6 fn fms) ;; (when (eq fn (cadr *current-form*)) (setq *recursion-detected* t)) ;; (cond ((consp fn) `(,(if la 'apply 'funcall) ,info ,(make-ordinary fn) ,fms)) ;; ((let ((fd (c1local-fun fn))) ;; (when fd ;; (add-info info (cadr fd)) ;; (setf (info-type info) (if (eq (info-type (cadr fd)) 'boolean) #tboolean (info-type (cadr fd)))) ;; `(call-local ,info ,(append (caddr fd) ll) ,fms)))) ;; (`(call-global ,info ,fn ,fms nil ,@ll)))) ;; (defun mi5 (fn info fms la &aux (ll (when la (list (length fms))))) ;; (mi6 fn fms) ;; (when (eq fn (cadr *current-form*)) (setq *recursion-detected* t)) ;; (cond ((consp fn) `(,(if la 'apply 'funcall) ,info ,(make-ordinary fn) ,fms)) ;; ((let ((fd (c1local-fun fn))) ;; (when fd ;; (add-info info (cadr fd)) ;; (setf (info-type info) (if (eq (info-type (cadr fd)) 'boolean) #tboolean (info-type (cadr fd)))) ;; `(call-local ,info ,(append (caddr fd) ll) ,fms)))) ;; (`(call-global ,info ,fn ,fms nil ,@ll)))) ;; Objects when read are not eql (declaim (inline unreadable-individual-p)) (defun unreadable-individual-p (x) (typecase x (number)(symbol (not (symbol-package x)))(otherwise t))) (defun bump-unreadable-individuals (tp) (bump-individuals 'unreadable-individual-p tp)) (defun type-from-args (fun fms last info &aux x) (when (symbolp fun) (unless (get fun 'c1no-side-effects) (setf (info-flags info) (logior (info-flags info) (iflags side-effects)))));FIXME (cond ((setq x (member-if-not 'identity fms :key (lambda (x) (info-type (cadr x))))) (keyed-cmpnote (list fun 'nil-arg) "Setting return type on call to ~s to nil due to nil-typed form:~%~s" fun x) (setf (info-type info) nil)) (last) ((and (symbolp fun) (not (local-fun-p fun))) (let ((tp (result-type-from-args fun (mapcar (lambda (x) (info-type (cadr x))) fms)))) (when tp (setf (info-type info) (type-and (info-type info) tp)))))) ;;FIXME inline functions from source with static data ;; (when (unreadable-individuals-p (info-type info)) ;; (keyed-cmpnote (list fun 'unreadable-individuals) ;; "~<;; ~@;Setting return type on call to ~s to nil due to unreadable individuals in~%~s~;~:>" ;; (list fun (cmp-unnorm-tp (info-type info)))) ;; (setf (info-type info) nil)) (info-type info)) (defun coerce-ff (ff) (coerce-to-funid (car (atomic-tp (info-type (cadr ff))))));(when (member (car ff) '(foo location var)) )) (defun coerce-to-local-fn (ob) (if (functionp ob) ob (local-fun-fn ob))) (defun ff-env (ff) (cond ((not ff) nil) ((symbolp ff) (ff-env (local-fun-fn ff))) ((consp ff) (let ((x (car (atomic-tp (info-type (cadr ff)))))) (unless (consp x) (ff-env x))));FIXME ((functionp ff) (list (or (fn-get ff 'ce) (current-env)) (fn-get ff 'df))))) ;; (let* ((fn (when ff (coerce-to-local-fn (car (atomic-tp (info-type (cadr ff)))))))) ;; (when fn ;; (let* ((ce (fn-get fn 'ce)) ;; (df (fn-get fn 'df))) ;; (list ce df))))) ;; (defun ff-env (ff) ;; (when ff ;; (values (gethash (coerce-to-local-fn (car (atomic-tp (info-type (cadr ff))))) *fun-ev-hash*)))) ;; (defun coerce-to-local-fun (ob) ;; (if (functionp ob) ob (local-fun-fun ob))) ;; (defun ff-env (ff) ;; (when ff ;; (gethash (coerce-to-local-fun (car (atomic-tp (info-type (cadr ff))))) *fun-ev-hash*))) ;; (case (car ff) ;; (location (gethash (local-fun-fun (car (atomic-tp (info-type (cadr ff))))) *fun-ev-hash*)) ;; (foo (gethash (car (atomic-tp (info-type (cadr ff)))) *fun-ev-hash*)))) ; (when (member (car ff) '(foo location)) (gethash (car (atomic-tp (info-type (cadr ff)))) *fun-ev-hash*))) (defun mi1c (fun args last info &optional ff prov &aux (*prov* prov)) (let* ((otp (info-type info)) (fms (make-c1forms fun args last info)) (last (when (and last (nth (length args) fms)) last)) (tp (type-from-args fun fms last info))) (or (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun)))) (when (member-if-not 'identity fms :key (lambda (x) (info-type (cadr x)))) (c1progn args fms)) (mi5 (or (when (symbolp fun) fun) ff) info fms last)))) (defvar *prov-src* nil) (defun mi1b (fun args last info &optional ff &aux (ops *prov-src*)(*prov-src* *prov-src*)) (with-restore-vars (let ((res (mi1c fun args last info ff t))) (cond ((iflag-p (info-flags (cadr res)) provisional) (keyed-cmpnote 'provisional "~s has provisional functions, res address ~s" fun (address res))) (t (keep-vars) (mapc 'eliminate-src (ldiff *prov-src* ops)) res))))) (defun mi1a (fun args last info &optional ff &aux (i1 (copy-info info)));FIXME side-effects on info (or (mi1b fun args last info ff) (prog1 (mi1c fun args last i1 ff) (setf (info-type info) (info-type i1))))) (defun current-env nil (list *lexical-env-mask* *vars* *blocks* *tags* *funs*)) (defun mi1 (fn args &optional last ff) (let* ((tp (get-return-type fn)) (sp (if (when (symbolp fn) (get fn 'no-sp-change)) 0 1)) (info (make-info :type (bump-unreadable-individuals tp) :flags (if sp (iflags sp-change) 0))) (res (mi1a fn args last info ff))) (when tp (let ((t1 (info-type (cadr res)))(t2 (info-type info))) (when (exit-to-fmla-p) (labels ((tb (tp) (type-or1 (when (type-and #tnull tp) #tnull) (when (type-and #t(not null) tp) #ttrue)))) (setq t1 (tb t1) t2 (tb t2) tp (tb tp)))) (setf (info-type (cadr res)) (type-and t1 (if (type= t1 t2) tp t2))))) res)) (defun local-fun-obj (fname) (typecase fname (function (fn-get fname 'fun)) (fun fname) (symbol (car (member-if (lambda (x) (when (fun-p x) (unless (member x *lexical-env-mask*) (eq fname (fun-name x))))) *funs*))))) (defun local-fun-p (fname &aux (fun (local-fun-obj fname))) (when (and fun (fun-src fun)) fun)) (defun local-macro-p (fname &aux (fun (local-fun-obj fname))) (when fun (unless (fun-src fun) fun))) (defun funs-to-macrolet-env nil `(nil ,(mapcan (lambda (x) (when (fun-p x) (unless (member x *lexical-env-mask*) `(,(if (fun-src x) `(,(fun-name x) function ,(lambda (&rest r) (declare (ignore r)) nil)) `(,(fun-name x) macro ,(fun-fn x))))))) *funs*) nil)) (defun c1symbol-fun (whole &aux (fname (car whole)) (args (cdr whole)) fd) (values (cond ((setq fd (get fname 'c1special)) (funcall fd args)) ((and (setq fd (get fname 'co1special)) (funcall fd fname args))) ((setq fd (local-macro-p fname)) (c1expr (cmp-expand-macro-w (fun-fn fd) whole))) ((local-fun-p fname) (mi1 fname args)) ((unless (member fname *notinline*) (let* ((fn (compiler-macro-function fname)) (res (if fn (funcall fn whole nil) whole)));FIXME cmp-expand-macro-w? (unless (eq whole res) (c1expr res))))) ((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 'c1g)) (inline-possible fname)) (funcall fd fname args)) ((setq fd (macro-function fname)) (c1expr (cmp-expand-macro-w fd whole))) ((eq fname 'si:|#,|) (cmperr "Sharp-comma-macro was found in a bad place.")) ((mi1 fname args))))) ;; (defun remove-doc-string (body) ;; (nconc (do (d doc) ((or (not body) (if (stringp (car body)) ;; (or (endp (cdr body)) doc) ;; (or (not (consp (car body))) (not (eq 'declare (caar body)))))) ;; (nreverse d)) ;; (let ((x (pop body))) (if (stringp x) (unless doc (push x doc)) (push x d)))) body)) (defun c1funcallable-symbol-function (args &aux a) (let* ((info (make-info :type #tfunction)) (nargs (c1args args info))) (cond ((setq a (atomic-tp (info-type (cadar nargs)))) (c1expr `(function ,(let ((x (coerce-to-funid (car a)))) (if (functionp x) (fn-get x 'id) x))))) ((list 'call-global info 'funcallable-symbol-function nargs))))) (si::putprop 'funcallable-symbol-function 'c1funcallable-symbol-function 'c1) ;; (defun c1lambda-fun (lambda-expr args) ;; (c1expr (blla (car lambda-expr) args nil (cdr lambda-expr)))) (defun c2expr (form) (values (if (eq (car form) 'call-global) (c2call-global (caddr form) (cadddr form) nil (info-type (cadr form)) (sixth 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 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;")) (let* ((cm *reservation-cmacro*) (vstu (if *mv-var* (let ((loc (write-to-string (var-loc *mv-var*)))) (concatenate 'string " if ((b_)>=-1) vs_top=V" loc " ? (object *)V" loc "+(b_) : base;")) " vs_top=base;"))) (wt-h "#define VMRV" cm "(a_,b_)" vstu " return(a_);") (wt-h "#define VMR" cm "(a_) VMRV" cm "(a_,0);")) (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))) ;; ((let ((info (make-info))) ;; (do ((forms forms (cdr forms))) ((not forms)) ;; (let* ((*c1exit* (unless (cdr forms) *c1exit*)) ;; (form (c1expr (car forms)))) ;; (push form fl) ;; (add-info info (cadr form)))) ;; (setf (info-type info) (info-type (cadar fl))) ;; (list 'progn info (nreverse fl)))))) (defun truncate-progn-at-nil-return-p (rp forms c1forms) (when (and rp (not (info-type (cadar rp)))) (keyed-cmpnote 'nil-return "progn truncated at nil return, eliminating ~s" forms) (eliminate-src (cons 'progn (nthcdr (length c1forms) forms))) t)) (defun c1progn (forms &optional c1forms &aux r rp (info (make-info))) (when c1forms (assert (eql (length forms) (length c1forms)))) (flet ((collect (f i) (setq rp (last (if rp (rplacd rp f) (setq r f)))) (add-info info i))) (do ((forms forms (cdr forms))) ((or (not forms) (truncate-progn-at-nil-return-p rp forms c1forms))) (let ((form (or (pop c1forms) (if (cdr forms) (c1arg (car forms)) (c1expr (car forms)))))) (cond ((and (cdr forms) (ignorable-form form))) ((eq (car form) 'progn) (collect (third form) (cadr form))) ((collect (cons form nil) (cadr form)))))) (cond ((cdr r) (setf (info-type info) (info-type (cadar rp))) (list 'progn info r)) ((the list (car r)));FIXME ((c1nil))))) ;;; 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)) (when l (c2expr (car l)))) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr (car l)) (wt-label *exit*)))) (defun c1arg (form &optional (info (make-info)) &aux *c1exit*) (c1expr* form info)) (defun c1args (forms info) (mapcar (lambda (form) (c1arg form info)) forms)) ;; (defun c1args (forms info &aux *c1exit*) ;; (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-and tp (nth aet-type +cmp-array-types+)))) (setf (info-type info) (if (and (eq name 'si::s-data) (= index 2));;FIXME -- this belongs somewhere else. CM 20050106 #t(vector unsigned-char) tp)) (list 'structure-ref info (c1arg form info) name index sd))))) ;; (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-and tp (nth aet-type +cmp-array-types+)))) ;; (setf (info-type info) (if (and (eq name 'si::s-data) (= index 2));;FIXME -- this belongs somewhere else. CM 20050106 ;; #t(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 (nth aet-type +cmp-array-types+))) (cond ((eq (inline-type type) 'inline) (or (= aet-type +aet-type-object+) (error "bad type ~a" type)))) (setf (info-type (car arg)) type) (coerce-loc (list (inline-type type) (flags) 'my-call (list (car (inline-args (list (car form)) '(t))) 'joe index sd)) 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 (nth (aref (si::s-data-raw sd) index) +cmp-array-types+))) (unwind-exit (list (inline-type type) (flags) 'my-call (list loc name-vv index sd)))) (close-inline-blocks) ) (defun c1str-ref (args) (let* ((info (make-info)) (nargs (c1args args info))) (list* 'str-ref info nargs))) (setf (get 'str-ref 'c1) 'c1str-ref) (defun sinline-type (tp);FIXME STREF STSET handled as aref (if (type= tp #tcharacter) 'inline-character (inline-type tp))) (defun c2str-ref (loc nm off) (let* ((nm (car (atomic-tp (info-type (cadr nm))))) (sd (get nm 'si::s-data)) (loc (car (inline-args (list loc) '(t)))) (off (car (atomic-tp (info-type (cadr off)))))) (unless (and off sd (not *compiler-push-events*)) (baboon)) (unwind-exit (list (sinline-type (nth (aref (si::s-data-raw sd) off) +cmp-array-types+));FIXME STREF STSET handled as aref (flags) 'my-call (list loc nil off sd))) (close-inline-blocks))) (setf (get 'str-ref 'c2) 'c2str-ref) (defun my-call (loc name-vv ind sd);FIXME get-inline-loc above (declare (ignore name-vv)) (let* ((raw (si::s-data-raw sd)) (spos (si::s-data-slot-position sd))) (if *compiler-push-events* (wfs-error) (wt "STREF(" (aet-c-type (nth (aref raw ind) +cmp-array-types+) ) "," loc "," (aref spos ind) ")")))) (defun c1structure-set (args &aux (info (make-info :flags (iflags side-effects)))) (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 (c1arg (car args) info)) (sd (get (cadadr args) 'si::s-data)) (raw (si::s-data-raw sd)) (type (nth (aref raw (caddr args)) +cmp-array-types+)) (y (c1arg (if (type= #tcharacter type) `(char-code ,(cadddr args)) (cadddr args)) info)));FIXME STREF STSET handled as aref (setf (info-type info) (info-type (cadr y))) (list 'structure-set info x (cadadr args) ;;; remove QUOTE. (caddr args) y (get (cadadr args) 'si::s-data))) (list 'call-global info 'si:structure-set (c1args args info)))) ;; (defun c1structure-set (args &aux (info (make-info :flags (iflags side-effects)))) ;; (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)) (declare (ignore name-vv)) (let* ((raw (si::s-data-raw sd)) (type (nth (aref raw ind) +cmp-array-types+)) (type (if (type= #tcharacter type) (car (assoc #tchar +c-type-string-alist+ :test 'type=)) type));FIXME STREF STSET handled as aref) (spos (si::s-data-slot-position sd)) (tftype 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 ");");FIXME STREF STSET handled as aref (unwind-exit (list (sinline-type tftype) (flags) 'wt-loc (list iy))) (close-inline-blocks))) (defun sv-wrap (x) `(symbol-value ',x)) (defun infinite-val-symbol (val) (or (car (member val '(+inf -inf nan +sinf -sinf snan) :key 'symbol-value)) (baboon))) (defun printable-long-float (val) (labels ((scl (val s) `(* ,(/ val (symbol-value s)) ,s))) (let ((nval (cond ((not (isfinite val)) `(symbol-value ',(infinite-val-symbol val))) ((> (abs val) (/ most-positive-long-float 2)) (scl val 'most-positive-long-float)) ((< 0.0 (abs val) (* least-positive-normalized-long-float 1.0d20)) (scl val 'least-positive-normalized-long-float))))) (if nval (cons '|#,| nval) val)))) (defun printable-short-float (val) (labels ((scl (val s) `(* ,(/ val (symbol-value s)) ,s))) (let ((nval (cond ((not (isfinite val)) `(symbol-value ',(infinite-val-symbol val))) ((> (abs val) (/ most-positive-short-float 2)) (scl val 'most-positive-short-float)) ((< 0.0 (abs val) (* least-positive-normalized-short-float 1.0d20)) (scl val 'least-positive-normalized-short-float))))) (if nval (cons '|#,| nval) val)))) (defun ltvp (val) (when (consp val) (eq (car val) '|#,|))) (defun c1constant-value-object (val always) (typecase val (char `(char-value nil ,val)) (immfix `(fixnum-value nil ,val)) (character `(character-value nil ,(char-code val))) (long-float `(vv ,(printable-long-float val))) (short-float `(vv ,(printable-short-float val)));FIXME ((or fixnum complex) `(vv ,val)) (otherwise (when (or always (ltvp val)) `(vv ,val))))) (defun c1constant-value (val always &aux (val (if (exit-to-fmla-p) (not (not val)) val))) (case val ((nil) (c1nil)) ((t) (c1t)) (otherwise (let ((l (c1constant-value-object val (or always (when *compiler-compile* (not *keep-gaz*)))))) (when l `(location ,(make-info :type (or (ltvp val) (object-type (typecase val (function (afe (cons 'df nil) (mf (fle val)))) (list (copy-tree val)) (t val))))) ,l)))))) (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 (member 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 co1structure-predicate (f args &aux tem) (cond ((and (symbolp f) (setq tem (get f 'si::struct-predicate)) args (not (cdr args))) (c1expr `(typep ,(car args) ',tem))))) ;;New C ffi ; (defmacro defdlfun ((crt name &optional (lib "")) &rest tps &aux (tsyms (load-time-value (mapl (lambda (x) (setf (car x) (gensym "DEFDLFUN"))) (make-list call-arguments-limit))))) (unless (>= (length tsyms) (length tps)) (baboon)) (flet ((cc (x) (if (consp x) (car x) x))) (let* ((sym (mdlsym name lib)) (dls (strcat "DL" name)) (ttps (mapcan (lambda (x) (if (atom x) (list x) (list (list (car x)) (cadr x)))) tps)) (args (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) ttps)) (cast (apply 'strcat (maplist (lambda (x) (strcat (cc (car x)) (if (cdr x) "," ""))) tps))) (cast (strcat "(" crt "(*)(" cast "))"))) `(defun ,sym ,args (declare (optimize (safety 2))) ,@(mapcar (lambda (x y) `(check-type ,x ,(get (cc y) 'lisp-type))) args ttps) (cadd-dladdress ,dls ,sym) (lit ,crt ,@(when (eq crt :void) `("(")) "(" ,cast "(" ,dls "))(" ,@(mapcon (lambda (x y) `((,(cc (car x)) ,(car y)) ,(if (cdr x) (if (consp (car x)) "+" ",") ""))) ttps args) ")" ,@(when (eq crt :void) `(",Cnil)"))))))) (defun c1cadd-dladdress (args) (list 'cadd-dladdress (make-info :type #tnull) args)) (defun c2cadd-dladdress (args) (apply 'add-dladdress args)) (si::putprop 'cadd-dladdress 'c1cadd-dladdress 'c1) (si::putprop 'cadd-dladdress 'c2cadd-dladdress 'c2) (defun c1clines (args) (list 'clines (make-info :type nil) (with-output-to-string (s) (princ (car args) s)))) (defun c2clines (clines) (wt-nl clines)) (si::putprop 'clines 'c1clines 'c1) (si::putprop 'clines 'c2clines 'c2) ;; (define-compiler-macro typep (&whole form &rest args &aux (info (make-info))(nargs (c1args args info))) ;; (let* ((info (make-info)) ;; (nargs (with-restore-vars (c1args args info))) ;; (tp (info-type (cadar nargs))) ;; (a (atomic-tp (info-type (cadadr nargs)))) ;; (c (cmp-norm-tp (car a)))) ;; (if (when a (constant-type-p (car a))) ;; (cond ((type>= c tp) (print (list c tp t)) t) ;; ((not (type-and c tp)) (print (list c tp nil)) nil) ;; (form));FIXME hash here ;; form))) (define-compiler-macro fset (&whole form &rest args) (when *sig-discovery* (let* ((info (make-info)) (nargs (with-restore-vars (c1args args info))) (ff (cadr nargs)) (fun (when (eq (car ff) 'function) (caaddr ff))) (fun (when (fun-p fun) fun)) (sym (car (atomic-tp (info-type (cadar nargs)))))) (when (and sym fun);FIXME (push (cons sym (apply 'si::make-function-plist (fun-call fun))) si::*sig-discovery-props*)))) form) (define-compiler-macro typep (&whole form &rest args);FIXME compiler-in-use (with-restore-vars (let* ((info (make-info)) (nargs (c1args args info)) (tp (info-type (cadar nargs))) (a (atomic-tp (info-type (cadadr nargs)))) (c (if (when a (constant-type-p (car a))) (cmp-norm-tp (car a)) '*))) (cond ((eq c '*) form) ((member-if-not 'ignorable-form nargs) form) ((type>= c tp) (keep-vars) t) ((not (type-and c tp)) (keep-vars) nil) ((when (consp (car a)) (eq (caar a) 'or)) `(typecase ,(car args) (,(car a) t))) (form)))));FIXME hash here (define-compiler-macro vector-push-extend (&whole form &rest args);FIXME compiler-in-use (let* ((vref (when (symbolp (cadr args)) (c1vref (cadr args))));FIXME local-aliases (var (car vref))) (when vref (do-setq-tp var form (reduce (lambda (y x) (if (type-and y x) (type-or1 y x) y)) '#.(mapcar (lambda (x) (cmp-norm-tp `(,(cdr x) 1))) si::*all-array-types*) :initial-value (var-type var))))) form) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmptag.lsp0000644000000000000000000000013114774225213015463 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.472939196 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmptag.lsp0000644000175000017500000004253214774225213015070 0ustar00cammcamm;;; CMPTAG Tagbody and Go. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'tagbody 'c1tagbody 'c1special) (si:putprop 'tagbody 'c2tagbody 'c2) (si:putprop 'go 'c1go 'c1special) (si:putprop 'go 'c2go 'c2) (defstruct (tag (:print-function (lambda (x s i) (s-print 'tag (tag-name x) (si::address x) s)))) 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 ) (si::freeze-defstruct 'tag) (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. (defvar *reg-amount* 60) ;;amount to increase var-register for each variable reference in side a loop (defun add-reg1 (form) (unless (tag-p form) (mapc (lambda (x) (when (var-p x) (incf (var-register x) (the fixnum *reg-amount*)))) (info-ref (cadr form))))) (defun intersection-p (l1 l2) (member-if (lambda (x) (member x l2)) l1)) (setf (get 'intersection-p 'cmp-inline) t) (defun add-loop-registers (tagbody &aux (first (member-if 'tag-p tagbody)) (tags (cons (pop first) (remove-if-not 'tag-p first))) (end first)) (mapl (lambda (x) (unless (tag-p (car x)) (when (intersection-p tags (info-ref (cadar x))) (setf end (cdr x))))) first) (do ((form first (cdr form))) ((eq form end)) (add-reg1 (car form)))) (defun ref-tags (form tags) (ref-obs form tags (lambda (x) (setf (tag-ref-ccb x) t)) (lambda (x) (setf (tag-ref-clb x) t)) (lambda (x) (setf (tag-ref x) t)))) ;FIXME separate pass with no repetitive allocation (defvar *ft* nil) (defvar *bt* nil) (defun tst (y x &aux (z (eq (car x) y))) (unless z (keyed-cmpnote (list 'tagbody-iteration) "Iterating tagbody at ~s ~x on ~s conflicts" (tag-name y) (address y) (length x)) (mapc (lambda (x &aux (v (pop x))) (keyed-cmpnote (list (var-name v) 'tagbody-iteration) " Iterating tagbody: setting ~s type ~s to ~s, store ~s to ~s" v (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp (car x)) (var-store v) (cadr x)) (setf (var-type v) (car x));FIXME do-setq-tp ? (push-vbinds v (cadr x))) x)) (when z x));FIXME return type (defun pt (y x) (or (tst y (with-restore-vars (catch y (prog1 (cons y (pr x)) (keep-vars))))) (pt y x))) ;; (defun pt (y x &optional (ws *warning-note-stack*)) ;; (or (tst y (with-restore-vars (catch y (prog1 (cons y (pr x)) (keep-vars))))) (pt y x (setq *warning-note-stack* ws)))) (defun lvars (&aux (v (member-if-not 'var-p *vars*))) (if v (ldiff *vars* v) *vars*)) (defun mch nil (mapcan (lambda (x) (when (var-p x) `((,x ,(var-type x) ,(var-store x) ,(mcpt (var-type x)))))) *vars*)) (defun or-mch (l &optional b) (mapc (lambda (x &aux (y x)(v (pop x))(tp (pop x))(st (pop x))(m (car x)) (m (unless (equal tp m) m)) (t1 (type-or1 (var-type v) (or m tp)));FIXME check expensive (t1 (if b (type-and (var-dt v) (bbump-tp t1)) t1))) (setf (cadr y) t1 (caddr y) (or-binds (var-store v) st);FIXME union? (cadddr y) (mcpt t1))) l)) (defun mch-set (z l) (mapc (lambda (x) (keyed-cmpnote (list (var-name (car x)) 'tagbody-label) "Initializing ~s at label ~s:~% type from ~s to ~s,~% store from ~s to ~s" (car x) (tag-name z) (var-type (car x)) (cadr x) (var-store (car x)) (if (eq (var-store (car x)) (caddr x)) (caddr x) +opaque+)) (do-setq-tp (car x) 'mch-set (cadr x));FIXME too prolix (push-vbinds (car x) (caddr x))) l)) (defun mch-z (z i &aux (f (cdr (assoc z *ft*)))) (declare (ignore i));FIXME (if f (mch-set z (or-mch f)) (mch)));FIXME ccb-ch (if i (or-mch f) f) ;; The right way to do this is to throw ccb assignments via tag-throw on go into something like *ft* (defun pr (x &aux (y (member-if 'tag-p x))(z (mapcar 'c1arg (ldiff x y)))(i (when z (info-type (cadar (last z)))))) (nconc z (when y (let* ((z (pop y)) (*bt* (cons (cons z (mch-z z i)) *bt*))) (pt z y))))) (defconstant +ttl-tag-name+ (gensym "TTL")) (defun make-ttl-tag nil (make-tag :name +ttl-tag-name+)) (defun is-ttl-tag (tag) (when (tag-p tag) (eq (tag-name tag) +ttl-tag-name+))) (defvar *ttl-tags* nil) (defun nttl-tags (body &aux (x (car body))) (if (is-ttl-tag x) (cons (list x *vars*) *ttl-tags*) *ttl-tags*)) (defun c1tagbody (body &aux (info (make-info :type #tnull))) (let* ((body (mapcar (lambda (x) (if (or (symbolp x) (integerp x)) (make-tag :name x) x)) body)) (tags (remove-if-not 'tag-p body)) (body (let* ((*tags* (append tags *tags*)) (*ft* (nconc (mapcar 'list tags) *ft*));FIXME (*ttl-tags* (nttl-tags body))) (pr body))) (body (mapc (lambda (x) (unless (tag-p x) (ref-tags x tags))) body)) (ref-clb (remove-if-not 'tag-ref-clb tags)) (ref-ccb (remove-if-not 'tag-ref-ccb tags)) (tagsc (union ref-clb ref-ccb)) (tags (union (remove-if-not 'tag-ref tags) tagsc)) (body (remove-if-not (lambda (x) (if (tag-p x) (member x tags) t)) body))) (mapc (lambda (x) (setf (tag-var x) (tag-name x))) tagsc) (if tagsc (set-volatile info) (add-loop-registers body)) (when ref-ccb (mapc (lambda (x) (setf (tag-ref-ccb x) t)) ref-clb));FIXME? (mapc (lambda (x) (unless (tag-p x) (add-info info (cadr x)))) body) (let ((x (car (last body)))) (unless (or (not x) (tag-p x) (info-type (cadr x))) (setf (info-type info) nil))) (if tags `(tagbody ,info ,(when ref-clb t) ,(when ref-ccb t) ,body) (let* ((v (car (last body))) (v (if (when v (not (info-type (cadr v)))) body (nconc body (list (c1nil)))))) (if (cdr v) `(progn ,info ,v) (car v)))))) (defun c2tagbody (ref-clb ref-ccb body) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) ((c2tagbody-local body)))) (defun c2tagbody-local (body &aux (label (next-label))) (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*)) ;gcc lintian, lacking noreturn attributes prevents ;(unless (type>= #tnil (info-type (cadar l))) (unwind-exit nil)) (unwind-exit nil)))) (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();") (add-libc "setjmp") (setq *frame-used* t) (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) (clink ref-clb) (setq ref-ccb (ccb-vs-push)) (add-libc "setjmp") (setq *frame-used* t) (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 mcpt (tp &aux (a (car (atomic-tp tp)))) (when (consp a) (subst (copy-list a) a tp)));rplacd, etc. (defun tag-throw (tag &aux (b (assoc tag *bt*))) (if b (let ((v (prune-mch (cdr b) t))) (when v (throw tag (or-mch v t)))) (let ((f (assoc tag *ft*))) (or (or-mch (cdr f)) (setf (cdr f) (mch)))))) (defun c1go (args &aux (name (car args)) ccb clb inner) (cond ((endp args) (too-few-args 'go 1 0)) ((not (endp (cdr args))) (too-many-args 'go 1 (length args))) ((not (or (symbolp name) (integerp name))) "The tag name ~s is not a symbol nor an integer." name)) (dolist (tag *tags* (cmperr "The tag ~s is undefined." name)) (case tag (cb (setq ccb t inner (or inner 'cb))) (lb (setq clb t inner (or inner 'lb))) (t (when (when (eq (tag-name tag) name) (not (member tag *lexical-env-mask*))) (tag-throw tag) (let* ((ltag (list tag)) (info (make-info :type nil)) (c1fv (when ccb (c1inner-fun-var)))) (cond (ccb (setf (info-ref-ccb info) ltag)) (clb (setf (info-ref-clb info) ltag)) ((setf (info-ref info) ltag))) (when c1fv (add-info info (cadr c1fv))) (return (list 'go info tag ccb clb c1fv)))))))) (defun c2go (tag ccb clb c1fv) (declare (ignore c1fv)) (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)) ");") (unwind-exit nil)) (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)) ");}") (unwind-exit nil)) (defun wt-switch-case (x) (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":")))) (defun or-branches (trv) (mapc (lambda (x &aux (v (pop x))(tp (pop x))(st (car x))) (cond ((var-p v) (unless (subsetp st (var-store v)) (keyed-cmpnote (list (var-name v) 'var-store 'binding '+opaque+) "~s store set to +opaque+ from ~s/~s across if branches" (var-name v) st (var-store v)) (push-vbinds v st)) (do-setq-tp v (list 'or-branches nil) (type-or1 (var-type v) tp))) (t (keyed-cmpnote (list 'type-mod-unwind) "Unwinding type ~s ~s" v tp) (repl-tp v tp t)))) trv)) (defun c1switch (body) (flet ((tgs-p (x) (or (symbolp x) (integerp x)))) (let* ((switch-op (pop body)) (info (make-info :type #tnil)) (switch-op-1 (c1arg switch-op info)) (st (coerce-to-one-value (info-type (cadr switch-op-1)))) (st (if (type>= #tfixnum st) st (baboon))) tags (body (remove-if (lambda (x) (when (tgs-p x) (prog1 (member x tags) (push x tags)))) body)) skip cs dfp rt (body (remove-if-not (lambda (b) (cond ((tgs-p b) (unless cs (setq cs t skip t rt nil)) (let* ((e (object-type b))(df (member b '(t otherwise)))(e (if df st e))) (cond ((and df dfp) (cmperr "default tag must be last~%")) ((type-and st e) (setq skip nil dfp (or df dfp) rt (type-or1 rt e))) ((keyed-cmpnote 'branch-elimination "Eliminating unreachable switch ~s" b))))) ((not skip) (when cs (setq st (type-and st (tp-not rt)) cs nil)) t) (t (eliminate-src b) nil))) body)) (body (mapcar (lambda (x) (if (tgs-p x) (make-tag :name x :ref t :switch (if (typep x 'fixnum) x "default")) x)) body)) trv (body (mapcar (lambda (x) (if (tag-p x) x (let ((x (c1branch t nil (list nil x) info))) (prog1 (pop x) (setq trv (append trv (car x))))))) body)) (ls (member-if 'consp body))) (or-branches trv) (when st (baboon)) (mapc (lambda (x) (assert (or (tag-p x) (not (info-type (cadr x)))))) body) (if (unless (cdr ls) (ignorable-form switch-op-1)) (car ls) (list 'switch info switch-op-1 body))))) (defun c2switch (op body &aux (*inline-blocks* 0)(*vs* *vs*)) (let ((args (inline-args (list op) `(,#tfixnum)))) (wt-nl "") (wt-inline-loc "switch(#0){" args) (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.7.1/cmpnew/PaxHeaders/gcl_cmpflet.lsp0000644000000000000000000000013114774225213015642 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.452939068 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpflet.lsp0000644000175000017500000005215114774225213015245 0ustar00cammcamm;; -*-Lisp-*- ;;; CMPFLET Flet, Labels, and Macrolet. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 (:print-function (lambda (x s i) (s-print 'fun (fun-name x) (si::address x) s)))) 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)))) (call (make-list 6));FIXME vv src c1 c1cb fn) (defun local-fun-fn (id) (let* ((fun (local-fun-p id))) (when fun (fun-fn fun)))) ;; (defun local-fun-fun (id) ;; (let* ((fun (local-fun-p id))) ;; (when fun (car (atomic-tp (info-type (cadr (fun-prov fun)))))))) ;; (defun local-fun-src (id) ;; (let ((fun (local-fun-fun id)));FUN-SRC? ;; (when fun (function-lambda-expression fun)))) (defun local-fun-src (id) (let ((fun (local-fun-p id))) (when fun (fun-src fun)))) (si::freeze-defstruct 'fun) (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). (defvar *restore-vars-env* nil) (defun repl-lst (l m &optional o) (typecase l (cons (cond ((consp m) (setf (car l) (repl-lst (car l) (car m) o) (cdr l) (repl-lst (cdr l) (cdr m) o)) l)(m))) (t (if (eql l m) l (if o (new-bind) m))))) (defun repl-tp (tp m &optional o) (unless (equal tp m) (let* ((atp (atomic-tp tp))(am (atomic-tp m))) (when (and atp am);FIXME redundant? (repl-lst (car atp) (car am) o)))) tp) (defmacro with-restore-vars (&rest body &aux (rv (sgen "WRV-"))(wns (sgen "WRVW-"))) `(let (,rv (,wns *warning-note-stack*)) (declare (ignorable ,rv)) (labels ((keep-vars nil (setq ,rv *restore-vars*)(keep-warnings)) (keep-warnings nil (setq ,wns *warning-note-stack*)) (pop-restore-vars nil (setq *warning-note-stack* ,wns) (mapc (lambda (l &aux (v (pop l))(tp (pop l))(st (pop l))) (cond ((var-p v) (keyed-cmpnote (list (var-name v) 'type-propagation 'type) "Restoring var type on ~s from ~s to ~s" (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp)) (setf (var-type v) tp (var-store v) st)) (t (keyed-cmpnote (list 'type-mod-unwind) "Unwinding type ~s ~s" v tp) (repl-tp v tp)))) (ldiff-nf *restore-vars* ,rv)))) (declare (ignorable #'keep-vars)) (prog1 (let (*restore-vars* (*restore-vars-env* *vars*)) (unwind-protect (progn ,@body) (pop-restore-vars))) (mapc (lambda (l) (when (member (car l) *restore-vars-env*) (pushnew l *restore-vars* :key 'car))) ,rv))))) (defun ref-environment (&aux inner) (dolist (fun *funs*) (when (or (eq fun 'cb) (eq fun 'lb)) (setq inner (or inner fun)))) (when (eq inner 'cb) (ref-inner inner))) (defun bump-closure-lam-sig (lam) (flet ((nt (x) (type-or1 x #tt))) (mapc (lambda (x) (setf (var-type x) (nt (var-type x)))) (caaddr lam)) (let ((i (cadar (last lam)))) (setf (info-type i) (nt (info-type i)))) (lam-e-to-sig lam))) (defun process-local-fun (b fun def tp) (let* ((name (fun-name fun)) (lam (do-fun name (cons name (cdr def)) (fun-call fun) (member fun *funs*) b)) (res (list fun lam))) ;closures almost always called anonymously which will be slow unless argd is 0 (unless (tailp (member-if-not 'fun-p *funs*) (member fun *funs*)) (setf (car (fun-call fun)) (bump-closure-lam-sig lam))) (ref-environment);FIXME? (setf (fun-cfun fun) (next-cfun)) (add-info (fun-info fun) (cadr lam));FIXME copy-info? (setf (info-type (fun-info fun)) (cadar (fun-call fun))) (setf (info-type (cadr lam)) tp) res)) ;; (defun process-local-fun (b fun def tp) ;; (let* ((name (fun-name fun)) ;; (lam (do-fun name (cons name (cdr def)) (fun-call fun) (member fun *funs*) b)) ;; ; (cvs (let (r) (do-referred (v (cadr lam)) (when (and (var-p v) (var-cbb v)) (push v r))) r)) ;; (res (list fun lam)) ;; ; (l (si::interpreted-function-lambda (cadr tp))) ;; ) ;; ;closures almost always called anonymously which will be slow unless argd is 0 ;; (when (or (eq b 'cb) (fun-ref-ccb fun)) (setf (car (fun-call fun)) (bump-closure-lam-sig lam))) ;; (ref-environment) ;; (setf (fun-cfun fun) (next-cfun)) ;; ; (setf (cadr l) cvs) ;; (add-info (fun-info fun) (cadr lam));FIXME copy-info? ;; (setf (info-type (fun-info fun)) (cadar (fun-call fun))) ;; (setf (info-type (cadr lam)) tp) ;; res)) (defun ref-funs (form funs) (ref-obs form funs (lambda (x) (setf (fun-ref-ccb x) t)) (lambda (x) (declare (ignore x))) (lambda (x) (setf (fun-ref x) t)))) (defun effective-safety-src (src &aux (n (pop src))(ll (pop src))) (multiple-value-bind (doc decls ctps body) (parse-body-header src) `(,n ,ll ,@(when doc (list doc)) ,@(cons `(declare (optimize (safety ,(this-safety-level)))) decls) ,@ctps ,@body))) (defvar *local-fun-inline-limit* 200) (defun c1flet-labels (labels args &aux body ss ts is other-decl (info (make-info)) defs1 fnames (ofuns *funs*) (*funs* *funs*)(*top-level-src* *top-level-src*)) (when (endp args) (too-few-args 'flet 1 0)) (dolist (def (car args) (setq defs1 (nreverse defs1))) (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def))))) (cmpck (or (endp def) (endp (cdr def))) "The function definition ~s is illegal." def) (when labels (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) (push (car def) fnames)) (let* ((def (effective-safety-src def)) (src (mark-toplevel-src (si::block-lambda (cadr def) (car def) (cddr def)))) (fun (make-fun :name (car def) :src src :info (make-info :type nil :flags (iflags sp-change))))) (push fun *funs*) (unless (< (cons-count src) *local-fun-inline-limit*) (keyed-cmpnote (list (car def) 'notinline) "Blocking inline of large local fun ~s" (car def)) (pushnew (car def) *notinline*)) (push (list fun (cdr def)) defs1))) (let ((*funs* (if labels *funs* ofuns))) ; (mapc (lambda (x &aux (x (car x))) (setf (fun-fn x) (afe (cons 'df (current-env)) (mf (fun-name x))))) defs1)) (mapc (lambda (x &aux (x (car x))) (setf (fun-fn x) (mf (fun-name x) x))) defs1)) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (c1add-globals ss) (check-vdecl (mapcar (lambda (x) `(function ,(fun-name (car x)))) defs1) ts is) (setq body (c1decl-body other-decl body)) (let ((nf (mapcar 'car defs1))) (ref-funs body nf) (when labels (do (fun) ((not (setq fun (car (member-if (lambda (x) (or (fun-ref x) (fun-ref-ccb x))) nf))))) (setq nf (remove fun nf)) (when (fun-ref fun) (ref-funs (fun-c1 fun) nf)) (when (fun-ref-ccb fun) (ref-funs (fun-c1cb fun) nf))))) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (mapc (lambda (x &aux (x (car x))) (unless (or (fun-ref x) (fun-ref-ccb x)) (eliminate-src (fun-src x)))) defs1) (let* ((funs (mapcar 'car defs1)) (fns (mapcar (lambda (x) (caddr (fun-c1 x))) (remove-if-not 'fun-ref funs))) (cls (mapcar (lambda (x) (caddr (fun-c1cb x))) (remove-if-not 'fun-ref-ccb funs)))) (if (or fns cls) (list (if labels 'labels 'flet) info fns cls body) body))) (defun c1flet (args) (c1flet-labels nil args)) (defun c2flet-labels (labels local-funs closures body &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*)) (mapc (lambda (def &aux (fun (car def))) (setf (fun-ref fun) (vs-push)) (clink (fun-ref fun)) (setf (fun-ref-ccb fun) (ccb-vs-push))) closures) (mapc (lambda (def &aux (fun (car def))) (when (eq (fun-ref fun) t) (setf (fun-ref fun) (vs-push)))) local-funs) (let ((*clink* (if labels *clink* oclink)) (*ccb-vs* (if labels *ccb-vs* occb-vs))) (mapc (lambda (def &aux (fun (pop def))) (setf (fun-level fun) *level*) (push (list nil *clink* *ccb-vs* fun (car def) *initial-ccb-vs*) *local-funs*)) local-funs) (when (or local-funs closures) (base-used));fixme (dolist (def closures) (let* ((fun (pop def)) (lam (car def)) (cl (update-closure-indices (fun-call fun))) (sig (car cl)) (at (car sig)) (rt (cadr sig))) (push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs*) (wt-nl) (wt-vs* (fun-ref fun)) (wt "=") (setf (fun-vv fun) (cons '|#,| (export-call-struct cl))) (wt-make-cclosure (fun-cfun fun) (fun-name fun) (fun-vv fun) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*) (wt ";") (wt-nl)))) (c2expr body)) (defun c2flet (local-funs closures body) (c2flet-labels nil local-funs closures body)) (defun c1labels (args) (c1flet-labels t args)) (defun c2labels (local-funs closures body) (c2flet-labels t local-funs closures body)) (defvar *macrolet-env* nil) (defun push-macrolet-env (defs) (dolist (def defs) (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) "The macro definition ~s is illegal." def) (push (make-fun :name (car def) :fn (eval (si::defmacro-lambda (pop def) (pop def) def))) *funs*))) (defun c1macrolet (args &aux body ss ts is other-decl (*funs* *funs*)) (when (endp args) (too-few-args 'macrolet 1 0)) (push-macrolet-env (car args)) (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 ref-inner (b) (when (eq b 'cb) (let* ((bv (member b *vars*)) (fv (member-if 'is-fun-var (nreverse (ldiff *vars* bv))))) (when fv (setf (var-ref (car fv)) t))))) ;; (defun ref-inner (b) ;; (when (eq b 'cb) ;; (let* ((bv (member b *vars*)) ;; (fv (member-if 'is-fun-var *vars*))) ;; (when fv ;; (when (tailp bv fv) ;; (setf (var-ref (car fv)) t)))))) ;(defvar *local-fun-recursion* nil) ;; (defun c1local-fun (fname &aux ccb prev inner) ;; (dolist (fun *funs*) ;; (cond ((eq fun 'cb) (setq ccb t inner (or inner 'cb))) ;; ((eq fun 'lb) (setq inner (or inner 'lb))) ;; ((eq (fun-name fun) fname) ;; (cond (ccb (ref-inner inner) (setf prev (fun-ref-ccb fun) (fun-ref-ccb fun) t)) ;; ((setf prev (fun-ref fun) (fun-ref fun) t))) ;; (unless prev ;; (unless (member fname *local-fun-recursion*) ;; (let* ((*local-fun-recursion* (cons fname *local-fun-recursion*))) ;; (setf (fun-c1 fun) (unfoo (fun-prov fun) (if ccb 'cb 'lb) fun))))) ;; (setf (info-type (fun-info fun)) (cadar (fun-call fun))) ;; (return (list 'call-local (fun-info fun) (list fun ccb))))))) ;; (defun make-fun-c1 (fun b env &optional osig) ;; (let* ((res (under-env env (c1function (list (fun-src fun) b fun)))) ;; (sig (car (fun-call fun)))) ;; (if (and (is-referred fun (cadr res)) (not (eq (cadr osig) (cadr sig)))) ;; (make-fun-c1 fun b env sig)) ;; res)) ;; (defmacro make-local-fun (c1 b f env) ;; `(progn ;; (unless (,c1 ,f) (setf (,c1 ,f) t (,c1 ,f) (make-fun-c1 ,f ',b ,env))) ;; (when (listp (,c1 ,f)) (,c1 ,f)))) (defvar *force-fun-c1* nil) (defvar *fun-stack* nil) (defun ifunp (key pred l) (car (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l))) (defun ifunm (pred i) (or (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i)))) (defun all-callees (i) (when i (nconc (mapcan (lambda (x) (when (fun-p x) (list (list x)))) (info-ref i)) (mapcan (lambda (x) (when (fun-p x) (list (list x t)))) (info-ref-ccb i))))) (defun callee-sigs (i) (mapcar (lambda (x) (cons x (car (fun-call (car x))))) (all-callees i))) (defun invalidate (s) (unless (eq s *fun-stack*) (let* ((k (car (car s)))) (keyed-cmpnote (list (fun-name (car k)) 'local) "invalidating local fun ~s" k) (if (cdr k) (setf (fun-c1cb (car k)) nil) (setf (fun-c1 (car k)) nil)) (let ((*fun-stack* s)) (mapc 'invalidate (fourth (car s)))) (invalidate (cdr s))))) (defun recursive-loop-funs (s) (unless (eq s *fun-stack*) (let* ((k (car (car s)))) (let ((*fun-stack* s)) (mapc 'recursive-loop-funs (fourth (car s)))) (pushnew (car k) (recursive-loop-funs (cdr s))))));FIXME (defun fun-stack (key res) (list key (car (fun-call (car key))) (callee-sigs (cadr res)) nil res)) (defun make-fun-c1 (fun ccb env &optional prev &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))) (key (cons fun ccb)) tmp) (labels ((set (fun val) (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val)))) (cond (c1 (keyed-cmpnote (list (fun-name fun) 'local) "returning finalized value for local fun ~s" key) c1) ((setq tmp (assoc key *fun-stack* :test 'equal)) (keyed-cmpnote (list (fun-name fun) 'local) "returning trial value for local fun ~s" key) (pushnew *fun-stack* (fourth tmp)) (fifth tmp)) ((let* ((ii (keyed-cmpnote (list (fun-name fun) 'local) "processing local fun ~s" key)) (*fun-stack* (cons (fun-stack key prev) *fun-stack*)) (res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun))) (fun-stack-prev (pop *fun-stack*)) (recursive-p (fourth fun-stack-prev)) (i (cadr res)) (callees (all-callees i))) (declare (ignore ii)) (when recursive-p (setf (info-flags (fun-info fun)) (logior (info-flags (fun-info fun)) (iflags compiler)))) (cond ((iflag-p (info-flags i) provisional) (keyed-cmpnote (list (fun-name fun) 'provisional 'local) "local fun ~s provisionally processed" key) res) ((unless (member-if (lambda (x) (assoc x *fun-stack* :test 'equal)) callees) (when recursive-p (or (not (equal (cadr fun-stack-prev) (car (fun-call fun)))) ; (member-if-not (lambda (x &aux (y (assoc x (caddr fun-stack-prev) :test 'equal))) (when y (equal (cdr y) (car (fun-call (car x)))))) callees) ))) (mapc 'invalidate (fourth fun-stack-prev)) (keyed-cmpnote (list (fun-name fun) 'local) "reprocessing unfinished local fun ~s on sig mismatch: ~s" key (list (butlast fun-stack-prev 2) (butlast (fun-stack key res) 2))) (make-fun-c1 fun ccb env res)) (t (keyed-cmpnote (list (fun-name fun) 'local) "finalizing local fun ~s" key) (set fun res)))))))) (defun c1local-fun (fname &optional cl &aux ccb inner (lf (local-fun-p fname))) (dolist (fun *funs*) (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun))) ((eq fun lf) (let* ((cl (or ccb cl)) (env (fn-get (fun-fn fun) 'df)) (fm (make-fun-c1 fun cl env)) (info (if fm (copy-info (cadr fm)) (make-info))) (c1fv (when ccb (c1inner-fun-var)))) (setf (info-type info) (cadar (fun-call fun)));FIXME (if cl (pushnew fun (info-ref-ccb info)) (pushnew fun (info-ref info))) (when c1fv (add-info info (cadr c1fv))) (return (list 'call-local info (list fun cl ccb) c1fv fm))))))) (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 make-inline-arg-str (sig &optional (lev -1)) (let* ((inl (let (r) (dotimes (i (1+ lev) r) (push i r)))) (inl (mapcar (lambda (x) (strcat "base" (write-to-string x))) inl)) (inl (if (= lev *level*) (cons "base" (cdr inl)) inl)) (va (member '* (car sig))) (inl (dotimes (i (- (length (car sig)) (if va 1 0)) inl) (push (strcat "#" (write-to-string i)) inl))) (inl (if va (cons (if (eq va (car sig)) "#?" "#*") inl) inl)) (inl (nreverse inl))) (reduce 'strcat (mapcon (lambda (x) (if (and (cdr x) (not (member (cadr x) '("#*" "#?") :test 'equal))) (list (car x) ",") (list (car x)))) inl) :initial-value ""))) (defun vfun-wrap (x sig clp &optional ap &aux (ap (when ap (1- ap)))) (let* ((mv (not (single-type-p (cadr sig)))) (va (member '* (car sig))) (nreg (length (ldiffn (car sig) va)))) (ms "(" (when clp (concatenate 'string "fcall.fun=" clp ",")) (when mv "fcall.valp=(fixnum)#v,") (when va "fcall.argd=") (when (and va ap) "-") (when va "#n") (when (and va ap (< ap nreg)) (- ap nreg)) (when va ",") x ")"))) (defun make-local-inline (fd) (let* ((fun (pop fd)) (clp (pop fd)) (ap (cadr fd)) (sig (car (fun-call fun))) (sig (list (mapcar (lambda (x) (link-rt x t)) (car sig)) (link-rt (cadr sig) t))) (mv (not (single-type-p (cadr sig)))) (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) (nm (concatenate 'string "(" (rep-type (coerce-to-one-value (cadr sig))) ")" nm)) (clp (when clp (ccb-vs-str (fun-ref-ccb fun)))) (nm (if clp (ms clp "->fun.fun_self") nm)) (inl (g1 clp nm sig ap clp (if clp -1 (fun-level fun))))) `(,(car sig) ,(cadr sig) ,(if mv (flags rfa svt) (flags rfa)) ,inl))) ;; (defun make-local-inline (fd) ;; (let* ((fun (pop fd)) ;; (clp (pop fd)) ;; (ap (cadr fd)) ;; (sig (car (fun-call fun))) ;; (sig (list (mapcar (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil))) ;; (mv (not (single-type-p (cadr sig)))) ;; (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) ;; (clp (when clp (ccb-vs-str (fun-ref-ccb fun)))) ;; (nm (if clp (ms clp "->fun.fun_self") nm)) ;; (inl (g1 clp nm sig ap clp (if clp -1 (fun-level fun))))) ;; `(,(car sig) ,(cadr sig) ;; ,(if mv (flags rfa svt) (flags rfa)) ;; ,inl))) ;; (defun make-local-inline (fd) ;; (let* ((fun (pop fd)) ;; (clp (pop fd)) ;; (ap (pop fd)) ;; (sig (car (fun-call fun))) ;; (sig (list (mapcar (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil))) ;; (mv (not (single-type-p (cadr sig)))) ;; (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) ;; (clp (when clp (ccb-vs-str (fun-ref-ccb fun)))) ;; (nm (if clp (ms clp "->fun.fun_self") nm)) ;; (inl (g1 clp nm sig ap clp (if clp -1 (fun-level fun))))) ;; `(,(car sig) ,(cadr sig) ;; ,(if mv (flags rfa svt) (flags rfa)) ;; ,inl))) ;; (defun make-local-inline (fd) ;; (let* ((fun (pop fd)) ;; (clp (pop fd)) ;; (ap (pop fd)) ;; (sig (car (fun-call fun))) ;; (sig (list (mapcar (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil))) ;; (mv (not (single-type-p (cadr sig)))) ;; (nm (c-function-name "L" (fun-cfun fun) (fun-name fun))) ;; (nm (if clp (strcat (ccb-vs-str (fun-ref-ccb fun)) "->fun.fun_self") nm)) ;; (inl (g0 nm sig ap (when clp (ccb-vs-str (fun-ref-ccb fun))) (if clp -1 (fun-level fun))))) ;; `(,(car sig) ,(cadr sig) ;; ,(if mv (flags rfa svt) (flags rfa)) ;; ,inl))) (defun c2call-local (fd c1fv lam args &aux (*vs* *vs*)) (declare (ignore lam c1fv)) (let ((*inline-blocks* 0)) (unwind-exit (get-inline-loc (make-local-inline fd) args)) (close-inline-blocks))) ;; (defun c2call-local (fd args &aux (*vs* *vs*)) ;; (let ((*inline-blocks* 0)) ;; (unwind-exit (get-inline-loc (make-local-inline fd) args)) ;; (close-inline-blocks))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpfun.lsp0000644000000000000000000000013114774225213015500 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.452939068 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpfun.lsp0000644000175000017500000005223014774225213015101 0ustar00cammcamm;; CMPFUN Library functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 'funcall 'c1funcall 'c1) (defvar *princ-string-limit* 80) (defun c1princ (args &aux stream (info (make-info :flags (iflags side-effects)))) (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) (c1arg (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 (c1arg (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 (cmp-norm-tp (if (characterp string) 'character 'string))) (list 'VV string)) stream) nil t)))) (defun c1terpri (args &aux stream (info (make-info :flags (iflags side-effects)))) (unless (or (endp args) (endp (cdr args))) (too-many-args 'terpri 1 (length args))) (setq stream (if (endp args) (c1nil) (c1arg (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 c1terpri (args &aux stream (info (make-info :flags (iflags side-effects)))) ;; (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 c2apply (funob args) (unless (eq 'ordinary (car funob)) (baboon)) (let* ((fn (caddr funob)) (all (cons fn args)) (*inline-blocks* 0)) (setq *sup-used* t) (unwind-exit (get-inline-loc (list (make-list (length all) :initial-element t) '* #.(flags ans set svt) (concatenate 'string "({fixnum _v=(fixnum)#v;object _z,_f=(#0),_l=(#1),_ll=_l; object _x4=Cnil,_x3=Cnil,_x2=Cnil,_x1=Cnil,_x0=Cnil; char _m=(#n-2),_q=_f->fun.fun_minarg>_m ? _f->fun.fun_minarg-_m : 0; char _n=Rset && !_f->fun.fun_argd ? _q : -1; fcall.fun=_f;fcall.valp=_v;fcall.argd=-(#n-1); switch (_n) { case 5: if (_l==Cnil) {_n=-1;break;} _x4=_l->c.c_car;_l=_l->c.c_cdr; case 4: if (_l==Cnil) {_n=-1;break;} _x3=_l->c.c_car;_l=_l->c.c_cdr; case 3: if (_l==Cnil) {_n=-1;break;} _x2=_l->c.c_car;_l=_l->c.c_cdr; case 2: if (_l==Cnil) {_n=-1;break;} _x1=_l->c.c_car;_l=_l->c.c_cdr; case 1: if (_l==Cnil) {_n=-1;break;} _x0=_l->c.c_car;_l=_l->c.c_cdr; case 0: if (_n+_m+(_l==Cnil ? 0 : 1)>_f->fun.fun_maxarg) _n=-1; else fcall.argd-=_n; default: break; } switch (_n) { case 5: _z=_f->fun.fun_self(#*_x4,_x3,_x2,_x1,_x0,_l);break; case 4: _z=_f->fun.fun_self(#*_x3,_x2,_x1,_x0,_l);break; case 3: _z=_f->fun.fun_self(#*_x2,_x1,_x0,_l);break; case 2: _z=_f->fun.fun_self(#*_x1,_x0,_l);break; case 1: _z=_f->fun.fun_self(#*_x0,_l);break; case 0: _z=" (if (cdr args) "_f->fun.fun_self(#*_l)" "(_f->fun.fun_maxarg ? _f->fun.fun_self(#*_l) : _f->fun.fun_self())") ";break; default: _z=call_proc_cs2(#*_ll);break; } if (!(_f)->fun.fun_neval && !(_f)->fun.fun_vv) vs_top=_v ? (object *)_v : sup; _z;})")) (list* (car all) (car (last all)) (butlast (cdr all))))) (close-inline-blocks))) ;FIXME c1symbol-fun, eliminate mi1b (defmacro try-provisional-functions (&rest body);ensure body has no side-effects for double eval `(or (with-restore-vars (let* ((*prov* t)(ops *prov-src*)(*prov-src* *prov-src*)(res (progn ,@body))) (unless (iflag-p (info-flags (cadr res)) provisional) (keep-vars) (mapc 'eliminate-src (ldiff *prov-src* ops)) res))) (progn ,@body))) (defun c1apply (args) (when (or (endp args) (endp (cdr args))) (too-few-args 'apply 2 (length args))) (try-provisional-functions (let* ((ff (c1arg (car args)))(args (cdr args))(fid (coerce-ff ff))) (if (eq fid 'funcall) (c1apply args) (mi1 fid (butlast args) (car (last args)) ff))))) (defun c1funcall (args) (when (endp args) (too-few-args 'funcall 1 0)) (try-provisional-functions (let* ((ff (c1arg (car args)))(args (cdr args))(fid (coerce-ff ff))) (case fid (funcall (c1funcall args))(apply (c1apply args)) (otherwise (mi1 fid args nil ff)))))) ;; (defun c1funcall-apply (args &optional last) ;; (mi1 (if last 'apply 'funcall) args (car last))) ;; (defun c1funcall (args) ;; (when (endp args) (too-few-args 'funcall 1 0)) ;; (c1funcall-apply args)) ;; (defun c1apply (args) ;; (when (or (endp args) (endp (cdr args))) ;; (too-few-args 'apply 2 (length args))) ;; (let* ((last (last args)) ;; (args (ldiff args last))) ;; (c1funcall-apply args last))) (defun eq-subtp (x y) ;FIXME axe mult values (let ((s (type>= y x))) (values s (or s (type>= (tp-not y) x))))) (defun eql-is-eq-tp (x) (eq-subtp x #teql-is-eq-tp)) (defun equal-is-eq-tp (x) (eq-subtp x #tequal-is-eq-tp)) (defun equalp-is-eq-tp (x) (eq-subtp x #tequalp-is-eq-tp)) (defun do-eq-et-al (fn args &aux (info (make-info :type #tboolean)));FIXME pass through function inlining (cmpck (not (eql (length args) 2)) "Predicate ~s takes two arguments" fn) (let* ((nargs (c1args args info)) (t1 (info-type (cadar nargs)))(t2 (info-type (cadadr nargs))) (a1 (atomic-tp t1))(a2 (atomic-tp t2)) (nfn (ecase fn (eq fn) (eql (let ((tp #teql-is-eq-tp)) (if (or (type<= t1 tp)(type<= t2 tp)) 'eq fn))) (equal (let ((tp #tequal-is-eq-tp)) (if (or (type<= t1 tp)(type<= t2 tp)) 'eq fn))) (equalp (let ((tp #tequalp-is-eq-tp)) (if (or (type<= t1 tp)(type<= t2 tp)) 'eq fn))))) (nfn (if (when (eq nfn 'equal) (or (type<= t1 #tnumber) (type<= t2 #tnumber))) 'eql nfn))) (cond ((when (and t1 t2 (member nfn '(eq eql))) (not (type-and t1 t2))) (c1progn (append args (list nil)) (nconc nargs (list (c1nil))))) ((and a1 a2 (case nfn (eq (or (eql-is-eq (car a1)) (eql-is-eq (car a2))))(eql t))) (let ((q (eql (car a1) (car a2)))) (c1progn (append args (list q)) (nconc nargs (list (if q (c1t) (c1nil))))))) ((when (and t1 t2) (let ((x (get-vbind (car nargs)))(y (get-vbind (cadr nargs)))) (when (or (when x (eq x y)) (and (symbolp (car args)) (eq (car args) (cadr args)))) (c1t))))) (t (unless (and t1 t2) (setf (info-type info) nil)) `(call-global ,info ,nfn ,nargs))))) (dolist (l `(eq eql equal equalp)) (si::putprop l 'do-eq-et-al 'c1g)) (defun num-type-bounds (t1) (let ((x (tp-bnds t1))) (when x (list (car x) (cdr x))))) (defun ntrr (x y) (and x y (list (and (car x) (car y)) (and (cadr x) (cadr y) (eq (car x) (car y)))))) (defun dntrr (l) (reduce 'ntrr (cdr l) :initial-value (car l))) (defun num-type-rel (fn t1 t2 &optional s &aux (t1 (coerce-to-one-value t1))(t2 (coerce-to-one-value t2))) (let ((nop (car (rassoc fn '((>= . <) (> . <=) (= . /=))))) (rfn (cdr (assoc fn '((>= . >) (> . >=)))))) (cond (nop (let ((q (num-type-rel nop t1 t2))) (list (and (not (car q)) (cadr q)) (cadr q)))) ((and (consp t1) (eq (car t1) 'or)) (dntrr (mapcar (lambda (x) (num-type-rel fn x t2)) (cdr t1)))) ((and (consp t2) (eq (car t2) 'or)) (dntrr (mapcar (lambda (x) (num-type-rel fn t1 x)) (cdr t2)))) ((eq fn '=) (cond ((not (and t1 t2)) (list nil t)) ;; ((and (type>= #tcomplex t1) (not (type-and #tcomplex t2))) ;; (unless (type-and (cadr t1) (type-and t2 #t(real 0.0 0.0))) ;; (list nil t))) ;; ((and (type>= #tcomplex t2) (not (type-and #tcomplex t1))) ;; (unless (type-and (cadr t2) (type-and t1 #t(real 0.0 0.0))) ;; (list nil t))) ((let ((x (num-type-rel '>= t1 t2))(y (num-type-rel '>= t2 t1))) (list (and (car x) (car y)) (and (cadr x) (cadr y))))))) ((not s) (let ((f (num-type-rel fn t1 t2 t))) (list f (or f (num-type-rel rfn t2 t1 t))))) ((not (and t1 t2)) nil) ((and (type>= #treal t1) (type>= #treal t2)) (let ((t1 (car (num-type-bounds t1))) (t2 (cadr (num-type-bounds t2)))) (and (numberp t1) (numberp t2) (values (funcall fn t1 t2)))))))) (defun do-num-relations (fn args) (let* ((info (make-info :type #tboolean)) (nargs (c1args args info)) (t1 (and (car args) (info-type (cadar nargs)))) (t2 (and (cadr args) (info-type (cadadr nargs)))) (fn (or (cdr (assoc fn '((si::=2 . =)(si::/=2 . /=)(si::>=2 . >=) (si::>2 . >)(si::<2 . <)(si::<=2 . <=)))) fn)) (r (and t1 t2 (num-type-rel fn t1 t2)))) (cond ((cddr args) (list 'call-global info fn nargs)) ((or (car r) (cadr r)) (let ((r (when (car r) t))) (c1progn (append args (list r)) (nconc nargs (list (if r (c1t) (c1nil))))))) ((let ((x (get-vbind (car nargs)))(y (get-vbind (cadr nargs)))) (when (or (when x (eq x y)) (and (symbolp (car args)) (eq (car args) (cadr args)))) (unless (type-and (type-or1 t1 t2) #t(or (short-float unordered) (long-float unordered))) (if (member fn '(= >= <=)) (c1t) (c1nil)))))) ((list 'call-global info fn nargs))))) (dolist (l `(>= > < <= = /=)) (si::putprop l 'do-num-relations 'c1g)) (defun do-+- (fn args) (let* ((info (make-info :type #tnumber)) (nargs (c1args args info)) (i1 (info-type (cadar nargs))) (t1 (car (atomic-tp i1))) (i2 (info-type (cadadr nargs))) (t2 (car (atomic-tp i2)))) (cond ((and (eq fn 'number-plus) (eql t1 0) (ignorable-form (car nargs))) (cadr nargs));contagion ((and (eql t2 0) (ignorable-form (cadr nargs))) (car nargs)) (t (setf (info-type info) (type-and (info-type info) (funcall (get fn 'type-propagator) fn i1 i2))) `(call-global ,info ,fn ,nargs))))) (setf (get 'number-plus 'c1g) 'do-+-) (setf (get 'number-minus 'c1g) 'do-+-) (defun do-*/ (fn args) (let* ((info (make-info :type #tnumber)) (nargs (c1args args info)) (i1 (info-type (cadar nargs))) (t1 (car (atomic-tp i1))) (i2 (info-type (cadadr nargs))) (t2 (car (atomic-tp i2)))) (cond ((and (eq fn 'number-times) (eql t1 1) (ignorable-form (car nargs))) (cadr nargs));contagion ((and (eql t2 1) (ignorable-form (cadr nargs))) (car nargs)) (t (setf (info-type info) (type-and (info-type info) (funcall (get fn 'type-propagator) fn i1 i2))) `(call-global ,info ,fn ,nargs))))) (setf (get 'number-times 'c1g) 'do-*/) (setf (get 'number-divide 'c1g) 'do-*/) (dolist (l `(eq eql equal equalp > >= < <= = /= length + - / * min max;FIXME get a good list here car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar caaadr caadar cadaar cdaaar caaddr cadadr cdaadr caddar cdadar cddaar cadddr cdaddr cddadr cdddar cddddr logand lognot logior logxor c-type complex-real complex-imag ratio-numerator ratio-denominator cnum-type si::number-plus si::number-minus si::number-times si::number-divide ;FIXME more ,@(mapcar (lambda (x) (cdr x)) (remove-if-not (lambda (x) (symbolp (cdr x))) +cmp-type-alist+)))) (si::putprop l t 'c1no-side-effects)) (setf (get 'cons 'c1no-side-effects) t) (setf (get 'make-list 'c1no-side-effects) t) (setf (get 'si::make-vector 'c1no-side-effects) t) (setf (get 'complex 'c1no-side-effects) t) ;;bound type comparisons ;; only boolean eval const args (defun test-to-tf (test) (let ((test (if (constantp test) (cmp-eval test) test))) (cond ((member test `(eql ,#'eql)) '(eql-is-eq eql-is-eq-tp)) ((member test `(equal ,#'equal)) '(equal-is-eq equal-is-eq-tp)) ((member test `(equalp ,#'equalp)) '(equalp-is-eq equalp-is-eq-tp))))) (defun cons-type-length (type) (cond ((and (consp type) (eq (car type) 'cons)) (the seqind (+ 1 (cons-type-length (caddr type))))) (0))) (defvar *frozen-defstructs* nil) ;; Return the most particular type we can EASILY obtain ;; from x. (defun result-type (x) (cond ((symbolp x) (cmp-unnorm-tp (info-type (cadr (c1arg x))))) ((constantp x) (type-of x)) ((and (consp x) (eq (car x) 'the)) (second x)) (t t))) ;; (defun co1schar (f args) ;; (declare (ignore 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-listc (x) (typecase x ((cons t (cons t null)) (let ((y (cadr x))) (typecase y ((cons (member cons) (cons t (cons t null))) (let ((d (cons-to-listc (cdr y)))) (when d (cons (car x) d)))) (otherwise x)))))) (defun limit-list-call-args (form &aux (of form)(fn (pop of)) (x (nthcdr (- call-arguments-limit 2) of))) (if (cdr x) `(list* ,@(ldiff of x) ,(limit-list-call-args (cons fn x))) form)) (defun co1cons (f args &aux (tem (cons-to-listc args))) (declare (ignore f)) (when tem (c1expr (limit-list-call-args (if (equal '(nil) (last tem)) (cons 'list (butlast tem)) (cons 'list* tem)))))) ;; 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) #-cygwin(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) (,(if (eq read-fun 'read-char1) '(code-char ans) 'ans)))) ((,read-fun ,stream ,eof)) )))) (`(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 ;; (let* ((s (sgen "CO1READ-BYTE"))(nargs (cons s (cdr args)))) ;; (cond ((setq tem (fast-read nargs 'read-byte1)) ;; (let ((*space* 10)) ;prevent recursion! ;; (c1expr `(let ((,s ,(car args))) ;; (if (= 1 (si::get-byte-stream-nchars ,s)) ,tem ,(cons f nargs))))))))) (defun co1read-char (f args &aux tem) (declare (ignore f)) (cond ((setq tem (fast-read args 'read-char1)) (let ((*space* 10)) ;prevent recursion! (c1expr tem))))) (defun cfast-write (args write-fun tp) (when (and (not *safe-compile*) (< *space* 2) (boundp 'si::*eof*)) (let* ((stream (second args))(stream (or stream '*standard-output*))) (if (atom stream) (let ((ch (sgen "CFAST-WRITE-CH"))) `(let ((,ch ,(car args))) (if (and (fp-okp ,stream) (typep ,ch ',tp)) (sputc ,ch ,stream) (,write-fun ,ch ,stream)) ,ch)) (let ((str (sgen "CFAST-WRITE-STR"))) `(let ((,str ,stream)) (declare (type ,(result-type stream) ,str)) ,(cfast-write (list (car args) str) write-fun tp))))))) (defun co1write-byte (f args) (declare (ignore f)) (let ((tem (cfast-write args 'write-byte 'fixnum))) (when tem (let ((*space* 10)) (c1expr tem))))) (defun co1write-char (f args) (declare (ignore f)) (let* ((tem (cfast-write args 'write-char 'character))) (when tem (let ((*space* 10)) (c1expr tem))))) (defun aet-c-type (type) (or (cdr (assoc type +c-type-string-alist+)) (baboon))) (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* t (> *space* 3) (null (cdr args)) ) (let ((*space* 10)) (c1expr (let ((val (sgen "CO1VECTOR-PUSH-VAL")) (v (sgen "CO1VECTOR-PUSH-V")) (i (sgen "CO1VECTOR-PUSH-I")) (dim (sgen "CO1VECTOR-PUSH-DIM"))) `(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 ,val ,v ,i) ,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)))))) (defun narg-list-type (nargs &optional dot) (let* ((y (mapcar (lambda (x &aux (atp (atomic-tp (info-type (cadr x))))) (cond ;((get-vbind x)) (atp (car atp));FIXME ((get-vbind x)) ((lit-bind x)) ((new-bind)))) nargs))) ; (when dot (setf (cdr (last y 2)) (car (last y)))) ;FIXME bump-pcons -- get rid of pcons entirely (let* ((s (when dot (car (last y))))(s (when s (unless (typep s 'proper-list) s)))(tp (info-type (cadar (last nargs)))));FIXME (cond ((when s (type>= #tproper-list tp)) #tproper-cons) ((when s (type-and #tproper-list tp)) #tcons) (t (when dot (setf (cdr (last y 2)) (car (last y)))) (object-type y)))))) (defun c1list (args) (let* ((info (make-info)) (nargs (c1args args info))) (cond ((not nargs) (c1nil)) ((setf (info-type info) (narg-list-type nargs)) `(call-global ,info list ,nargs))))) (si::putprop 'list 'c1list 'c1) (defun c1list* (args) (unless args (too-few-args 'list* 1 0)) (let* ((info (make-info)) (nargs (c1args args info))) (cond ((not nargs) (c1nil)) ((not (cdr nargs)) (car nargs)) ((setf (info-type info) (narg-list-type nargs t)) `(call-global ,info ,(if (cddr nargs) 'list* 'cons) ,nargs))))) (si::putprop 'list* 'c1list* 'c1) (si::putprop 'cons 'c1list* 'c1) (define-compiler-macro list (&whole form) (limit-list-call-args form)) (define-compiler-macro list* (&whole form) (limit-list-call-args form)) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpinit.lsp0000644000000000000000000000013114774225213015653 xustar0030 mtime=1743858315.801955256 30 atime=1744294961.293792704 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpinit.lsp0000644000175000017500000000067614774225213015263 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire ;(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.7.1/cmpnew/PaxHeaders/gcl_cmpmulti.lsp0000644000000000000000000000013114774225213016042 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.472939196 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpmulti.lsp0000644000175000017500000004177014774225213015452 0ustar00cammcamm;;; CMPMULT Multiple-value-call and Multiple-value-prog1. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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-bind 'c1multiple-value-bind 'c1) (si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2) (defun nval (x) (cond ;((type>= #t(returns-exactly) x) 0) ((single-type-p x) 1) ((when (consp x) (eq (car x) 'returns-exactly)) (1- (length x))))) (defun c1multiple-value-call (args &aux (tsyms (load-time-value (mapl (lambda (x) (setf (car x) (gensym "MV-CALL"))) (make-list 50))))) (when (endp args) (too-few-args 'multiple-value-call 1 0)) (let* ((info (make-info)) (nargs (c1args args info)) (tps (mapcar (lambda (x) (info-type (cadr x))) (cdr nargs))) (vals (mapcar 'nval tps)) (n (if (member nil vals) -1 (reduce '+ vals)))) (cond ((endp (cdr args)) (c1funcall args)) ((and (>= (length tsyms) n 0) (inline-possible 'multiple-value-bind)) (let* ((syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) (make-list n))) (r syms)) (c1expr (reduce (lambda (x y) (cond ((= 1 (length (car x))) `(let ((,(caar x) ,(cadr x))) ,y)) (`(multiple-value-bind ,@x ,y)))) (mapcar (lambda (x y) (let* ((n (nval x)) syms) (dotimes (i n) (push (pop r) syms)) (list (nreverse syms) y))) tps (cdr args)) :from-end t :initial-value `(funcall ,(car args) ,@syms))))) ((list 'multiple-value-call info (pop nargs) nargs))))) (defun c2multiple-value-call (funob forms &aux (*vs* *vs*) (loc (list 'vs (vs-push))) top sup) (let ((*value-to-go* loc)) (c2expr* funob)) (cond ((endp (cdr forms)) (let ((*value-to-go* 'top)) (c2expr* (car forms)))) ((setq top (cs-push t t)) (setq sup (cs-push t t)) (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_base= (length tsyms) (length (cdr tp))))) (keep-vars))) (cond ((single-type-p tp) (let ((s (pop tsyms))) (c1expr `(let ((,s ,(car args))) ,@(cdr args) ,s)))) ((and (consp tp) (eq (car tp) 'returns-exactly) (>= (length tsyms) (length (cdr tp)))) (let ((syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) (cdr tp)))) (c1expr `(multiple-value-bind (,@syms) ,(car args) ,@(cdr args) (values ,@syms))))) (t (setq args (c1args (cdr args) info)) ; (setf (info-type info) (info-type (cadr form))) (list 'multiple-value-prog1 info form args)))) ;; (defun c1multiple-value-prog1 (args &aux (info (make-info)) form) ;; (when (endp args) (too-few-args 'multiple-value-prog1 1 0)) ;; (setq form (c1expr* (car args) info)) ;; (let ((tp (info-type (cadr form)))) ;; (cond ((single-type-p tp) (let ((s (tmpsym))) (c1expr `(let ((,s ,(car args))) ,@(cdr args) ,s)))) ;; ((and (consp tp) (eq (car tp) 'returns-exactly)) ;; (let ((syms (mapcar (lambda (x) (declare (ignore x)) (tmpsym)) (cdr tp)))) ;; (c1expr `(multiple-value-bind (,@syms) ,(car args) ,@(cdr args) (values ,@syms))))) ;; (t ;; (setq args (c1args (cdr args) info)) ;; (setf (info-type info) (info-type (cadr form))) ;; (list 'multiple-value-prog1 info form args))))) ;; We may record information here when *value-to-go* = 'top (defvar *top-data* nil) (defun c2multiple-value-prog1 (form forms &aux (base (cs-push t t)) (top (cs-push t t)) (sup (cs-push t t)) top-data) (let ((*value-to-go* 'top) *top-data*) (c2expr* form) (setq top-data *top-data*)) ;; 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 "=vs_top,*V" base "=vs_base,*V" sup "=sup;") (setq *sup-used* t) (wt-nl "vs_base=V" top ";") (dolist (form forms) (let ((*value-to-go* 'trash) (*unwind-exit* (cons (cons 'sup sup) *unwind-exit*))) (c2expr-top* form top))) (wt-nl "vs_base=V" base ";vs_top=V" top ";sup=V" sup ";}") (unwind-exit 'fun-val nil (if top-data (car top-data)))) (defun c1values (args &aux (info (make-info))(a (mapcar (lambda (x) (c1expr* x info)) args))) (when (and a (not (cdr a)) (single-type-p (info-type (cadar a)))) (return-from c1values (car a))) (setf (info-type info) (let ((x (mapcar (lambda (x) (coerce-to-one-value (info-type (cadr x)))) a))) (if (unless (cdr x) x) (car x) (cons 'returns-exactly x))));FIXME (list 'values info a)) ;; (defun c1values (args &aux (info (make-info))) ;; (cond ((and args (not (cdr args))) ;; (let ((nargs (c1args args info))) ;; (if (type>= t (info-type (cadar nargs))) ;; (c1expr (car args)) ;; (c1expr (let ((s (tmpsym))) `(let ((,s ,(car args))) ,s)))))) ;; (t ;; (setq args (c1args args info)) ;; (setf (info-type info) ;; (cmp-norm-tp ;; (cons 'returns-exactly ;; (mapcar (lambda (x) (coerce-to-one-value (info-type (cadr x)))) args)))) ;; (list 'values info args)))) (defun c2values (forms) (let* ((*inline-blocks* 0) (types (mapcar (lambda (x) (let ((x (coerce-to-one-value (info-type (cadr x))))) (if (type>= #tboolean x) t x))) forms)) (i -1) ;FIXME all of this unnecessary, just avoid valp[i]=base[0] (r (mapcar (lambda (x y &aux (x (when x (write-to-string (incf i))))) (strcat (rep-type y) " _t" x "=#" x ";")) (or forms (list (c1nil))) (or types (list #tnull)))) (i 0) (s (mapcar (lambda (x &aux (x (when x (write-to-string (incf i))))) (strcat "@" x "(_t" x ")@")) (cdr forms))) (s (strcat "({" (apply 'strcat (nconc r s)) "_t0;})"));FIXME (s (cons s (mapcar 'inline-type (cdr types)))) (in (list (inline-type (car types)) (flags) s (inline-args forms types)))) (unwind-exit in nil (cons 'values (length forms))) (close-inline-blocks))) (defun c1multiple-value-bind (args &aux (info (make-info)) (vars nil) (vnames nil) init-form ss is ts body other-decls (*vars* *vars*)) (when (or (endp args) (endp (cdr args))) (too-few-args 'multiple-value-bind 2 (length args))) (when (and (caar args) (not (cdar args))) (return-from c1multiple-value-bind (c1expr `(let ((,(caar args) ,(cadr args))) ,@(cddr args))))) (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil)) (dolist (s (car args)) (let ((v (c1make-var s ss is ts))) (push s vnames) (push v vars))) (c1add-globals (set-difference ss vnames)) (setq init-form (c1arg (cadr args) info)) (unless (let ((x (info-type (cadr init-form)))) (if (cmpt x) (not (member nil x)) x)) (eliminate-src body) (return-from c1multiple-value-bind init-form)) (when (single-type-p (info-type (cadr init-form))) (return-from c1multiple-value-bind (c1let-* (cons (cons (list (caar args) (cadr args)) (cdar args)) (cddr args)) t (cons init-form (mapcar (lambda (x) (declare (ignore x)) (c1nil)) (cdar args)))))) (setq vars (nreverse vars)) (let* ((tp (info-type (second init-form))) (tp (if (eq tp '*) (make-list (length vars) :initial-element t) (cdr tp)))) (do ((v vars (cdr v)) (t1 tp (cdr t1))) ((not v)) (set-var-init-type (car v) (if t1 (car t1) #tnull)))) (dolist (v vars) (push-var v init-form)) (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))) (ref-vars body vars) (dolist (var vars) (check-vref var)) ;; (let* ((*vars* ov));FIXME ;; (print (setq fff (trim-vars vars (make-list (length vars) :initial-element init-form) body nil))) ;; (break)) (list 'multiple-value-bind info vars init-form body)) (defun max-stack-space (form) (abs (vald (info-type (cadr form))))) (defun stack-space (form) (let* ((tp (info-type (cadr form))) (vd (vald tp))) (cond ((< vd 0) (- vd)) ((equal tp #t(returns-exactly)) 0)))) (defvar *mvb-vals* nil) (defvar *vals-set* nil) (defun c2multiple-value-bind (vars init-form body &aux (labels nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) top-data lbs) (let* ((mv (make-var :type #tfixnum :kind 'lexical :loc (cs-push #tfixnum t))) (nv (1- (length vars))) (ns1 (stack-space init-form)) (ns (max nv (or ns1 (max-stack-space init-form)))) (*mvb-vals* t) *vals-set*) (setf (var-kind mv) (c2var-kind mv) (var-space mv) nv (var-known-init mv) (or ns1 -1)) (setq lbs (mapcar (lambda (x) (let ((kind (c2var-kind x))(f (eq x (car vars)))) (if kind (setf (var-kind x) (if f kind 'object) (var-loc x) (cs-push (if f (var-type x) t) t)) (setf (var-ref x) (vs-push) x (cs-push (if f (var-type x) t) t))))) vars)) ; (wt-nl "{") ; (wt-nl "int vals_set=0;") (when vars (wt-nl "register " (rep-type (var-type (car vars))) " V" (car lbs) ";") (wt-nl "object V" (var-loc mv) "[" ns "];")) (let ((i -1)) (mapc (lambda (x) (wt-nl "#define V" x " V" (var-loc mv) "[" (incf i) "]")) (cdr lbs))) (wt-nl);FIXME (dotimes (i (1+ (length vars))) (push (next-label) labels)) (wt-nl "{") ;; (wt-nl "int vals_set=0;") (let ((*mv-var* mv) (*value-to-go* (or (mapcar (lambda (x) (list 'cvar x)) lbs) 'trash)) *top-data*) (c2expr* init-form) (setq top-data *top-data*)) (and *record-call-info* (record-call-info nil (car top-data))) (when lbs (unless *vals-set* (baboon))) ;; (wt-nl "if (!vals_set) {") ;; (setq labels (nreverse labels)) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(reset-top)(wt-go (car lab))) ;; (wt-nl "if(vs_base>=vs_top){") ;; (reset-top) ;; (wt-go (car lab)) ;; (wt "}") ;; (set-cvar '(vs-base 0) (car lb)) ;; (when (cdr lb) ;; (wt-nl "vs_base++;"))) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(wt-label (car lab))) ;; (wt-label (car lab)) ;; (set-cvar nil (car lb))) ;; (wt-nl "}}") (do ((vs vars (cdr vs)) (lb lbs (cdr lb))) ((endp vs)) (when (member (var-kind (car vs)) '(lexical special down)) (c2bind-loc (car vs) (list 'cvar (car lb)))))) (c2expr body) (mapc (lambda (x) (wt-nl "#undef V" x)) (cdr lbs)) (wt-nl "") (wt-nl "}")) ;; (defun c2multiple-value-bind (vars init-form body ;; &aux (labels nil) ;; (*unwind-exit* *unwind-exit*) ;; (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) ;; top-data lbs) ;; (multiple-value-check vars init-form) ;; (let* ((mv (make-var :type #tfixnum :kind 'lexical :loc (cs-push #tfixnum t))) ;; (nv (1- (length vars))) ;; (ns1 (stack-space init-form)) ;; (ns (max nv (or ns1 (max-stack-space init-form)))) ;; (*mvb-vals* t)) ;; (setf (var-kind mv) (c2var-kind mv) (var-space mv) nv (var-known-init mv) (or ns1 -1)) ;; (setq lbs ;; (mapcar (lambda (x) ;; (let ((kind (c2var-kind x))(f (eq x (car vars)))) ;; (if kind (setf (var-kind x) (if f kind 'object) ;; (var-loc x) (cs-push (if f (var-type x) t) t)) ;; (setf (var-ref x) (vs-push) x (cs-push (if f (var-type x) t) t))))) ;; vars)) ;; (wt-nl "{") ;; ; (wt-nl "int vals_set=0;") ;; (when vars ;; (wt-nl "register " (rep-type (var-type (car vars))) " V" (car lbs) ";") ;; (wt-nl "object V" (var-loc mv) "[" ns "];")) ;; (let ((i -1)) (mapc (lambda (x) (wt-nl "#define V" x " V" (var-loc mv) "[" (incf i) "]")) (cdr lbs))) ;; (wt-nl);FIXME ;; (dotimes (i (1+ (length vars))) (push (next-label) labels)) ;; (wt-nl "{") ;; (wt-nl "int vals_set=0;") ;; (let ((*mv-var* mv) ;; (*value-to-go* (or (mapcar (lambda (x) (list 'cvar x)) lbs) 'trash)) ;; *top-data*) ;; (c2expr* init-form) ;; (setq top-data *top-data*)) ;; (and *record-call-info* (record-call-info nil (car top-data))) ;; (wt-nl "if (!vals_set) {") ;; (setq labels (nreverse labels)) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(reset-top)(wt-go (car lab))) ;; (wt-nl "if(vs_base>=vs_top){") ;; (reset-top) ;; (wt-go (car lab)) ;; (wt "}") ;; (set-cvar '(vs-base 0) (car lb)) ;; (when (cdr lb) ;; (wt-nl "vs_base++;"))) ;; (do ((lb lbs (cdr lb)) ;; (lab labels (cdr lab))) ;; ((endp lb)(wt-label (car lab))) ;; (wt-label (car lab)) ;; (set-cvar nil (car lb))) ;; (wt-nl "}}") ;; (do ((vs vars (cdr vs)) (lb lbs (cdr lb))) ;; ((endp vs)) ;; (when (member (var-kind (car vs)) '(lexical special down)) ;; (c2bind-loc (car vs) (list 'cvar (car lb)))))) ;; (c2expr body) ;; (mapc (lambda (x) (wt-nl "#undef V" x)) (cdr lbs)) ;; (wt-nl "") ;; (wt-nl "}")) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmptest.lsp0000644000000000000000000000013114774225213015667 xustar0030 mtime=1743858315.801955256 30 atime=1744294961.293792704 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmptest.lsp0000755000175000017500000002010414774225213015266 0ustar00cammcamm;;; 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.7.1/cmpnew/PaxHeaders/gcl_cmpmain.lsp0000644000000000000000000000013114776006046015637 xustar0030 mtime=1744309286.150034344 30 atime=1744309286.274034943 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpmain.lsp0000644000175000017500000007601514776006046015247 0ustar00cammcamm;;; CMPMAIN Compiler main program. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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*));FIXME (import 'si::(*tmp-dir* *cc* *ld* *objdump*)) ;;; 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* ;t) (si::file-to-string (namestring (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :back "h")) :name "cmpinclude" :type "h")))) (defvar *compiler-default-type* #p".lsp") (defvar *compiler-normal-type* #p".lsp") (defvar *compile-file-truename* nil) (defvar *compile-file-pathname* nil) ;; 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 string "$" "\\$")) (unless (and (zerop code) (zerop result)) (cerror "Continues anyway." "(SYSTEM ~S) returned a non-zero value ~D ~D." string code result)) (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 *lsp-ext* (make-pathname :type "lsp")) (defvar *o-ext* (make-pathname :type "o")) (defvar *compile-file-truename*) (defvar *sigs* (make-hash-table :test 'eq)) (defvar *new-sigs-in-file* nil) (defun set-first-sig (x y) (unless (gethash x *sigs*) (setf (gethash x *sigs*) y))) (defun setup-sigs nil (clrhash *sigs*) (mapc (lambda (x) (set-first-sig (car x) (cdr x)) (mapc (lambda (x) (set-first-sig (car x) (list (cdr x) nil nil nil nil nil))) (caddr x))) si::*sig-discovery-props*)) (defun compile-file (fn &rest l &aux w e (*error-count* 0)) (values (handler-bind ((style-warning (lambda (c) (declare (ignore c)) (setq w t))) ((or error (and warning (not style-warning))) (lambda (c) (declare (ignore c)) (setq w t e t)))) (apply 'compile-file2 fn l)) w (or e (plusp *error-count*)))) (defun compile-file2 (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 (filename (pathname filename)) (*compile-file-pathname* (merge-pathnames filename)) (*compile-file-truename* (truename filename))) (loop (setup-sigs) (do nil ((not (eq (setq tem (let (*new-sigs-in-file*) (apply 'compile-file1 filename args))) 'again)))) (cond ((atom *split-files*)(return (when tem (truename tem)))) ((and (consp *split-files*) (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) (unless (member :output-file args) (setq args (append args (list :output-file (merge-pathnames (make-pathname :type "o") (pathname filename)))))) (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* (delete-file gaz)) (when tem (truename tem)))))) ((setf (car *split-files*) (+ (third *split-files*) section-length)))))) (defvar *init-name* nil) (defvar *function-filename* nil) (defvar *c-debug* nil) (defvar *dump-inl-hash* nil) (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*) (print *compile-print*) (external-format :default) (verbose *compile-verbose*) (prof-p *default-prof-p*) #+large-memory-model(large-memory-model-p *default-large-memory-model-p*) (load nil) &aux (*standard-output* *standard-output*) (*prof-p* prof-p) #+large-memory-model(*large-memory-model-p* large-memory-model-p) (output-file (translate-logical-pathname output-file)) (*error-output* *error-output*) (*compiler-in-use* *compiler-in-use*) (*c-debug* c-debug) (*compile-print* (or print *compile-print*)) (*compile-verbose* verbose) (*DEFAULT-PATHNAME-DEFAULTS* #p"") *data* (*fasd-data* *fasd-data*) (*init-name* *init-name*) (*function-filename* *function-filename*)) (declare (ignore external-format)) ; (declare (special *c-debug* system-p)) (when *compiler-in-use* (catch *cmperr-tag* (cmperr "~&The compiler was called recursively.~%~ Cannot compile ~a.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*)))) (return-from compile-file1 (values))) (setq *compiler-in-use* t) (unless (probe-file (merge-pathnames input-pathname *compiler-default-type*)) (catch *cmperr-tag* (cmperr "~&The source file ~a is not found.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*)))) (return-from compile-file1 (values))) (when *compile-verbose* (format t "~&;; Compiling ~a.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*)))) (and *record-call-info* (clear-call-table)) (with-open-file (*compiler-input* (merge-pathnames input-pathname *compiler-default-type*)) (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 :device (pathname-device output-file) :directory (pathname-directory output-file) :name (format nil "~a~a" (pathname-name output-file) (length (second *split-files*))) :type "o"))) (with-open-file (s output-file :if-does-not-exist :create)) (setq *init-name* (init-name output-file t)) (delete-file output-file) (setq *function-filename* (unless *compiler-compile* (namestring (truename (pathname *compiler-input*))))) (let* ((eof (cons nil nil)) (dir (or (unless (null output-file) (pathname-directory output-file)) (pathname-directory input-pathname))) (name (or (unless (null output-file) (pathname-name output-file)) (pathname-name input-pathname))) (tp (or (unless (null output-file) (pathname-type output-file)) "o")) (device (or (unless (null output-file) (pathname-device output-file)) (pathname-device input-pathname))) (o-pathname (get-output-pathname o-file tp 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));FIXME (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 (when (eq (get-macro-character #\# rtb) (get-macro-character #\# (si:standard-readtable))) (get-dispatch-macro-character #\# #\, rtb)))) (when (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* (list-split '(load :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) (and *split-files* (> (file-position *compiler-input*) (car *split-files*)))) (when *new-sigs-in-file* (keyed-cmpnote (list 'signatures (car *new-sigs-in-file*)) "Caller ~s appears after callee ~s,~% whose sig changed from ~s to ~s, restart pass1~%" (car *new-sigs-in-file*) (cadr *new-sigs-in-file*) (caddr *new-sigs-in-file*) (cadddr *new-sigs-in-file*)) (return-from compile-file1 'again)) (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))))) (when *sig-discovery* (close *compiler-output-data*) (close *compiler-input*) (return-from compile-file1 (values))) (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 (*dump-inl-hash* (dump-inl-hash (get-output-pathname output-file "hsh" 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)))) ((catch *cmperr-tag* (cmperr "~&Your C compiler failed to compile the intermediate file.~%"))))) (*compile-verbose* (print-compiler-info) (format t "~&;; Finished compiling ~a.~%" (namestring output-file)))) (unless c-file (delete-file c-pathname)) (unless h-file (delete-file h-pathname)) (unless (or data-file #+ld-not-accept-data t system-p) (delete-file data-pathname)) (when o-file o-pathname)) (progn (when (probe-file c-pathname) (delete-file c-pathname)) (when (probe-file h-pathname) (delete-file h-pathname)) (when (probe-file data-pathname) (delete-file data-pathname)) (catch *cmperr-tag* (cmperr "No FASL generated.~%")) (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-data2 form) ;; this binds all the print stuff )) (defun fun-env (name) (let ((fun (when (fboundp name) (or (macro-function name) (symbol-function name))))) (multiple-value-bind (src clo blk) (function-lambda-expression fun) (declare (ignore src blk)) (mapcar 'cadr clo)))) ;; (cond ((si::interpreted-function-p fun) ;; (multiple-value-bind ;; (src clo blk) ;; (function-lambda-expression fun) ;; (declare (ignore src blk)) ;; (mapcar 'cadr clo))) ;; ((compiled-function-p fun) (c::function-env fun 0))))) (defun get-named-form (name) (when (fboundp name) (let* ((mac (macro-function name)) (na (if (symbol-package name) name 'cmp-anon)) (fun (or mac (symbol-function name)))) (multiple-value-bind (lam clo) (function-lambda-expression fun) (assert (not (when mac clo)));FIXME? (let ((form `(,(if mac 'defmacro 'defun) ,(if mac (cons 'macro na) na) ,(cadr lam) ,@(cddr lam)))) (values (if clo `(let* ((e (fun-env ',name)) ,@(mapcar (lambda (x) `(,(car x) (pop e))) clo)) ,form) form) na)))))) (defun interpret (name &aux (form (get-named-form name))) (if (when (consp (cadr form)) (eq (caadr form) 'macro)) (setf (macro-function (cdadr form)) (eval (cons 'lambda (cddr form)))) (eval form))) (defvar *compiler-compile-data* nil) (defun compile (name &optional def &aux na tem gaz (*default-pathname-defaults* #p".")) (when (eq name 'cmp-anon) ; (remhash name si::*call-hash-table*) (dolist (l '(proclaimed-function proclaimed-arg-types proclaimed-return-type)) (remprop name l))) (cond ((not (symbolp name)) (error "Must be a name")) ((and (consp def) (eq (car def) 'lambda));(or (si::interpreted-function-p def) );FIXME (compile nil (coerce def 'function))) ((functionp def) (or name (setf name 'cmp-anon)) (setf (symbol-function name) def) (compile name)) (def (error "def not a lambda expression")) ;; FIXME -- support warnings-p and failures-p. CM 20041119 ((multiple-value-setq (tem na) (get-named-form name)) (let (warnings failures *compiler-compile-data*) (with-open-file (st (setq gaz (gazonk-name)) :direction :output)) (multiple-value-bind (fn w f) (let ((*compiler-compile* tem)) (compile-file gaz)) (when fn (load fn) (unless *keep-gaz* (delete-file fn))) (setq warnings w failures f)) (unless *keep-gaz* (delete-file gaz)) (unless (eq na name) (setf (symbol-function name) (symbol-function na))) (when *tmp-pack* (delete-package *tmp-pack*) (setq *tmp-pack* nil)) (values (symbol-function name) warnings failures))) (t (error "can't compile ~a" name)))) (defvar *codes* '((lambda (x) (code-char x)) (lambda (x) (char-code x)) (lambda (x y) (+ x y)) (lambda (x y) (declare (seqind x y)) (+ x y)) (lambda (x y) (- x y)) (lambda (x y) (declare (seqind x y)) (- x y)) (lambda (x) (- x)) (lambda (x) (declare (seqind x)) (- x)) (lambda (x y) (member x y)) (lambda (x y) (declare (symbol x)) (member x y)) (lambda (f x) (mapl f x)) (lambda (x) (mapc (lambda (x) (1+ x)) x)) (lambda (x) (coerce x 'function)) (lambda (x) (declare (function x)) (coerce x 'function)) (lambda (x) (declare (symbol x)) (coerce x 'function)) (lambda (x y) (eq x y)) (lambda (x y) (eql x y)) (lambda (x y) (declare (symbol x)) (eql x y)) (lambda (x y) (declare (fixnum x)) (eql x y)) (lambda (x y) (declare (symbol x) (fixnum x)) (eql x y)))) (defun code-size (f) (let* ((x (with-output-to-string (s) (let ((*standard-output* s)) (disassemble f)))) (b (string-match #v"\n[0-9a-f]* <[^>\n]*>:" x)) (e (string-match #v"\n[0-9a-f]* <[^>\n]*>:" x (match-end 0))) (x (subseq x b e))(i 0)(zb 0)(ze 0)) (do nil ((>= 0 (string-match #v"\n *\([0-9a-f]*\):" x i))) (setq zb (match-beginning 1) ze (match-end 1) i (match-end 0))) (let ((*read-base* 16)) (read-from-string (subseq x zb ze))))) (defun vec-to-list (x) (typecase x (string (if (find-if-not 'standard-char-p x) "fasl code" x)) ((vector t) (vec-to-list (coerce x 'list))) (cons (let ((a (vec-to-list (car x)))(d (vec-to-list (cdr x)))) (if (and (eq a (car x)) (eq d (cdr x))) x (cons a d)))) (otherwise x))) (defvar *disassemble-objdump* t) (defun disassemble (name &aux tem); &optional (asm t) file (declare (optimize (safety 1))) (check-type name (or function function-identifier)) (cond ((and (consp name) (eq (car name) 'lambda)) (dolist (l '(proclaimed-function proclaimed-return-type proclaimed-arg-types)) (remprop 'cmp-anon l)) (eval `(defun cmp-anon ,@ (cdr name))) (disassemble 'cmp-anon)) ((consp name) (disassemble (si::funid-sym name))) ((functionp name) (disassemble (si::fle name))) ((setq tem (get-named-form name)) (let ((gaz (gazonk-name))(*compiler-compile* tem)) (with-open-file (st gaz :direction :output) (prin1-cmp tem st)) (let (*fasd-data*) (multiple-value-bind (f w e) (compile-file gaz :h-file t :c-file t :data-file t :o-file t) (declare (ignore f w)) (unless e (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 #v"gazonk_[0-9]*_[0-9]*.h" a) 0) (format t "~%~d~%" a) a)))) (si::copy-stream st *standard-output*)) (with-open-file (st dn) (princ (let (f) (do nil ((eq 'eof (car (push (read st nil 'eof) f))) (vec-to-list (nreverse (cdr f)))))))) (with-open-file (st hn) (si::copy-stream st *standard-output*)) (when *disassemble-objdump* (si::copy-stream (open (concatenate 'string "|objdump --source " (namestring on))) *standard-output*)) (delete-file cn) (delete-file dn) (delete-file hn) (delete-file on) (unless *keep-gaz* (delete-file gaz)) nil)))))))) (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 (or (eq system-p 'disassemble) (probe-file ci)) system-p))) (declare (special *init-name*)) (with-open-file (st c-pathname :direction :output) (let ((*compiler-output1* (if (eq system-p 'disassemble) *standard-output* 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 c-pathname system-p))) (when system-p (wt-nl "") (wt-nl "#ifdef SYSTEM_SPECIAL_INIT") (wt-nl "SYSTEM_SPECIAL_INIT") (wt-nl "#endif")) (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 ) (declare (special *c-debug*)) (format nil "~a ~a -I~a ~a ~a -c ~a -o ~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)))) #+(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-new-safety*) 2) ((null *compiler-push-events*) 3) (t 4)) *safe-compile* *space* *speed* *debug*)) (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)) (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 "extern void gcl_init_or_load1 (void (*fn) (void), const char *file);~%") (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) (delete-file c) o)) (defun mysub (str it new) (declare (string str it new));FIXME (let ((x (search it str))) (cond ((not x) str) ((si::string-concatenate (subseq str 0 x) new (mysub (subseq str (+ x (length it))) it new)))))) (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)) (when (= 0 (system (format nil "~a ~a ~a ~a -L~a ~a ~a ~a" *ld* (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 "-rdynamic -Wl,-Map ~a" (namestring map)) #-gnu-ld "" (let* ((par (namestring (make-pathname :directory '(:relative :up)))) (i (concatenate 'string " " par)) (j (concatenate 'string " " si::*system-directory* par))) (mysub *ld-libs* i j)) (if (stringp extra-libs) extra-libs "")))) (delete-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 "(setq si::*optimize-maximum-pages* ~s si::*disable-recompile* ~s)(si::use-fast-links t)" si::*optimize-maximum-pages* si::*disable-recompile*) (format st "(si::save-system \"~a\")~%" (namestring image))) (when (= 0 (system (format nil "GCL_SYSDIR=~a GCL_LSPSYSDIR=$GCL_SYSDIR GCL_LIBDIR=~a ~a ~a < ~a" si::*system-directory* si::*lib-directory* (namestring raw) si::*system-directory* (namestring init)))) (delete-file raw) (delete-file init) image)))) (defun cdebug (&optional a) (setq *default-system-p* t *default-c-file* t *default-data-file* t *default-h-file* t *keep-gaz* a *annotate* a)) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpcall.lsp0000644000000000000000000000013114774225213015623 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.444939017 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpcall.lsp0000644000175000017500000004321614774225213015230 0ustar00cammcamm;;; CMPCALL Function call. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) (defun link-arg-p (x) (or (is-global-arg-type x) (not (is-local-arg-type x)))) (defun fast-link-proclaimed-type-p (fname &optional args) (and (symbolp fname) ; (not (get fname 'lfun)) (and (< (length args) 64) (or (and (get fname 'fixed-args) (listp args)) (and (link-arg-p (get-return-type fname)) (not (member-if-not 'link-arg-p (get-arg-types fname)))))))) (si::putprop 'funcall 'c2funcall-aux 'wholec2) (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 (fun (local-fun-obj name))) (if fun (unless (fun-src fun) (fun-fn fun)) (macro-function name))) (defun c2funcall-aux(form &aux (funob (caddr form)) (args (cadddr form))) (c2funcall funob args)) (defvar *use-sfuncall* t) (defvar *super-funcall* nil) (defun c2funcall (funob args &optional loc) (unless (listp 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) (return-from c2funcall nil)) (unless (eq 'ordinary (car funob)) (baboon)) (let* ((fn (caddr funob)) (all (cons fn args)) (*inline-blocks* 0)) (setq *sup-used* t) (unwind-exit (get-inline-loc (list (make-list (length all) :initial-element t) '* #.(flags ans set svt) (concatenate 'string "({object _z,_f=#0;fixnum _v=(fixnum)#v; fcall.fun=_f;fcall.valp=_v;fcall.argd=#n-1; _z=Rset && !(_f)->fun.fun_argd && fcall.argd>=(_f)->fun.fun_minarg && fcall.argd<=((_f)->fun.fun_maxarg) ? " (if args "(_f)->fun.fun_self(#*)" "((_f)->fun.fun_maxarg ? (_f)->fun.fun_self(#?) : (_f)->fun.fun_self(#*))") " : call_proc_cs2(#?); if (!(_f)->fun.fun_neval && !(_f)->fun.fun_vv) vs_top=_v ? (object *)_v : sup; _z;})")) all)) (close-inline-blocks))) (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 find-var (n x &optional f) (cond ((not f) (find-var n x t)) ((var-p x) (when (eq n (var-name x)) x)) ((atom x) nil) ((or (find-var n (car x) f) (find-var n (cdr x) f))))) (defun ori-p (x) (and (consp x) (eq (car x) 'var) (char= #\Z (aref (symbol-name (var-name (caaddr x))) 0)))) (defun kp (x y) (setf (get y 'kp) x) (cons x y)) (defun ll-sym (x &optional kn) (cond ((atom x) x) ((atom (car x)) (car x)) (kn (caar x)) ((cadar x)))) (defun ll-alist (l &aux k (a "G")) (mapcan (lambda (x) (cond ((member x lambda-list-keywords) (setq k x a (string (aref (symbol-name k) 1))) nil) (`(,@(when (and (consp x) (caddr x)) (list (kp (caddr x) (gensym "P")))) ,(kp (ll-sym x) (gensym a)))))) l)) ;; (defun ll-alist (l &aux k) ;; (mapcan (lambda (x) ;; (cond ((member x lambda-list-keywords) (setq k x) nil) ;; (`(,@(when (and (consp x) (caddr x)) (list (kp (caddr x) (gensym "P")))) ;; ,(kp (ll-sym x) (gensym (if k (string (aref (symbol-name k) 1)) "G"))))))) l)) (defun name-keys (l &aux k) (mapcar (lambda (x) (cond ((member x lambda-list-keywords) (setq k x) x) ((eq k '&key) (cond ((atom x) (list (list (intern (symbol-name x) 'keyword) x))) ((atom (car x)) (list* (list (intern (symbol-name (car x)) 'keyword) (car x)) (cdr x))) (x))) (x))) l)) (defun blla-recur (tag ll args last) (let* ((ll (ldiff ll (member '&aux ll)));FIXME ? impossible check? (ll (name-keys ll)) (s (ll-alist ll)) (sl (sublis s ll))) (blla sl args last `((tail-recur ,tag ,s))))) (defmacro tail-recur (&rest r) (declare (ignore r))) (defun c1tail-recur (args) (let* ((s (cadr args)) (ts (or (car (member (car args) *ttl-tags* :key 'car)) (baboon))) (ttl-tag (pop ts)) (nv (mapcar (lambda (x) (car (member (cdr x) *vars* :key (lambda (x) (when (var-p x) (var-name x)))))) s)) (ov (mapcar (lambda (x) (car (member (car x) (car ts) :key (lambda (x) (when (var-p x) (var-name x)))))) s)) (v (mapc (lambda (x) (set-var-noreplace x)) (append nv ov))) (*vars* (append v *vars*)) (*tags* (cons ttl-tag *tags*)) (*lexical-env-mask* (remove ttl-tag (set-difference *lexical-env-mask* v)))) (c1expr `(progn (setq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s)) (go ,(tag-name ttl-tag)))))) (setf (get 'tail-recur 'c1) 'c1tail-recur) (defun c2call-global (fname args loc return-type &optional lastp &aux fd (*vs* *vs*)) (assert (not (special-operator-p fname))) (assert (not (macro-function fname))) (assert (listp args)) (assert (null loc)) (assert (setq fd (get-inline-info fname args return-type (when lastp (length args))))) (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma fd) (unwind-exit (get-inline-loc fd args) nil fname) (close-inline-blocks))) (defun link-rt (tp global) (cond ((cmpt tp) `(,(car tp) ,@(mapcar (lambda (x) (link-rt x global)) (cdr tp)))) ((not tp) #tnull) ((type>= #tboolean tp) #tt);FIXME ((car (member tp `(,@(if global +c-global-arg-types+ +c-local-var-types+) t *) :test 'type<=))))) (defun ldiffn (list tail) (if tail (ldiff list tail) list)) (declaim (inline ldiffn)) (defun commasep (x) (mapcon (lambda (x) (if (cdr x) (list (car x) ",") (list (car x)))) x)) (defun ms (&rest r) (apply 'concatenate 'string (mapcar (lambda (x) (cond ((listp x) (apply 'ms x)) ((stringp x) x) ((write-to-string x)))) r))) (defun nords (n &aux (i -1)) (mapl (lambda (x) (setf (car x) (incf i))) (make-list n))) (defun nobs (n &optional (p "_x")) (mapcar (lambda (x) (ms p x)) (nords n))) (defun bind-str (nreq nsup nl) (let* ((unroll (nobs (- nreq nsup))) (decl (commasep (cons (list "_l=#" nsup) unroll))) (unroll (mapcar (lambda (x) (list nl x "=_l->c.c_car;if (_l!=Cnil) _n--;_l=_l->c.c_cdr;")) unroll)) (ndecl (unless (= nreq nsup) (list "fixnum _n=" (- (1+ nsup)) ";")))) (ms ndecl "object " decl ";" unroll))) (defun cond-str (nreq nsup st) (ms "(" (unless (= nreq nsup) (list "_n==" (- (1+ nreq)) (unless st "&&"))) (unless st "_l==Cnil") ")")) (defun mod-argstr (n call st nsup) (let* ((x (commasep (append (nobs nsup "#") (nobs (- n nsup)) (when st (list "_l"))))) (s (or (position #\# call) (length call)))) (ms (subseq call 0 s) x))) (defun nvfun-wrap (cname argstr sig clp ap) (vfun-wrap (ms cname "(" argstr ")") sig clp ap)) (defun wrong-number-args (&rest r) (error 'program-error :format-control "Wrong number of arguments to anonymous function: ~a" :format-arguments (list r))) (defun insufficient-arg-str (fnstr nreq nsup sig st &aux (sig (if st sig (cons '(*) (cdr sig)))) ;(st nil)(nreq 0) (fnstr (or fnstr (ms (vv-str 'wrong-number-args) "->s.s_gfdef")))) (ms (cdr (assoc (cadr sig) +to-c-var-alist+)) "(" (nvfun-wrap "call_proc_cs2" (ms (commasep (append (nobs nsup "#") (nobs (- nreq nsup)) `(("#" ,nsup))))) sig fnstr (1+ nreq)) ")"));FIXME better way? ;;FIXME can unroll in lisp only? ;; (defun lisp-unroll (sig args) ;; (let* ((at (car sig)) ;; (st (member '* at)) ;; (regs (ldiffn at st)) ;; (nr (length regs)) ;; (la (1- (length args))) ;; (nd (- nr la)) ;; (binds (mapc (lambda (x) (setf (car x) (tmpsym))) (make-list la))) ;; (l (tmpsym)) ;; (unrolls (mapc (lambda (x) (setf (car x) (tmpsym))) (make-list nd)))) ;; `(let (,@(mapcar 'list binds args) ;; (,l (car (last args))) ;; ,@(mapcar (lambda (x) (list x `(pop ,l))) unrolls)) ;; (if (,l) ;; (apply ',fn ,@binds ,@unrolls ,l) ;; (funcall ',fn ,@binds ,@unrolls))))) (defun maybe-unroll (argstr cname sig ap clp fnstr) (let* ((at (car sig)) (st (member '* at)) (nreq (length (ldiffn at st))) (nsup (if ap (1- ap) nreq))) (when (or (< nsup nreq) (and ap (= nsup nreq) (not st))) (let ((nl (list (string #\Newline) " "))) (ms (list "@" (nords (1+ nsup)) ";") "({" (bind-str nreq nsup nl) nl (cond-str nreq nsup st) " ? " nl (nvfun-wrap cname (mod-argstr nreq argstr st nsup) sig clp ap) " : " nl (insufficient-arg-str fnstr nreq nsup sig st) ";})"))))) (defun g1 (fnstr cname sig ap clp &optional (lev -1)) (let* ((x (make-inline-arg-str sig lev))) (or (maybe-unroll x cname sig ap clp fnstr) (nvfun-wrap cname x sig clp ap)))) ;; (defun g0 (cname sig apnarg clp &optional (lev -1)) ;; (let* ((at (car sig)) ;; (st (member '* at)) ;; (nreg (length (ldiff at st))) ;; (apreg (if apnarg (1- apnarg) nreg)) ;; (u (when (< apreg nreg) (- nreg apreg))) ;; (x (make-inline-arg-str sig lev)) ;; (ss (when u (search (strcat "#" (write-to-string apreg)) x))) ;; (x (if ss (subseq x 0 ss) x)) ;; (yy (when u (let (r) (dotimes (i u (nreverse r)) (push i r))))) ;; (yy (mapcar (lambda (x) (strcat "_x" (write-to-string x))) yy)) ;; (y (append yy (when (when st u) (list "_l")))) ;; (y (mapcon (lambda (x) (if (cdr x) (list (car x) ",") (list (car x)))) y)) ;; (y (apply 'strcat y)) ;; (z (length x))(w (length y)) ;; (s (if (or (= w 0) (= z 0) ;; (char= (char x (1- z)) #\,) (char= (char x (1- z)) #\*)) "" ",")) ;; (x (strcat x s y)) ;; (x (format nil "(~a(~a))" cname x)) ;; (x (vfun-wrap x sig clp)) ;; (ss (when apnarg (search "#n" x))) ;; (x (if ss (progn (setf (aref x (1- ss)) #\-) ;; (when u ;; (setf (aref x (+ 2 ss)) #\-) ;; (setf (aref x (+ 3 ss)) (code-char (+ (truncate u 10) (char-code #\0)))) ;; (setf (aref x (+ 4 ss)) (code-char (+ (mod u 10) (char-code #\0))))) ;; x) x)) ;; (nx (apply 'strcat (mapcar (lambda (x) (strcat x "=_l->c.c_car;_l=_l->c.c_cdr;")) yy))) ;; (nx (strcat "object _l=#" (write-to-string apreg) ;; (apply 'strcat (mapcar (lambda (x) (strcat "," x)) yy)) ";" nx)) ;; (x (if (> w 0) (concatenate 'string "({" nx x ";})") x))) ;; x)) (defun g (fname n sig &optional apnarg (clp t) &aux (cname (format nil "/* ~a */(~a)(*LnkLI~d)" (function-string fname) (rep-type (cadr sig)) n)) (fnstr (ms (vv-str fname) "->s.s_gfdef")) (clp (when clp fnstr))) (g1 fnstr cname sig apnarg clp)) ;; (defun g (fname n sig &optional apnarg (clp t) ;; &aux (cname (format nil "/* ~a */(*LnkLI~d)" (function-string fname) n)) ;; (clp (when clp (concatenate 'string (vv-str (add-object fname)) "->s.s_gfdef")))) ;; (g0 cname sig apnarg clp)) (defun call-arg-types (at la apnarg) (let* ((st (member '* at)) (reg (ldiff at st)) (nr (length reg)) (la (if apnarg (max nr (1- la)) la)) (ns (- nr la))) (cond ((> ns 0) (butlast reg ns));funcall too few args (st at) ((= ns 0) at) ((append at '(*))))));let call_proc_new foil fast linking and catch errors (defun add-fast-link (fname la &optional apnarg &aux n (at (call-arg-types (mapcar (lambda (x) (link-rt x t)) (get-arg-types fname)) la apnarg)) (rt (link-rt (get-return-type fname) t)) (clp (cclosure-p fname)) (tail (list rt at clp apnarg))) (cond ((setq n (caddar (member-if (lambda (x) (and (eq (car x) fname) (equal (cdddr x) tail))) *function-links*))) (car (member-if (lambda (x) (let ((x (last x 2))) (when (eq 'link-call (car x)) (eql n (cadr x))))) *inline-functions*))) ((let* ((n (progn (add-object2 fname) (next-cfun))) (f (flags ans set)) (f (if (single-type-p rt) f (flag-or f svt))) (f (if apnarg (flag-or f aa) f))) (push (list* fname (format nil "LI~d" n) n tail) *function-links*) (car (push (list fname at rt f (g fname n (list at rt) apnarg clp) 'link-call n) *inline-functions*)))))) ;; (defun add-fast-link (fname &optional apnarg ;; &aux n ;; (at (mapcar (lambda (x) (link-rt x t)) (get-arg-types fname))) ;; (rt (link-rt (get-return-type fname) t)) ;; (clp (cclosure-p fname)) ;; (tail (list rt at clp apnarg))) ;; (cond ((setq n (caddar (member-if ;; (lambda (x) ;; (and (eq (car x) fname) ;; (equal (cdddr x) tail))) *function-links*))) ;; (car (member-if ;; (lambda (x) ;; (let ((x (last x 2))) ;; (when (eq 'link-call (car x)) ;; (eql n (cadr x))))) *inline-functions*))) ;; ((let* ((n (next-cfun)) ;; (f (flags ans set)) ;; (f (if (single-type-p rt) f (flag-or f svt))) ;; (f (if apnarg (flag-or f aa) f))) ;; (push (list* fname (format nil "LI~d" n) n tail) *function-links*) ;; (car (push (list fname at rt f ;; (g fname n (list at rt) apnarg clp) ;; 'link-call n) ;; *inline-functions*)))))) ;;make a function which will be called hopefully only once, ;;and will establish the link. (defun wt-function-link (x) (let* ((name (pop x)) (num (pop x)) (n (pop x)) (type (pop x)) (type (or type t));FIXME (args (pop x)) (clp (pop x))) (declare (ignore n)) (cond (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) (let ((d (declaration-type (rep-type (if (link-arg-p type) type t)))));FIXME (if (or args (not (eq t type))) (wt "(object first,...){" d "V1;va_list ap;va_start(ap,first);V1=(" d ")" "call_proc_new(" (vv-str name) "," (if clp "1" "0") "," (write-to-string (argsizes args type 0));FIXME ",(void **)(void *)&Lnk" num "," (new-proclaimed-argd args type) ",first,ap);va_end(ap);return V1;}") (wt "(){" d "V1=(" d ")call_proc_new_nval(" (vv-str name) "," (if clp "1" "0") "," (write-to-string (argsizes args type 0));FIXME ",(void **)(void *)&Lnk" num "," (new-proclaimed-argd args type) ",0);return V1;}"))))) (setq name (function-string 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 (cs-push t t))) ;; (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)) (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 &aux (temp (list 'vs (vs-push)))) (let ((*value-to-go* temp)) (c2expr* funob) temp)) ;; (defun save-funob (funob &optional force) ;; (case (car funob) ;; ((call-quote-lambda call-local)) ;; (call-global ;; (unless (and (not force) ;; (inline-possible (caddr funob)) ;; (or (get (caddr funob) 'Lfun) ;; (get (caddr funob) 'Ufun) ;; (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 &optional lastp) (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) ";") (when lastp (wt-nl "{object _x=*--vs_top;for (;_x!=Cnil;_x=_x->c.c_cdr) *vs_top++=_x->c.c_car;}")) (base-used))))) (defun push-args-lispcall (args) (dolist (arg args) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* arg)))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmplam.lsp0000644000000000000000000000013114774225213015461 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.456939094 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmplam.lsp0000644000175000017500000000767714774225213015101 0ustar00cammcamm;;; CMPLAM Lambda expression. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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. (defun wfs-error () (error "This error is not supposed to occur: Contact Schelter ~ ~%wfs@math.utexas.edu")) (defun decls-from-procls (ll procls body) (cond ((or (null procls) (eq (car procls) '*) (null ll) (member (car ll) '(&whole &optional &rest &key &environment))) nil) ((eq (car procls) t) (decls-from-procls (cdr ll) (cdr procls) body)) (t (cons (list (car procls) (or (if (atom (car ll)) (car ll) (caar ll)))) (decls-from-procls (cdr ll) (cdr procls) body))))) (defun c1lambda-expr (args &aux (regs (pop args)) requireds tv doc body ss is ts other-decls (ovars *vars*) (*vars* *vars*) narg (info (make-info)) ctps) (multiple-value-setq (body ss ts is other-decls doc ctps) (c1body args t));FIXME parse-body-header (mapc (lambda (x &aux (y (c1make-var x ss is ts))) (setf (var-mt y) nil) (push-var y nil) (push y requireds)) regs) (when (member +nargs+ ts :key 'car) (setq narg (list (c1make-var +nargs+ ss is ts)))) (setq tv (append narg requireds)) (c1add-globals ss) (check-vdecl (mapcar 'var-name tv) ts is) (setq body (c1decl-body other-decls body)) (ref-vars body requireds) (dolist (var requireds) (check-vref var)) (dolist (v requireds) (when (var-p v) (unless (type>= (var-type v) (var-mt v)) (setf (var-type v) (var-mt v)))));FIXME? (let ((*vars* ovars)) (add-info info (cadr body))) (cond (*compiler-new-safety* (mapc (lambda (x) (setf (var-type x) #tt)) requireds) (let ((i (cadr body))) (setf (info-type i) (if (single-type-p (info-type i)) #tt #t*)))) ((mapc (lambda (l) (setf (var-type l) (type-and (var-type l) (nil-to-t (cdr (assoc (var-name l) ctps)))))) tv)));FIXME? `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body)) (defvar *rest-on-stack* nil) ;; non nil means put rest arg on C stack. (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. )) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmplet.lsp0000644000000000000000000000013114774225213015474 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.456939094 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmplet.lsp0000644000175000017500000003305014774225213015074 0ustar00cammcamm;;; CMPLET Let and Let*. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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 set-var-init-type (v t1);;FIXME should be in c1make-var (when (eq (var-kind v) 'lexical) (setq t1 (coerce-to-one-value t1)) (setf (var-dt v) (var-type v) (var-type v) (ensure-known-type (if *compiler-new-safety* (var-type v) (type-and t1 (var-dt v)))) (var-mt v) (var-type v) (var-loc v) (unless (and (eq (var-loc v) 'object) (unless (eq t (var-type v)) (var-type v))) (var-loc v))) (unless (var-type v) (cmpwarn "Type mismatches binding declared ~s variable ~s to type ~s." (cmp-unnorm-tp (var-dt v)) (var-name v) (cmp-unnorm-tp t1))) (keyed-cmpnote (list (var-name v) 'type-propagation 'type 'init-type) "Setting init type of ~s to ~s" (var-name v) (cmp-unnorm-tp (var-type v))))) (defun new-c1progn (f body) (let ((info (copy-info (cadr body)))) (add-info info (cadr f)) (list 'progn info (if (eq (car body) 'progn) (cons f (caddr body)) (list f body))))) ;; (defun side-effects-p (f &optional bl) ;; (cond ((atom f) nil) ;; ((eq (car f) 'setq) (let ((v (car (third f)))) (member (var-kind v) '(special global))));FIXME psetq ;; ((member (car f) '(lambda function foo)) nil) ;; ((eq (car f) 'call-global) ;; (reduce (lambda (y x) (or y (side-effects-p x))) ;; (fourth f) :initial-value (not (get (caddr f) 'c1no-side-effects)))) ;; ((eq (car f) 'block) (side-effects-p (cdddr f) (cons (caddr f) bl))) ;; ((member (car f) '(return return-from)) (or (not (member (caddr f) bl)) (side-effects-p (cdddr f) bl))) ;; ((member (car f) '(call-local ordinary funcall apply throw princ structure-set go)));FIXME ;; ((or (side-effects-p (car f) bl) (side-effects-p (cdr f) bl))))) ;; (defun ignorable-form (f) ;; (cond ((member (car f) '(function lambda))) ;; ((> (length (info-changed-array (cadr f))) 0) nil) ;; ((side-effects-p f) nil) ;; (t))) ;; (defun have-provfn (form);FIXME provisional flag ;; (cond ((atom form) (eq form 'provfn)) ;; ((or (have-provfn (car form)) (have-provfn (cdr form)))))) ;; (defun provisional-block-trim (n bp fs star) ;; (declare (ignorable n)) ;; (when *provisional-inline* ;; (or bp ;; (when star ;; (have-provfn (cdr fs)))))) (defun ignorable-form-with-local-unreferenced-changes (form vs) (let* ((i (cadr form))(ch (info-ch i)) (nch (remove-if (lambda (x) (and (member x vs) (eq (var-kind x) 'lexical) (not (eq (var-ref x) t)) (not (var-ref-ccb x)))) ch))) (ignorable-form (if (eq nch ch) form (list* (car form) (let ((i (copy-info i)))(setf (info-ch i) nch) i) (cddr form)))))) (defun trim-vars (vars forms body &optional star) (do* (nv nf (vs vars (cdr vs)) (fs forms (cdr fs)) (av (append vars *vars*)) (fv (cdr av) (cdr fv))) ((or (endp vs) (endp fs)) (list nv nf body)) (let ((var (car vs)) (form (car fs))) (cond ((and (eq (var-kind var) 'LEXICAL) (not (eq t (var-ref var))) ;;; This field may be IGNORE. (not (var-ref-ccb var))) (check-vref var) (keyed-cmpnote (list 'var-trim (var-name var)) "Trimming ~s; bound form ~a ignorable" (var-name var) (if (ignorable-form form) "" "not ")) (unless (ignorable-form-with-local-unreferenced-changes form (cdr vs));(ignorable-form form) (when star (ref-vars form (cdr vs))) (let* ((*vars* (if nf (if star fv *vars*) av)) (f (if nf (car nf) body)) (np (new-c1progn form f))) (if nf (setf (car nf) np) (setf body np))))) ((push var nv) (when star (ref-vars form (cdr vs))) (push form nf)))))) (defun mvars (args ss is ts star inls);FIXME truncate this and make-c1forms at nil type (mapcar (lambda (x) (let* ((n (if (atom x) x (pop x))) (f (unless (atom x) (car x))) (v (c1make-var n ss is ts)) (fm (if (and inls (eq f (caar inls))) (cdr (pop inls)) (c1arg f))));FIXME check (set-var-init-type v (info-type (cadr fm))) (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v))) (maybe-reverse-type-prop (var-type v) fm) (when star (push-var v fm)) (cons v fm))) args)) (defun push-var (var form) (push var *vars*) (push-vbind var form)) (defun c1let-* (args &optional star inls &aux (nm (if star 'let* 'let)) (ov *vars*) (*vars* *vars*) ss is ts body other-decls (info (make-info))) (when (endp args) (too-few-args nm 1 0)) (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) (let* ((vs (nreverse (mvars (car args) ss is ts star inls))) (vars (mapcar 'car vs)) (forms (mapcar 'cdr vs)) (vnames (mapcar 'var-name vars))) (unless star (mapc (lambda (x) (push-var (car x) (cdr x))) vs)) (when (member-if-not 'identity forms :key (lambda (x) (info-type (cadr x)))) (eliminate-src body) (setq body nil)) (c1add-globals (set-difference ss vnames)) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (unless (single-type-p (info-type (cadr body))) ;FIXME infinite recursion (let ((mv (car (member-if 'is-mv-var vars)))) (when mv (ref-vars (c1var (var-name mv)) (list mv))))) (ref-vars body vars) (dolist (var vars) (setf (var-type var) (var-mt var)));FIXME? (let* ((*vars* ov) (z (trim-vars vars forms body star)) (vars (pop z)) (fms (pop z)) (body (car z))) (dolist (fm fms) (add-info info (cadr fm))) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (if vars (list nm info vars fms body) (list* (car body) info (cddr body)))))) (defun c1let (args) (c1let-* args)) (defun c1let* (args) (c1let-* args t)) (defun c2let (vars forms body &aux block-p bindings initials (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil)) ((endp vl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (cond (kind (setf (var-kind var) kind (var-loc var) (cs-push (var-type var) t))) ((eq (var-kind var) 'down) (or (si::fixnump (var-loc var)) (wfs-error))) ((eq (var-kind var) 'special)) ((setf (var-ref var) (vs-push))) ) (if (member (var-kind var) +c-local-var-types+) (push (list 'c2expr* (list 'var var nil) form) initials) (case (car form) (LOCATION (if (can-be-replaced var body) (progn (setf (var-kind var) 'REPLACED (var-loc var) (caddr form))) (push (list var (caddr form)) bindings))) (VAR (let ((var1 (caaddr form))) (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))) ((push (list var) bindings) (unless (integerp (var-ref var)) (setf (var-ref var) (vs-push))) (list 'vs (var-ref var)))) form) initials)) ((eq (var-kind var) 'replaced)) ((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))))) ((push (list var (list 'var var1 (cadr (caddr form)))) bindings))))) (otherwise (cond ((when (and nil (symbolp (car form));FIXME (get (car form) 'wt-loc) (can-be-replaced var body) (= (var-register var) 1)) (setf (var-kind var) 'replaced) (var-loc var) form)) ((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))) ((push (list var) bindings) (unless (integerp (var-ref var)) (setf (var-ref var) (vs-push))) (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)) (cond ((type>= #tnil (info-type (cadr (third binding)))) (let ((*value-to-go* 'trash)) (c2expr* (third binding))) (let ((*value-to-go* (second binding))) (c2expr* (c1nil)))) ((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 c2let* (vars forms body &aux (block-p nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (do ((vl vars (cdr vl)) (fl forms (cdr fl))) ((endp vl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (when kind (setf (var-kind var) kind (var-loc var) (cs-push (var-type var) t))) (unless (member (var-kind var) +c-local-var-types+) (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) 'down) (or (si::fixnump (var-loc var)) (baboon))) ((member (var-kind var) '(object special))) ((setf (var-ref var) (vs-push))) )) (VAR (let ((var1 (caaddr form))) (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))))) ((member (var-kind var) '(object special))) ((setf (var-ref var) (vs-push))) ))) (otherwise (cond ((when (and nil (symbolp (car form));FIXME (get (car form) 'wt-loc) (can-be-replaced var body) (= (var-register var) 1))(print form) (setf (var-kind var) 'replaced) (var-loc var) form)) ((member (var-kind var) '(object special))) ((setf (var-ref var) (vs-push))) ; ((var-ref var) (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))) (cond ((eq (var-kind var) 'replaced)) ((type>= #tnil (info-type (cadr form))) (let ((*value-to-go* 'trash)) (c2expr* form)) (c2bind-loc var nil)) ((member (var-kind var) +c-local-var-types+) (let ((*value-to-go* (list 'var var nil))) (c2expr* form))) (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 (member (var-kind var) '(LEXICAL OBJECT REPLACED)) (not (var-cb var)) (not (var-noreplace var)) (not (is-changed var (cadr body))))) ;; (defun can-be-replaced (var body) ;; (and (member (var-kind var) '(LEXICAL OBJECT REPLACED)) ;; (not (var-cb var)) ;; (not (var-store var)) ;; (not (is-changed var (cadr body))))) ;; (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))) (when (or (eq kind 'object) (member kind +c-local-var-types+)) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))) block-p )) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpopt.lsp0000644000000000000000000000013114775021255015513 xustar0030 mtime=1744052909.996233641 30 atime=1744340056.416938838 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpopt.lsp0000644000175000017500000013354414775021255015124 0ustar00cammcamm;; Copyright (C) 2024 Camm Maguire (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")) ;;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 rfa) "@0;(type_of(#0)==t_stream? ((#0)->sm.sm_fp)!=0: 0 )") (get 'fp-okp 'inline-unsafe)) (push '((stream) boolean #.(flags set rfa)"((#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 rfa)"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 `((t) boolean #.(flags set rfa) ,(lambda (x) (add-libc "feof") (wt "(((int(*)(void *))dlfeof)((" x ")->sm.sm_fp))"))) (get 'sfeof 'inline-unsafe)) ;;SGETC1 (push `((t) fixnum #.(flags set rfa) ,(lambda (x) (add-libc "getc") (wt "(((int(*)(void *))dlgetc)((" x ")->sm.sm_fp))"))) (get 'sgetc1 'inline-unsafe)) ;;SPUTC (push `((fixnum t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(((int(*)(int,void *))dlputc)(" x ",(" y ")->sm.sm_fp))"))) (get 'sputc 'inline-always)) (push `((character t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(((int(*)(int,void *))dlputc)(char_code(" x "),(" y ")->sm.sm_fp))"))) (get 'sputc 'inline-always)) ;;FORK (push `(() t #.(flags) ,(lambda nil (add-libc "memset")(add-libc "pipe")(add-libc "close")(add-libc "fork")(wt "myfork()"))) (get 'si::fork 'inline-unsafe)) ;;READ-POINTER-OBJECT (push '((t) t #.(flags ans set)"read_pointer_object(#0)") (get 'si::read-pointer-object 'inline-unsafe)) ;;WRITE-POINTER-OBJECT (push '((t t) t #.(flags ans set)"write_pointer_object(#0,#1)") (get 'si::write-pointer-object 'inline-unsafe)) ;;READ-BYTE1 ;; (push '((t t) t #.(flags rfa ans set)"read_byte1(#0,#1)") ;; (get 'read-byte1 'inline-unsafe)) ;;READ-CHAR1 (push '((t t) t #.(flags rfa 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 rfa)"type_of(#0)==t_shortfloat") (get 'short-float-p 'inline-always)) ;;SIDE-EFFECTS (push '(nil t #.(flags)"Ct") (get 'side-effects 'inline-always)) ;;STACK-CONS ;;FIXME update this ; (push '((fixnum t t) t #.(flags) ; "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), ; STcons#0.c_cdr=(#2),(object)&STcons#0)") ; (get 'stack-cons 'inline-always)) ;;SUBLIS1 ;; (push '((t t t) t #.(flags rfa ans set)SUBLIS1-INLINE) ;; (get 'sublis1 'inline-always)) ;;FIXME the MAX and MIN optimized arg evaluations aren't logically related to side effects ;; but we need to save the intermediate results in any case to avoid exponential ;; growth in nested expressions. set added to flags for now here and in analogous ;; constructs involving ?. CM 20041129 ;;ABS ; (si::putprop 'abs 'abs-propagator 'type-propagator) (push '((t) t #.(compiler::flags) "immnum_abs(#0)") (get 'abs 'compiler::inline-always)) (push '(((integer #.(1+ most-negative-fixnum) #.most-positive-fixnum)) (integer 0 #.most-positive-fixnum) #.(flags)"abs(#0)") (get 'abs 'inline-always)) (push '((short-float) (short-float 0.0) #.(flags)"fabs(#0)") ;;FIXME ranged floating point types (get 'abs 'inline-always)) (push '((long-float) (long-float 0.0) #.(flags)"fabs(#0)") (get 'abs 'inline-always)) (push '(((real 0.0)) t #.(flags)"#0") (get 'abs 'inline-always)) (push '(((and cnum (real 0.0))) cnum #.(flags)"#0") (get 'abs 'inline-always)) ;;VECTOR-TYPE (push '((t fixnum) boolean #.(flags rfa) "@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(#1,fixint(#2),#0)") ;; (get 'system:aset 'inline-always)) ;; (push '((t t fixnum) t #.(flags set)"aset1(#1,#2,#0)") ;; (get 'system:aset 'inline-always)) ;; (push '((t t t) t #.(flags set)"aset1(#1,fix(#2),#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((t (array t) fixnum) t #.(flags set)"(#1)->v.v_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((character (array character) fixnum) character #.(flags rfa set)"(#1)->ust.ust_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array fixnum) fixnum) fixnum #.(flags set rfa)"(#1)->fixa.fixa_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array signed-short) fixnum) fixnum #.(flags rfa set)"((short *)(#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array signed-char) fixnum) fixnum #.(flags rfa set)"((#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array unsigned-short) fixnum) fixnum #.(flags rfa set) ;; "((unsigned short *)(#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array unsigned-char) fixnum) fixnum #.(flags rfa set)"((#1)->ust.ust_self)[#2]=(#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((short-float (array short-float) fixnum) short-float #.(flags rfa set)"(#1)->sfa.sfa_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((long-float (array long-float) fixnum) long-float #.(flags rfa set)"(#1)->lfa.lfa_self[#2]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((t t t t) t #.(flags set) ;; "@1;aset(#1,fix(#2)*(#1)->a.a_dims[1]+fix(#3),#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((t (array t) fixnum fixnum) t #.(flags set) ;; "@1;(#1)->a.a_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((character (array character) fixnum fixnum) character ;; #.(flags rfa set) ;; "@1;(#1)->ust.ust_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((fixnum (array fixnum) fixnum fixnum) fixnum #.(flags set rfa) ;; "@1;(#1)->fixa.fixa_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((short-float (array short-float) fixnum fixnum) short-float #.(flags rfa set) ;; "@1;(#1)->sfa.sfa_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;; (push '((long-float (array long-float) fixnum fixnum) long-float #.(flags rfa set) ;; "@1;(#1)->lfa.lfa_self[(#2)*(#1)->a.a_dims[1]+#3]= (#0)") ;; (get 'system:aset 'inline-unsafe)) ;;SYSTEM:FILL-POINTER-SET (push '((t fixnum) seqind #.(flags rfa set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) : ((#0)->st.st_fillp)))") (get 'system:fill-pointer-set 'inline-unsafe)) (push '(((vector) seqind) seqind #.(flags rfa set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) : ((#0)->st.st_fillp)))") (get 'system:fill-pointer-set 'inline-always)) ;;SYSTEM:FIXNUMP ;; (push '((t) boolean #.(flags rfa)"type_of(#0)==t_fixnum") ;; (get 'system:fixnump 'inline-always)) ;; (push '((fixnum) boolean #.(flags rfa)"1") ;; (get 'system:fixnump 'inline-always)) ;;SYSTEM:SEQINDP ;; (push '((t) boolean #.(flags rfa) #.(format nil "(type_of(#0)==t_fixnum && ({fixnum _t=fix(#0);_t>=0 && _t<=~s;}))" array-dimension-limit)) ;; (get 'system::seqindp 'inline-always)) ;; (push '((fixnum) boolean #.(flags rfa)#.(format nil "(#0>=0 && #0<=~s)" array-dimension-limit)) ;; (get 'system::seqindp 'inline-always)) ;; (push '((seqind) boolean #.(flags rfa)"1") ;; (get 'system::seqindp 'inline-always)) ;;SYSTEM:HASH-SET (push '((t t t) t #.(flags rfa) "@2;(sethash(#0,#1,#2),#2)") (get 'si::hash-set 'inline-always));FIXME ;(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)"(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:SET-MV (push '((fixnum t) t #.(flags)"(MVloc[(#0)]=(#1))") (get 'system:set-mv 'inline-always)) ;;SYSTEM:SPUTPROP (push '((symbol t t) t #.(flags set)"fSsputprop(#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)) (push '((structure) structure #.(flags)"(#0)->str.str_def") (get 'system:structure-def 'inline-always)) ;;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: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)) ;;ASH ;(si::putprop 'ash 'ash-propagator 'type-propagator) (push '((t t) t #.(compiler::flags) "immnum_shft(#0,#1)") (get 'ash 'compiler::inline-always)) (push '(((integer 0 0) t) fixnum #.(flags rfa)"0") (get 'ash 'inline-always)) (push '((fixnum (integer 0 #.(integer-length most-positive-fixnum))) fixnum #.(flags)"((#0)<<(#1))") (get 'ash 'inline-always)) (push '((fixnum (integer #.most-negative-fixnum 0)) fixnum #.(flags set) #.(concatenate 'string "@1;(-(#1)&" (write-to-string (logxor -1 (integer-length most-positive-fixnum))) "? ((#0)>=0 ? 0 : -1) : (#0)>>-(#1))")) (get 'ash 'inline-always)) ;;+ (push '((t t) t #.(flags ans)"immnum_plus(#0,#1)") (get 'si::number-plus 'inline-always)) (push '((cnum cnum) cnum #.(flags)"(#0)+(#1)") (get 'si::number-plus 'inline-always)) ;;- ;(push '((t) t #.(flags ans)"immnum_negate(#0)") (get '- 'inline-always)) ;(push '((cnum) cnum #.(flags)"-(#0)") (get '- 'inline-always)) ;(push '(((integer #.most-negative-fixnum #.most-negative-fixnum)) t #.(flags)"immnum_negate(#0)") (get '- 'inline-always)) (push '((t t) t #.(flags ans)"immnum_minus(#0,#1)") (get 'si::number-minus 'inline-always)) (push '((cnum cnum) cnum #.(flags)"(#0)-(#1)") (get 'si::number-minus 'inline-always)) (push '(((integer 0 0) t) t #.(flags ans)"immnum_negate(#1)") (get 'si::number-minus 'inline-always)) (push '(((integer 0 0) cnum) cnum #.(flags ans)"-(#1)") (get 'si::number-minus 'inline-always)) ;;* ;(si::putprop '* 'super-range 'type-propagator) (push '((t t) t #.(flags ans)"immnum_times(#0,#1)") (get 'si::number-times 'inline-always)) (push '((fixnum fixnum) integer #.(flags ans rfa)"safe_mul(#0,#1)") (get 'si::number-times 'inline-always)) (push '((cnum cnum) cnum #.(flags)"(#0)*(#1)") (get 'si::number-times 'inline-always)) ;;/ (push '((t t) t #.(flags ans) "number_divide(#0,#1)") (get 'si::number-divide 'inline-always)) (push '((cnum cnum) cnum #.(flags) "(#0)/(#1)") (get 'si::number-divide 'inline-always)) ;;/= (push '((t t) boolean #.(flags rfa)"immnum_ne(#0,#1)") (get '/= 'inline-always)) (push '((cnum cnum) boolean #.(flags rfa)"(#0)!=(#1)") (get '/= 'inline-always)) ;;< (push '((t t) boolean #.(flags rfa)"immnum_lt(#0,#1)") (get '< 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)<(#1)") (get '< 'inline-always)) ;;compiler::objlt (push '((t t) boolean #.(flags rfa)"((object)(#0))<((object)(#1))") (get 'si::objlt 'inline-always)) ;;<= (push '((t t) boolean #.(flags rfa)"immnum_le(#0,#1)") (get '<= 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)<=(#1)") (get '<= 'inline-always)) ;;= (push '((t t) boolean #.(flags rfa)"immnum_eq(#0,#1)") (get '= 'inline-always)) (push '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get '= 'inline-always)) ;;> (push '((t t) boolean #.(flags rfa)"immnum_gt(#0,#1)") (get '> 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)>(#1)") (get '> 'inline-always)) ;;>= (push '((t t) boolean #.(flags rfa)"immnum_ge(#0,#1)") (get '>= 'inline-always)) (push '((creal creal) boolean #.(flags rfa)"(#0)>=(#1)") (get '>= 'inline-always)) ;;APPEND ;; (push '((t t) t #.(flags ans)"append(#0,#1)") ;; (get 'append 'inline-always)) ;;ARRAY-DIMENSION ;(push '((t fixnum) fixnum #.(flags rfa)"@01;(type_of(#0)==t_array ? (#0)->a.a_dims[(#1)] : (#0)->v.v_dim)") ; (get 'array-dimension 'inline-unsafe)) ;;CMP-ARRAY-DIMENSION ;; (setf (symbol-function 'cmp-array-dimension) (symbol-function 'array-dimension)) ;; (push '(cmp-array-dimension-inline-types nil #.(flags itf) cmp-array-dimension-inline) ;; (get 'cmp-array-dimension 'inline-always)) ;;ARRAY-TOTAL-SIZE (push '((t) fixnum #.(flags rfa)"((#0)->st.st_dim)") (get 'array-total-size 'inline-unsafe)) ;;ARRAYP (push '((t) boolean #.(flags rfa) "@0;({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_array;})") (get 'arrayp 'inline-always)) ;;ATOM (push '((t) boolean #.(flags rfa)"atom(#0)") (get 'atom 'inline-always)) ;;BIT-VECTOR-P (push '((t) boolean #.(flags rfa)"({enum type tp=type_of(#0);tp==t_bitvector||tp==t_simple_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 rfa)"(#0)->s.s_dbind!=OBJNULL") (get 'boundp 'inline-unsafe)) (push '((symbol) boolean #.(flags rfa)"(#0)->s.s_dbind!=OBJNULL") (get 'boundp 'inline-always)) ;;CONS-CAR ; (push '((list) t #.(flags rfa)"(#0)->c.c_car") (get 'si::cons-car 'inline-always)) ;;CONS-CDR ; (push '((list) t #.(flags rfa)"(#0)->c.c_cdr") (get 'si::cons-cdr 'inline-always)) ;;CHAR-CODE ; (push '((character) fixnum #.(flags rfa)"(#0)") ; (get 'char-code 'inline-always)) ;;CHAR/= (push '((t t) boolean #.(flags rfa)"!eql(#0,#1)") (get 'char/= 'inline-unsafe)) (push '((t t) boolean #.(flags rfa)"char_code(#0)!=char_code(#1)") (get 'char/= 'inline-unsafe)) (push '((character character) boolean #.(flags rfa)"(#0)!=(#1)") (get 'char/= 'inline-unsafe)) ;;CHAR< (push '((character character) boolean #.(flags rfa)"(#0)<(#1)") (get 'char< 'inline-always)) ;;CHAR<= (push '((character character) boolean #.(flags rfa)"(#0)<=(#1)") (get 'char<= 'inline-always)) ;;CHAR= (push '((t t) boolean #.(flags rfa)"eql(#0,#1)") (get 'char= 'inline-unsafe)) (push '((t t) boolean #.(flags rfa)"char_code(#0)==char_code(#1)") (get 'char= 'inline-unsafe)) (push '((character character) boolean #.(flags rfa)"(#0)==(#1)") (get 'char= 'inline-unsafe)) ;;CHAR> (push '((character character) boolean #.(flags rfa)"(#0)>(#1)") (get 'char> 'inline-always)) ;;CHAR>= (push '((character character) boolean #.(flags rfa)"(#0)>=(#1)") (get 'char>= 'inline-always)) ;;CHARACTERP (push '((t) boolean #.(flags rfa)"type_of(#0)==t_character") (get 'characterp 'inline-always)) ;;RPLACA (push '((cons t) t #.(flags)"@0;((#0)->c.c_car=(#1),(#0))") (get 'rplaca 'inline-always)) (push '((t t) t #.(flags)"@0;((#0)->c.c_car=(#1),(#0))") (get 'rplaca 'inline-unsafe)) ;;RPLACD (push '((cons t) t #.(flags)"@0;((#0)->c.c_cdr=(#1),(#0))") (get 'rplacd 'inline-always)) (push '((t t) t #.(flags)"@0;((#0)->c.c_cdr=(#1),(#0))") (get 'rplacd 'inline-unsafe)) ;;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 rfa)"consp(#0)") (get 'consp 'inline-always)) ;;DIGIT-CHAR-P ; (push '((character) (or null (integer 0 9)) #.(flags rfa)"@0; ((#0) <= '9' && (#0) >= '0')") ; (get 'digit-char-p 'inline-always)) ;;ENDP (push '((t) boolean #.(flags rfa)"endp(#0)") (get 'endp 'inline-safe)) ;(push '((t) boolean #.(flags rfa)"(#0)==Cnil") ; (get 'endp 'inline-unsafe)) ;;EQ (push '((t t) boolean #.(flags rfa)"(#0)==(#1)") (get 'eq 'inline-always)) (push '((cnum cnum) 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 '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) (push '((character character) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) ;;FIXME -- floats? ;;EQUAL (push '((t t) boolean #.(flags rfa)"equal(#0,#1)") (get 'equal 'inline-always)) (push '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'equal 'inline-always)) (push '((character character) 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)) (push '((short-float short-float) boolean #.(flags rfa)"(#0)==(#1)") (get 'equalp 'inline-always)) (push '((long-float long-float) boolean #.(flags rfa)"(#0)==(#1)") (get 'equalp 'inline-always)) (push '((character character) 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) "fixnum_expt((#0),(#1))") (get 'expt 'inline-always)) (push `(((integer 2 2) fixnum) fixnum #.(flags) "(1L<<(#1))") (get 'expt 'inline-always)) ;; ;;si::FILL-POINTER-INTERNAL ;; (push '((t) seqind #.(flags rfa)"((#0)->v.v_fillp)") ;; (get 'si::fill-pointer-internal 'inline-unsafe)) ;; (push '((vector) seqind #.(flags rfa)"((#0)->v.v_fillp)") ;; (get 'si::fill-pointer-internal 'inline-always)) ;;ARRAY-HAS-FILL-POINTER-P (push '((t) boolean #.(flags rfa)"((#0)->v.v_hasfillp)") (get 'array-has-fill-pointer-p 'inline-unsafe)) (push '((vector) boolean #.(flags rfa)"((#0)->v.v_hasfillp)") (get 'array-has-fill-pointer-p 'inline-always)) ;;FIRST ;; (push '((t) t #.(flags)"car(#0)") ;; (get 'first 'inline-safe)) ;(push '((t) t #.(flags)"CMPcar(#0)") ; (get 'first 'inline-unsafe)) ;;FLOATP (push '((t) boolean #.(flags rfa) "@0;type_of(#0)==t_shortfloat||type_of(#0)==t_longfloat") (get 'floatp 'inline-always)) ;;FLOOR ; (push '((fixnum fixnum) fixnum #.(flags rfa) ; "@01;(#0>=0&&(#1)>0?(#0)/(#1):ifloor(#0,#1))") ; (get 'floor 'inline-always)) ;(si::putprop 'floor 'floor-propagator 'type-propagator) (push '((t t) t #.(compiler::flags) "immnum_floor(#0,#1)") (get 'floor 'compiler::inline-always)) #+intdiv (push '((fixnum fixnum) (returns-exactly fixnum fixnum) #.(flags rfa set) "@01;({fixnum _t=(#0)/(#1);_t=((#0)<=0 && (#1)<=0) || ((#0)>=0 && (#1)>=0) || ((#1)*_t==(#0)) ? _t : _t-1;@1((#0)-_t*(#1))@ _t;})") (get 'floor 'inline-always)) ;;CEILING ;(si::putprop 'ceiling 'floor-propagator 'type-propagator) (push '((t t) t #.(compiler::flags) "immnum_ceiling(#0,#1)") (get 'ceiling 'compiler::inline-always)) #+intdiv (push '((fixnum fixnum) (returns-exactly fixnum fixnum) #.(flags rfa set) "@01;({fixnum _t=(#0)/(#1);_t=((#0)<=0 && (#1)>=0) || ((#0)>=0 && (#1)<=0) || ((#1)*_t==(#0)) ? _t : _t+1;@1((#0)-_t*(#1))@ _t;})") (get 'ceiling 'inline-always)) ;;FOURTH ;; (push '((t) t #.(flags)"cadddr(#0)") ;; (get 'fourth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadddr(#0)") ; (get 'fourth 'inline-unsafe)) ;;FIFTH ;; (push '((t) t #.(flags)"cadr(cdddr(#0))") ;; (get 'fifth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadr(CMPcdddr(#0))") ; (get 'fifth 'inline-unsafe)) ;;SIXTH ;; (push '((t) t #.(flags)"caddr(cdddr(#0))") ;; (get 'sixth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcaddr(CMPcdddr(#0))") ; (get 'sixth 'inline-unsafe)) ;;SEVENTH ;; (push '((t) t #.(flags)"cadddr(cdddr(#0))") ;; (get 'seventh 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadddr(CMPcdddr(#0))") ; (get 'seventh 'inline-unsafe)) ;;EIGHTH ;; (push '((t) t #.(flags)"cadr(cdddr(cdddr(#0)))") ;; (get 'eighth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadr(CMPcdddr(CMPcdddr(#0)))") ; (get 'eighth 'inline-unsafe)) ;;NINTH ;; (push '((t) t #.(flags)"caddr(cdddr(cdddr(#0)))") ;; (get 'ninth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcaddr(CMPcdddr(CMPcdddr(#0)))") ; (get 'ninth 'inline-unsafe)) ;;TENTH ;; (push '((t) t #.(flags)"cadddr(cdddr(cdddr(#0)))") ;; (get 'tenth 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadddr(CMPcdddr(CMPcdddr(#0)))") ; (get 'tenth '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 rfa) "@0;({enum type _tp=type_of(#0);_tp==t_fixnum||_tp==t_bignum;})") (get 'integerp 'inline-always)) (push '((fixnum) boolean #.(flags rfa)"1") (get 'integerp 'inline-always)) ;;KEYWORDP (push '((t) boolean #.(flags rfa) "@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 '((vector) seqind #.(flags rfa)"((#0)->v.v_hasfillp ? (#0)->v.v_fillp : (#0)->v.v_dim)") (get 'length 'inline-always)) ;;LIST (push '((t *) list #.(flags ans rfa) LIST-INLINE);proper-list can get bumped (get 'list 'inline-always)) ;;LIST* (push '((t *) list #.(flags ans rfa) LIST*-INLINE) (get 'list* 'inline-always)) ;;CONS (push '((t t) t #.(flags ans) CONS-INLINE) (get 'cons 'inline-always)) ;;LISTP (push '((t) boolean #.(flags rfa)"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)) ;;LOGANDC1 (push '((fixnum fixnum) fixnum #.(flags rfa)"(~(#0) & (#1))") (get 'logandc1 'inline-always)) ;;LOGANDC2 (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & ~(#1))") (get 'logandc2 '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 '((seqind) proper-list #.(flags ans rfa) MAKE-LIST-INLINE) (get 'make-list 'inline-always)) (push '(((integer 0 0)) null #.(flags rfa) "Cnil") (get 'make-list 'inline-always)) ;;INTEGER-LENGTH (push '((t) t #.(compiler::flags) "immnum_length(#0)") (get 'integer-length 'compiler::inline-always)) (push '((fixnum) fixnum #.(flags rfa set) #.(format nil "({register fixnum _x=labs(#0),_t=~s;for (;_t>=0 && !((_x>>_t)&1);_t--);_t+1;})" (integer-length most-positive-fixnum))) (get 'integer-length 'inline-always)) ;;MAX (push '((t t) t #.(flags) "immnum_max(#0,#1)");"@01;(number_compare(#0,#1)>=0?(#0):#1)" (get 'max 'inline-always));FIXME ;(push '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1); fixnum_float_contagion(_r>=0 ? #0 : #1,_r>=0 ? #1 : #0);})") ; (get 'max 'inline-always)) (push '((creal creal) long-float #.(flags set)"@01;((double)((#0)>=(#1)?(#0):#1))") (get 'max 'inline-always)) (push '((creal creal) short-float #.(flags set)"@01;((float)((#0)>=(#1)?(#0):#1))") (get 'max 'inline-always)) (push '((creal creal) fixnum #.(flags set)"@01;((fixnum)((#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));FIXME ;(push '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1); fixnum_float_contagion(_r<=0 ? #0 : #1,_r<=0 ? #1 : #0);})") ; (get 'min 'inline-always)) (push '((creal creal) long-float #.(flags set)"@01;((double)((#0)<=(#1)?(#0):#1))") (get 'min 'inline-always)) (push '((creal creal) short-float #.(flags set)"@01;((float)((#0)<=(#1)?(#0):#1))") (get 'min 'inline-always)) (push '((creal creal) fixnum #.(flags set)"@01;((fixnum)((#0)<=(#1)?(#0):#1))") (get 'min 'inline-always)) ;;MOD (push '((t t) t #.(compiler::flags) "immnum_mod(#0,#1)") (get 'mod 'compiler::inline-always)) #+intdiv (push '((fixnum fixnum) fixnum #.(flags rfa set)"@01;({register fixnum _t=(#0)%(#1);((#1)<0 && _t<=0) || ((#1)>0 && _t>=0) ? _t : _t + (#1);})") (get 'mod 'inline-always)) ;;CMP-NTHCDR (push '((seqind t) list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") (get 'cmp-nthcdr 'inline-unsafe)) (push '(((not seqind) proper-list) null #.(flags rfa)"Cnil") (get 'cmp-nthcdr 'inline-unsafe)) (push '((seqind proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") (get 'cmp-nthcdr 'inline-always)) (push '(((and (integer 0) (not seqind)) proper-list) null #.(flags rfa)"Cnil") (get 'cmp-nthcdr 'inline-always)) ;;NULL (push '((t) boolean #.(flags rfa)"(#0)==Cnil") (get 'null 'inline-always)) ;;RATIONALP (push '((t) boolean #.(flags rfa)"@0;rationalp(#0)") (get 'rationalp 'inline-always)) ;;REALP (push '((t) boolean #.(flags rfa)"@0;realp(#0)") (get 'realp 'inline-always)) ;;NUMBERP (push '((t) boolean #.(flags rfa)"@0;numberp(#0)") (get 'numberp 'inline-always)) ;;EQL-IS-EQ (push '((t) boolean #.(flags rfa)"@0;eql_is_eq(#0)") (get 'eql-is-eq 'inline-always)) (push '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))") (get 'eql-is-eq 'inline-always)) ;;EQUAL-IS-EQ (push '((t) boolean #.(flags rfa)"@0;equal_is_eq(#0)") (get 'equal-is-eq 'inline-always)) (push '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))") (get 'equal-is-eq 'inline-always)) ;;EQUALP-IS-EQ (push '((t) boolean #.(flags rfa)"@0;equalp_is_eq(#0)") (get 'equalp-is-eq '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)) ;;RATIOP (push '((t) boolean #.(flags rfa) "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)) #+intdiv (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0)%(#1))") (get 'rem 'inline-always)) ;;SECOND ;; (push '((t) t #.(flags)"cadr(#0)") ;; (get 'second 'inline-safe)) ;(push '((t) t #.(flags)"CMPcadr(#0)") ; (get 'second 'inline-unsafe)) ;;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 rfa)"({enum type tp=type_of(#0);tp==t_string||tp==t_simple_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) string #.(flags ans rfa)"symbol_name(#0)") ;; (get 'symbol-name 'inline-always)) ;;SYMBOL-VALUE (push '((t) t #.(flags) "((#0)->s.s_dbind)") (get 'symbol-value 'inline-unsafe)) ;;SYMBOL-FUNCTION FIXME (push '((t) (or cons function) #.(flags rfa) "({register object _sym=#0;_sym->s.s_sfdef!=NOT_SPECIAL ? make_cons(sLspecial,make_fixnum((long)_sym->s.s_sfdef)) : (_sym->s.s_mflag ? make_cons(sSmacro,_sym->s.s_gfdef) : _sym->s.s_gfdef);})") (get 'symbol-function 'inline-unsafe)) ;;FUNCALLABLE-SYMBOL-FUNCTION (push '((t) function #.(flags rfa) "#0->s.s_gfdef") (get 'funcallable-symbol-function 'inline-always)) ;;SI::FBOUNDP-SYM (push '((t) boolean #.(flags rfa) "@0;(#0->s.s_sfdef!=NOT_SPECIAL || #0->s.s_gfdef!=OBJNULL)") (get 'si::fboundp-sym 'inline-unsafe)) (push '((symbol) boolean #.(flags rfa) "@0;(#0->s.s_sfdef!=NOT_SPECIAL || #0->s.s_gfdef!=OBJNULL)") (get 'si::fboundp-sym '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)) #+intdiv (push '((fixnum fixnum) (returns-exactly fixnum fixnum) #.(flags rfa)"({fixnum _t=(#0)/(#1);@1(#0)-_t*(#1)@ _t;})") (get 'truncate 'inline-always)) (push '((fixnum) (returns-exactly fixnum fixnum) #.(flags rfa)"({fixnum _t=(#0);@1(#0)-_t@ _t;})") (get 'truncate 'inline-always)) (push '((short-float) (returns-exactly fixnum short-float) #.(flags rfa)"({float _t=(#0);@1(#0)-_t@ _t;})") (get 'truncate 'inline-always)) (push '((long-float) (returns-exactly fixnum long-float) #.(flags rfa)"({double _t=(#0);@1(#0)-_t@ _t;})") (get 'truncate 'inline-always)) ;;COMPLEXP (push '((t) boolean #.(flags rfa) "type_of(#0)==t_complex") (get 'complexp 'inline-always)) ;;COMPLEX (push '((t t) complex #.(flags) "make_complex(#0,#1)") (get 'complex 'inline-always)) (push '((short-float short-float) fcomplex #.(flags) "(#0 + I * #1)") (get 'complex 'inline-always)) (push '((long-float long-float) dcomplex #.(flags) "(#0 + I * #1)") (get 'complex 'inline-always)) ;;VECTORP (push '((t) boolean #.(flags rfa) "@0;({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_vector;})") (get 'vectorp 'inline-always)) ;;SEQUENCEP (push '((t) boolean #.(flags rfa) "@0;(listp(#0) || ({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_vector;}))") (get 'sequencep 'inline-always)) ;;FUNCTIONP (push '((t) boolean #.(flags rfa) "(functionp(#0))") (get 'functionp 'inline-always)) ;;COMPILED-FUNCTION-P (push '((t) boolean #.(flags rfa) "(compiled_functionp(#0))") (get 'compiled-function-p 'inline-always)) ;; ;;WRITE-CHAR ;; (push '((t) t #.(flags set) ;; "@0;(writec_stream(char_code(#0),sLAstandard_outputA->s.s_dbind),(#0))") ;; (get 'write-char 'inline-unsafe)) ;;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)) ;;SI::NEXT-HASH-TABLE-INDEX (push '((t t) fixnum #.(flags rfa) "({fixnum _i;for (_i=fix(#1);_i<(#0)->ht.ht_size && (#0)->ht.ht_self[_i].hte_key==OBJNULL;_i++);_i==(#0)->ht.ht_size ? -1 : _i;})") (get 'si::next-hash-table-index 'inline-unsafe)) (push '((t fixnum) fixnum #.(flags rfa) "({fixnum _i;for (_i=(#1);_i<(#0)->ht.ht_size && (#0)->ht.ht_self[_i].hte_key==OBJNULL;_i++);_i==(#0)->ht.ht_size ? -1 : _i;})") (get 'si::next-hash-table-index 'inline-unsafe)) ;;SI::HASH-ENTRY-BY-INDEX (push '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_value") (get 'si::hash-entry-by-index 'inline-unsafe)) (push '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_value") (get 'si::hash-entry-by-index 'inline-unsafe)) ;;SI::HASH-KEY-BY-INDEX (push '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_key") (get 'si::hash-key-by-index 'inline-unsafe)) (push '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_key") (get 'si::hash-key-by-index 'inline-unsafe)) ;;si::GENSYM0 (push '(nil symbol #.(flags ans set rfa) "fSgensym0()") (get 'si::gensym0 'inline-always)) ;;si::GENSYM1S (push '((string) symbol #.(flags ans set rfa) "fSgensym1s(#0)") (get 'si::gensym1s 'inline-always)) ;;si::GENSYM1IG (push '((t) symbol #.(flags ans set rfa) "fSgensym1ig(#0)") (get 'si::gensym1ig 'inline-always)) ;;SI::HASH-SET (push '((t t t) t #.(flags) "@2;(sethash(#0,#1,#2),#2)") (get 'si::hash-set 'inline-unsafe)) ;;New C ffi ;; ;(push '((t fixnum opaque *) opaque #.(flags rfa) "(#0(#1))(#2#*)") (get 'addr-call 'inline-always)) ;(push '((t fixnum) opaque #.(flags rfa) "(#0(#1))()") (get 'addr-call 'inline-always)) (push '(((member :address) t) fixnum #.(flags rfa) "object_to_fixnum(#1)") (get 'unbox 'inline-always)) (push '(((member :address) fixnum) fixnum #.(flags rfa) "(#1)") (get 'unbox 'inline-always)) ;; (defun register-key (l tt) ;; (push `(((member ,l) t t t) ,tt ,(flags rfa) "((#1)->#2.#3)") ;; (get 'el 'inline-always)) ;; (push `(((member ,l) t t t seqind) ,tt ,(flags rfa) "((#1)->#2.#3[#4])") ;; (get 'el 'inline-always)) ;; (push `((,tt (member ,l) t t t) ,tt ,(flags rfa) "((#2)->#3.#4=(#0))") ;; (get 'set-el 'inline-always)) ;; (push `((,tt (member ,l) t t t seqind) ,tt ,(flags rfa) "((#2)->#3.#4[#5]=(#0))") ;; (get 'set-el 'inline-always)) ;; ) (deftype stdesig nil '(or string symbol character)) (deftype longfloat nil 'long-float) (deftype shortfloat nil 'short-float) (deftype hashtable nil 'hash-table) (deftype ocomplex nil 'complex) (deftype bitvector nil 'bit-vector) (deftype random nil 'random-state) (deftype cfun nil 'function);FIXME ; (deftype cclosure nil 'function);FIXME ; (deftype closure nil 'function);FIXME ; (deftype sfun nil 'function);FIXME (deftype ifun nil 'function);FIXME ; (deftype vfun nil 'function);FIXME (deftype ustring nil 'string);FIXME (deftype fixarray nil '(array fixnum)) (deftype sfarray nil '(array short-float)) (deftype lfarray nil '(array long-float)) ;;si::c-type (push '((t) #.(cmp-unnorm-tp (c-type-propagator 'si::c-type #tt)) #.(flags rfa) "type_of(#0)") (get 'si::c-type 'inline-always)) (push '((long-float) short-float #.(flags rfa) "((float)#0)" ) (get 'si::long-to-short 'inline-always)) (push '((t) short-float #.(flags) "((float)lf(#0))" ) (get 'si::long-to-short 'inline-unsafe)) (push '((long-float) short-float #.(flags rfa) "((float)#0)" ) (get 'si::long-to-short 'inline-unsafe)) (push '((bignum) long-float #.(flags) "big_to_double(#0)" ) (get 'si::big-to-double 'inline-always)) (push '((t) long-float #.(flags) "big_to_double(#0)" ) (get 'si::big-to-double 'inline-unsafe)) (push '((bignum) long-float #.(flags) "big_to_double(#0)" ) (get 'si::big-to-double 'inline-unsafe)) (push '(((complex)) t #.(flags) "(#0)->cmp.cmp_real") (get 'complex-real 'inline-always)) (push '((fcomplex) short-float #.(flags) "creal(#0)") (get 'complex-real 'inline-always)) (push '((dcomplex) long-float #.(flags) "creal(#0)") (get 'complex-real 'inline-always)) (push '((t) t #.(flags) "(#0)->cmp.cmp_real") (get 'complex-real 'inline-unsafe));FIXME (push '((fcomplex) short-float #.(flags) "creal(#0)") (get 'complex-real 'inline-unsafe)) (push '((dcomplex) long-float #.(flags) "creal(#0)") (get 'complex-real 'inline-unsafe)) (push '(((complex)) t #.(flags) "(#0)->cmp.cmp_imag") (get 'complex-imag 'inline-always)) (push '((fcomplex) short-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-always)) (push '((dcomplex) long-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-always)) (push '((t) t #.(flags) "(#0)->cmp.cmp_imag") (get 'complex-imag 'inline-unsafe));FIXME (push '((fcomplex) short-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-unsafe)) (push '((dcomplex) long-float #.(flags) "cimag(#0)") (get 'complex-imag 'inline-unsafe)) (push '((ratio) integer #.(flags rfa) "(#0)->rat.rat_num") (get 'ratio-numerator 'inline-always)) (push '((ratio) integer #.(flags rfa) "(#0)->rat.rat_den") (get 'ratio-denominator 'inline-always)) (push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isinf") (wt "(((int(*)(double))dlisinf)(" x "))"))) (get 'si::isinf 'inline-always)) (push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isnan") (wt "(((int(*)(double))dlisnan)(" x "))"))) (get 'si::isnan '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)) ;;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)) ;;LOGTEST (push '((t t) boolean #.(compiler::flags) "immnum_logt(#0,#1)") (get 'logtest 'compiler::inline-always)) ;LDB (push '(((cons fixnum fixnum) fixnum) fixnum #.(compiler::flags) "fixnum_ldb(fix(#0->c.c_car),fix(#0->c.c_cdr),#1)") (get 'ldb 'compiler::inline-always)) ;LDB-TEST (push '(((cons fixnum fixnum) fixnum) boolean #.(compiler::flags) "fixnum_ldb(fix(#0->c.c_car),fix(#0->c.c_cdr),#1)") (get 'ldb-test 'compiler::inline-always)) ;DPB (push '((fixnum (cons fixnum fixnum) fixnum) t #.(compiler::flags) "fixnum_dpb(fix(#1->c.c_car),fix(#1->c.c_cdr),#0,#2)") (get 'dpb 'compiler::inline-always)) ;DEPOSIT-FIELD (push '((fixnum (cons fixnum fixnum) fixnum) t #.(compiler::flags) "fixnum_dpf(fix(#1->c.c_car),fix(#1->c.c_cdr),#0,#2)") (get 'deposit-field 'compiler::inline-always)) ;;MINUSP (push '((t) boolean #.(flags) "immnum_minusp(#0)") (get 'minusp 'inline-always));"number_compare(small_fixnum(0),#0)>0" ;;PLUSP (push '((t) boolean #.(flags) "immnum_plusp(#0)") (get 'plusp 'inline-always));"number_compare(small_fixnum(0),#0)>0" ;;ZEROP (push '((t) boolean #.(flags) "immnum_zerop(#0)") (get 'zerop 'inline-always));"number_compare(small_fixnum(0),#0)==0" ;;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)) (setf (get :boolean 'lisp-type) 'boolean) (setf (get :void 'lisp-type) nil) (setf (get :cnum 'lisp-type) 'cnum) (setf (get :creal 'lisp-type) 'creal) (dolist (l '((:float "make_shortfloat" short-float cnum) (:double "make_longfloat" long-float cnum) (:character "code_char" character cnum) (:char "make_fixnum" char cnum) (:short "make_fixnum" short cnum) (:int "make_fixnum" int cnum) (:uchar "make_fixnum" unsigned-char cnum) (:ushort "make_fixnum" unsigned-short cnum) (:uint "make_fixnum" unsigned-int cnum) (:fixnum "make_fixnum" fixnum cnum) (:long "make_fixnum" fixnum cnum) (:fcomplex "make_fcomplex" fcomplex cnum) (:dcomplex "make_dcomplex" dcomplex cnum) (:string "make_simple_string" string) (:object "" t) (:char* nil nil (array character) "->st.st_self") (:float* nil nil (array short-float) "->sfa.sfa_self") (:double* nil nil (array long-float) "->lfa.lfa_self") (:long* nil nil (array fixnum) "->fixa.fixa_self") (:void* nil nil (array t) "->v.v_self"))) (setf (get (car l) 'lisp-type) (if (cadr l) (caddr l) (cadddr l))) (when (cadr l) (push `(((member ,(car l)) opaque) t #.(flags rfa) ,(strcat (cadr l) "(#1)")) (get 'box 'inline-always)) (push `(((member ,(car l)) t) opaque #.(flags rfa) ,(if (eq (car l) :object) "(#1)" (strcat "object_to_" (car l) "(#1)"))) (get 'unbox 'inline-always))) (when (cadddr l) (push `(((member ,(car l)) ,(cadddr l)) opaque #.(flags rfa) ,(if (fifth l) (strcat "(#1)" (fifth l)) (strcat "(" (car l) ")" "(#1)"))) (get 'unbox 'inline-always)))) (dolist (l '(char short long int integer keyword character real string structure symbol fixnum)) (let ((s (intern (symbol-name l) 'keyword))) (setf (get s 'lisp-type) l))) (dolist (l '((object t)(plist proper-list)(float short-float)(double long-float) (pack (or null package)) (direl (or keyword null string)))) (let ((s (intern (symbol-name (car l)) 'keyword))) (setf (get s 'lisp-type) (cadr l)))) (defvar *box-alist* (mapcar (lambda (x) (cons x (cadr (assoc (get x 'lisp-type) *c-types*)))) '(:char :fixnum :float :double :fcomplex :dcomplex))) (do-symbols (s :keyword) (let ((z (get s 'lisp-type :opaque))) (unless (eq z :opaque) (setf (get s 'cmp-lisp-type) (or (cadr (assoc (get s 'lisp-type) *c-types*)) (cmp-norm-tp z)))))) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmptype.lsp0000644000000000000000000000013114774225213015671 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.472939196 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmptype.lsp0000644000175000017500000013337314774225213015302 0ustar00cammcamm;;; CMPTYPE Type information. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) (defstruct (binding (:print-function (lambda (x s i) (s-print 'binding (binding-repeatable x) (si::address x) s)))) form repeatable) (defun naltp (tp &aux (catp (car (atomic-tp tp)))) (labels ((g (x) (when (binding-p x) (return-from naltp catp))) (f (x) (if (consp x) (or (g (car x)) (f (cdr x))) (g x)))) (f catp))) (defun explode-nalt (tp) (labels ((g (x) (if (binding-p x) (if (binding-form x) (cmp-unnorm-tp (info-type (cadr (binding-form x)))) t) `(member ,x))) (f (x) (if (consp x) `(cons ,(g (car x)) ,(f (cdr x))) (g x)))) (cmp-norm-tp (f tp)))) (defun cons-type-p (ktp tp) (let ((a (type-and ktp tp))) (when (consp a) (member-if #'identity (cdr (caar (third a))) :key 'car)))) (defun needs-explode (t1 t2 &aux (n (naltp t1))) (when (and n (cons-type-p (if (typep n 'proper-cons) #tproper-cons #tsi::improper-cons) t2)) n)) (defun ctp-and (t1 t2 &aux n) (cond ((setq n (needs-explode t1 t2)) (when (tp-and (explode-nalt n) t2) t1)) ((setq n (needs-explode t2 t1)) (when (tp-and (explode-nalt n) t1) t2)) ((tp-and t1 t2)))) (defun ctp<= (t1 t2 &aux n) (cond ((setq n (needs-explode t1 t2)) (when (tp-and (explode-nalt n) t2) t));hash ((tp<= t1 t2)))) (defun null-list (x) (when (plusp x) (make-list x :initial-element #tnull))) (defun type-and (x y) (cond ((eq x '*) y) ((eq y '*) x) ((and (cmpt x) (cmpt y)) (let ((lx (length x))(ly (length y))) (cons (if (when (eql lx ly) (when (eq (car x) (car y)) (eq (car x) 'returns-exactly))) 'returns-exactly 'values) (mapcar 'type-and (append (cdr x) (null-list (- ly lx))) (append (cdr y) (null-list (- lx ly))))))) ((cmpt x) (type-and (or (cadr x) #tnull) y)) ((cmpt y) (type-and x (or (cadr y) #tnull))) ((ctp-and x y)))) (defun type-or1 (x y) (cond ((eq x '*) x) ((eq y '*) y) ((and (cmpt x) (cmpt y)) (let ((lx (length x))(ly (length y))) (cons (if (when (eql lx ly) (when (eq (car x) (car y)) (eq (car x) 'returns-exactly))) 'returns-exactly 'values) (mapcar 'type-or1 (append (cdr x) (null-list (- ly lx))) (append (cdr y) (null-list (- lx ly))))))) ((cmpt x) (type-or1 x `(returns-exactly ,y))) ((cmpt y) (type-or1 `(returns-exactly ,x) y)) ((tp-or x y)))) (defun type<= (x y) (cond ((eq y '*)) ((eq x '*) nil) ((and (cmpt x) (cmpt y)) (do ((x (cdr x) (cdr x))(y (cdr y) (cdr y))) ((and (not x) (not y)) t) (unless (type<= (if x (car x) #tnull) (if y (car y) #tnull)) (return nil)))) ((cmpt x) (type<= x `(returns-exactly ,y)));FIXME ((cmpt y) (type<= `(returns-exactly ,x) y)) ((ctp<= x y)))) (defun type>= (x y) (type<= y x)) (defun type= (x y) (when (type<= y x) (type<= x y))) (defun get-sym (args) (intern (apply 'concatenate 'string (mapcar 'string args)))) (defvar *c-types* (mapcar (lambda (x &aux (y (pop x))) (list* y (cmp-norm-tp y) x)) `((nil nil nil nil "" "" "object ") (null nil nil inline-cond "" "" "object ") (true nil nil inline-cond "" "" "object ") (boolean nil nil inline-cond "" "" "object ") (character wt-character-loc nil inline-character "char_code" "code_char" "int8_t ") (bit wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (non-negative-char wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (unsigned-char wt-char-loc return-char inline-char "fix" "make_fixnum" "uint8_t ") (signed-char wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (char wt-char-loc return-char inline-char "fix" "make_fixnum" "int8_t ") (non-negative-short wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int16_t ") (unsigned-short wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "uint16_t ") (signed-short wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int16_t ") (short wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int16_t ") (non-negative-int wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int32_t ") (unsigned-int wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "uint32_t ") (signed-int wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int32_t ") (int wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "int32_t ") (non-negative-fixnum wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "fixnum ") (fixnum wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "fixnum ") (long wt-fixnum-loc return-fixnum inline-fixnum "fix" "make_fixnum" "fixnum ") (short-float wt-short-float-loc return-short-float inline-short-float "sf" "make_shortfloat" "float ") (long-float wt-long-float-loc return-long-float inline-long-float "lf" "make_longfloat" "double ") (creal nil nil nil "" "" "") (fcomplex wt-fcomplex-loc return-fcomplex inline-fcomplex "sfc" "make_fcomplex" "fcomplex ") (dcomplex wt-dcomplex-loc return-dcomplex inline-dcomplex "lfc" "make_dcomplex" "dcomplex ") (cnum nil nil nil "" "" "") (string wt-string-loc return-string inline-string "object_to_string" "make_simple_string" "char *") (t wt-loc return-object inline "" "" "object ")))) (defconstant +c-global-arg-types-syms+ `(fixnum)) ;FIXME (long-float short-float) later (defconstant +c-local-arg-types-syms+ (union +c-global-arg-types-syms+ '(char fixnum long-float short-float fcomplex dcomplex))) (defconstant +c-local-var-types-syms+ (union +c-local-arg-types-syms+ '(char fixnum long-float short-float fcomplex dcomplex))) (defvar +value-types+ (mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (get-sym `(,x "-VALUE")))) (list* 'character +c-local-var-types-syms+))) (defconstant +return-alist+ (mapcar (lambda (x) (cons (if (eq x 'object) x (cadr (assoc x *c-types*))) (get-sym `("RETURN-" ,x)))) (cons 'object +c-local-arg-types-syms+))) (defconstant +wt-loc-alist+ `((object . wt-loc) ,@(mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (get-sym `("WT-" ,x "-LOC")))) (cons 'string +c-local-var-types-syms+)))) (defconstant +inline-types-alist+ `(,@(mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (case x ((t) 'inline) (boolean 'inline-cond) (otherwise (get-sym `("INLINE-" ,x)))))) (list* 'boolean t 'string +c-local-var-types-syms+)))) (defconstant +c-global-arg-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +c-global-arg-types-syms+)) (defconstant +c-local-arg-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +c-local-arg-types-syms+)) (defconstant +c-local-var-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +c-local-var-types-syms+)) (defconstant +wt-c-var-alist+ (nconc (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (seventh z))) (list* 'character 'string +c-local-var-types-syms+)) `((object . "")))) (defconstant +to-c-var-alist+ (nconc (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (sixth z))) (list* 'character 'string +c-local-var-types-syms+)) `((object . "")))) (defconstant +c-type-string-alist+ (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (eighth z))) `(t bit character signed-char non-negative-char unsigned-char signed-short non-negative-short unsigned-short fixnum non-negative-fixnum signed-int non-negative-int unsigned-int long-float short-float fcomplex dcomplex))) (defconstant +cmp-array-types+ (mapcar (lambda (x) (cadr (assoc x *c-types*))) +array-types+)) (defconstant +wt-c-rep-alist+ (nconc (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (eighth z))) (list* nil +c-local-var-types-syms+)) `((object . "object ")))) (defconstant +defentry-c-rep-alist+ (mapcar (lambda (x &aux (z (assoc x *c-types*))) (cons (cadr z) (eighth z))) '(char #+64bit signed-int fixnum short-float long-float string t))) (defconstant +cmp-type-alist+ (mapcar (lambda (x) (cons (cmp-norm-tp (car x)) (cdr x))) +type-alist+)) ;FIXME? (defconstant +promoted-c-types+ (nconc (mapcar (lambda (x) (cadr (assoc x *c-types*))) '(nil null boolean)) +c-local-var-types+)) (defconstant +clzl0+ (let ((x (1- fixnum-length))) (cmp-norm-tp `(integer ,x ,x)))) (defconstant +coersion-alist+ (mapcar (lambda (x) (cons (cadr (assoc x *c-types*)) (get-sym `(,x "-LOC")))) +c-local-var-types-syms+)) (defconstant +number-inlines+ (mapcar 'cdr (remove-if-not (lambda (x) (type>= #tnumber (car x))) +inline-types-alist+))) (defstruct opaque) (defmacro nil-to-t (x) `(or ,x t)) (defun name-to-sd (x &aux (sd (when (symbolp x) (get x 's-data)))) (unless sd (error "The structure ~a is undefined." x)) sd) (defvar *tmpsyms* nil) (defun tmpsym nil (let ((x (or (pop *tmpsyms*) (gensym)))) (setf (symbol-plist x) '(tmp t)) x)) (defconstant +tmpsyms+ (let ((*gensym-counter* 0)) (mapl (lambda (x) (rplaca x (tmpsym))) (make-list 1000)))) (defconstant +opaque+ (gensym)) (defvar *car-limit* -1);1) (defvar *cdr-limit* -1);5) (defun cons-tp-limit (x i j) (declare (seqind i j)) (cond ((> i *car-limit*) nil) ((> j *cdr-limit*) nil) ((atom x) t) ((and (cons-tp-limit (car x) (1+ i) 0) (cons-tp-limit (cdr x) i (1+ j)))))) (defun cons-tp-limit-tp (x i j) (declare (seqind i j)) (cond ((> i *car-limit*) nil) ((> j *cdr-limit*) nil) ((atom x)) ((not (eq (car x) 'cons))) ((and (cons-tp-limit-tp (cadr x) (1+ i) 0) (cons-tp-limit-tp (caddr x) i (1+ j)))))) (defun object-type (thing) (object-tp thing)) (defconstant +real-contagion-list+ si::+range-types+) (defun get-inf (x) (etypecase x (integer (if (plusp x) '+iinf (if (minusp x) '-iinf 'inan))) (rational (if (plusp x) '+rinf (if (minusp x) '-rinf 'rnan))) (float (float (if (plusp x) +inf (if (minusp x) -inf nan)) x)))) (defun pole-type (y) (etypecase y (integer 'integer) (short-float 'short-float) (long-float 'long-float))) (defun tp-to-inf (tp x) (ecase tp (integer (if x '-iinf '+iinf)) (ratio (if x '-rinf '+rinf)) (short-float (if x -sinf +sinf)) (long-float (if x -inf +inf)))) (defun bnds-to-bounds (tp x) (when x (let ((y (pop x))) (cons (cond ((eq y '*) (tp-to-inf tp x)) ((consp y) (cons (if x 1 -1) y)) (y)) (bnds-to-bounds tp x))))) (defun bound-num (x) (cond ((member x '(+iinf +rinf)) +sinf) ((member x '(-iinf -rinf)) -sinf) ((member x '(inan rnan)) snan) ((consp x) (cadr x)) (x))) (defun rat-bound-p (x) (or (member x '(+iinf -iinf inan +rinf -rinf rnan)) (rationalp (if (consp x) (cadr x) x)))) (defun int-bound-p (x) (or (member x '(+iinf -iinf inan)) (integerp (if (consp x) (cadr x) x)))) ;; (& ^ \| ~) ;; (logand logior logxor logeqv logandc1 logandc2 logorc1 logorc2 lognand lognor lognot) ;; (+ - * max min si::number-plus si::number-times si::number-minus pexpt /-pole) ;; (gcd lcm) ;; (mod rem) ;; (floor ceiling truncate round ffloor fceiling ftruncate fround) ;; (ash >> << integer-length clzl ctzl abs ) (defun ?rationalize (x f r &aux (z (or (eq f '/-pole) (member-if-not 'int-bound-p r)))) (cond ((not (member f '(+ - * max min si::number-plus si::number-times si::number-minus pexpt /-pole))) x);closed functions over rationals plus pexpt ((member-if-not 'rat-bound-p r) x) ((unless (int-bound-p (cadr r)) (eq f 'pexpt)) x) ((isinf x) (if (plusp x) (if z '+rinf '+iinf) (if z '-rinf '-iinf))) ((isnan x) (if z 'rnan 'inan)) ((numberp x) (rational x)) (x))) (defun ?list-bound (x r) (if (when (and (numberp x) (member-if 'consp r)) (not (or (isinf x) (isnan x)))) (list x) x)) (defun pole-d (x) (if (consp x) (car x) 0)) (defun pole-check (f r) (si::break-on-floating-point-exceptions :suspend t) (prog1 (apply f (if (when (symbolp f) (get f 'pole)) r (mapcar 'bound-num r))) (si::break-on-floating-point-exceptions :suspend nil))) (defun mfc1 (f &rest r) (?list-bound (?rationalize (pole-check f r) f r) r)) (defun infp (x m) (member x (if m `(-iinf -rinf ,-sinf ,-inf) `(+iinf +rinf ,+sinf ,+inf)))) (defun nanp (x) (or (member x '(inan rnan)) (isnan x))) (defun minmax1 (tp m) (or (reduce (lambda (y x &aux (x (if (when (consp x) (eq (cdr x) 'incl)) (car x) x))) (cond ((eq y '*) y) ((infp x m) '*) ((infp x (not m)) (or y 0)) ((nanp x) y);'* ((not y) x) ((funcall (if m '< '>) (if (consp x) (car x) x) (if (consp y) (car y) y)) x) ((when (atom x) (when (consp y) (eql x (car y)))) x) (y))) tp :initial-value nil) '*)) (defun inf-tp (x) (case x ((+iinf -iinf inan) 'integer) ((+rinf -rinf rnan) 'ratio))) (defun mk-tp2 (tp &aux (mm1 (minmax1 tp t)) (mm2 (minmax1 tp nil))) (reduce 'type-or1 (mapcar (lambda (x) (when (member-if (lambda (y &aux (y (if (listp y) (if (integerp (car y)) 1/2 (car y)) y))) (or (typep y x) (eq (inf-tp y) x))) tp) (cmp-norm-tp `(,(if (eq x 'ratio) 'rational x) ,mm1 ,mm2)))) si::+range-types+) :initial-value nil)) (defun outer-merge (&rest r &aux (z (pop r))) (mapcan (lambda (z) (mapcar (lambda (x) (cons z x)) (if r (apply 'outer-merge r) (list nil)))) z)) (defun ar-merge (&rest r) (mapcar (lambda (x &aux (p1 (pop x))(b1 (real-bnds x))) (unless (car b1) (return-from ar-merge nil)) (bnds-to-bounds p1 b1)) r)) (defun mk-contagion-rep (f ?complex r &aux (i 1)) (apply f (mapcar (lambda (x &aux (p (pop x)) (y (contagion-irep (incf i) p))) (if ?complex (complex y (contagion-irep (incf i) p)) y)) r))) (defun dsrg (f &rest r &aux (z (apply 'ar-merge r))) (if z (let* ((v (mapcar (lambda (x) (apply 'mfc1 f x)) (apply 'outer-merge z))) (vc (remove-if-not 'mfc-complexp v)) (vr (set-difference v vc))) (reduce 'type-or1 (mapcar 'complex-contagion vc) :initial-value (mk-tp2 vr))) (complex-contagion (mk-contagion-rep f t r)))) (defun super-range (f &rest r) (reduce 'type-or1 (mapcar (lambda (x) (apply 'dsrg f x)) (apply 'outer-merge (mapcar 'range-decomp r))) :initial-value nil)) ; libm standard poles ; / mod rem truncate etc. 0 two-sided ; atanh +-1 branch-cut ; log 0 branch-cut ; expt/pow 0 neg same as / ; lgamma/tgamma neg int (defconstant +small-rat+ (rational least-positive-long-float)) (defun contagion-irep (x tp) (case tp (ratio (if (or (= 0 x) (= 1 x)) x (+ x (/ 1 x)))) (integer x) (otherwise (coerce x tp)))) (defconstant +cmp-range-types+ (let ((z '(integer ratio short-float long-float))) (nconc (mapcar (lambda (x) (cons x (cmp-norm-tp x))) z) (mapcar (lambda (x) (cons x (case x (integer #t(complex rational)) (ratio #t(and (complex rational) (not (complex integer)))) (otherwise (cmp-norm-tp `(complex ,x)))))) z)))) (defun complex-contagion (z &aux (z (if (listp z) (car z) z))) (cadar (member z '#.(mapcar (lambda (x &aux (x `(complex ,x))) (list x (cmp-norm-tp x))) '(integer rational short-float long-float real)) :test 'typep :key 'car))) (defun mfc-complexp (x &aux (x (if (listp x) (car x) x))) (complexp x)) (defun range-decomp (tp) (mapcan (lambda (x &aux (f (pop x))(z (type-and tp x))) (when z (list (cons f z)))) +cmp-range-types+)) (dolist (l '(si::number-plus si::number-minus si::number-times + - * exp tanh sinh asinh)) (si::putprop l 'super-range 'type-propagator)) (defun atan-propagator (f t1 &optional (t2 nil t2p)) (if t2p (type-or1 (super-range f (type-and #tnon-negative-real t1) (type-and #tnon-negative-real t2)) (type-or1 (super-range f (type-and #tnon-negative-real t1) (type-and #tnegative-real t2)) (type-or1 (super-range f (type-and #tnegative-real t1) (type-and #tnon-negative-real t2)) (super-range f (type-and #tnegative-real t1) (type-and #tnegative-real t2))))) (super-range f t1))) (si::putprop 'atan 'atan-propagator 'type-propagator) (defun float-propagator (f t1 &optional (t2 (or (type-and #tfloat t1) #t(member 0.0))) &aux (t1 (type-and #treal t1))(t2 (type-and #tfloat t2))) (when (and t1 t2) (super-range f t1 t2))) (setf (get 'float 'type-propagator) 'float-propagator) (defun bit-type (tp) (cond ((not tp) tp) ((atomic-tp tp) tp) ((type>= #tinteger tp) (let* ((tp (list* 'integer (real-bnds tp))) (l (cadr tp)) (l (if (consp l) (car l) l)) (h (caddr tp)) (h (if (consp h) (car h) h)) (h (if (eq h '*) h (if (>= h 0) (1- (ash 1 (integer-length h))) -1))) (l (if (eq l '*) l (if (< l 0) (- (ash 1 (integer-length l))) 0)))) (cmp-norm-tp `(integer ,l ,h)))))) (defun logand2-propagator (f t1 t2) (when (and (type>= #tfixnum t2) (type>= #tfixnum t1));FIXME (let ((t1 (bit-type t1))(t2 (bit-type t2))) (super-range '* (if (and (atomic-tp t1) (atomic-tp t2)) #t(integer 1 1) #t(integer 0 1)) (type-or1 (super-range f (type-and #tnon-negative-integer t1) (type-and #tnon-negative-integer t2)) (type-or1 (super-range f (type-and #tnegative-integer t1) (type-and #tnon-negative-integer t2)) (type-or1 (super-range f (type-and #tnon-negative-integer t1) (type-and #tnegative-integer t2)) (super-range f (type-and #tnegative-integer t1) (type-and #tnegative-integer t2))))))))) (dolist (l '(& ^ \|)) (si::putprop l 'logand2-propagator 'type-propagator)) (defun logand1-propagator (f t1) (when (type>= #tfixnum t1);FIXME (super-range '* #t(integer 0 1) (super-range f t1)))) (si::putprop '~ 'logand1-propagator 'type-propagator) (defun logand-propagator (f &optional (t1 nil t1p) (t2 nil t2p) &rest r) (cond (r (apply 'logand-propagator f (logand-propagator f t1 t2) (car r) (cdr r))) (t2p (logand2-propagator f t1 t2)) (t1p (logand1-propagator f t1)) ((not t1p) (super-range f)))) (dolist (l '(logand logior logxor logeqv logandc1 logandc2 logorc1 logorc2 lognand lognor lognot)) (si::putprop l 'logand-propagator 'type-propagator)) (defun min-max-propagator (f &optional (t1 nil t1p) (t2 nil t2p)) (cond (t2p (super-range f (type-and #treal t1) (type-and #treal t2))) (t1p (super-range f (type-and #treal t1))))) (si::putprop 'max 'min-max-propagator 'type-propagator) (si::putprop 'min 'min-max-propagator 'type-propagator) (defun /-pole (x y &aux (d (pole-d y))(x (bound-num x))(y (bound-num y))) (if (zerop y) (get-inf (* x (if (floatp y) (float d y) d))) (let ((x (/ x y))) (if (integerp x) (cons x 'incl) x)))) (setf (get '/-pole 'pole) t) (defun /-propagator (f t1 &optional t2) (cond (t2 (reduce 'type-or1 (mapcar (lambda (x) (super-range '/-pole t1 (type-and t2 x))) '(#tcomplex #tpositive-real #tnegative-real)) :initial-value nil)) (t1 (/-propagator f (object-tp 1) t1)))) (si::putprop '/ '/-propagator 'type-propagator) (si::putprop 'si::number-divide '/-propagator 'type-propagator) (defun real-imag-tp (x rp) (when (consp x) (case (car x) (member (reduce (lambda (y x) (type-or1 y (object-tp (if rp (realpart x) (imagpart x))))) (cdr x) :initial-value nil)) (or (reduce (lambda (y x) (type-or1 y (real-imag-tp x rp))) (cdr x) :initial-value nil)) (complex (cmp-norm-tp (cadr x))) (si::complex* (cmp-norm-tp (if rp (cadr x) (caddr x))))))) (defun complex-real-imag-type-propagator (f t1 rp) (declare (ignore f)) (when (type>= #tcomplex t1) (reduce (lambda (&rest r) (when r (apply 'type-or1 r))) (mapcar (lambda (x) (real-imag-tp (si::tp-type (cdr x)) rp)) (range-decomp t1))))) (defun complex-real-type-propagator (f t1) (complex-real-imag-type-propagator f t1 t)) (defun complex-imag-type-propagator (f t1) (complex-real-imag-type-propagator f t1 nil)) (si::putprop 'si::complex-real 'complex-real-type-propagator 'type-propagator) (si::putprop 'si::complex-imag 'complex-imag-type-propagator 'type-propagator) (si::putprop 'c-ocomplex-real 'complex-real-type-propagator 'type-propagator) (si::putprop 'c-ocomplex-imag 'complex-imag-type-propagator 'type-propagator) (defun tp-contagion (tp c &aux (s #tshort-float)(l #tlong-float)) (cond ((type>= c s) (if (type>= s tp) tp (cmp-norm-tp `(short-float ,@(real-bnds tp))))) ((type>= c l) (if (type>= l tp) tp (cmp-norm-tp `(long-float ,@(real-bnds tp))))) (tp))) (defun c-type-propagator (f t1) (declare (ignore f)) (cmp-norm-tp (cons 'member (reduce (lambda (y x) (when (type-and t1 (car x)) (pushnew (c-type (eval (cdr x))) y)) y) si::+rn+ :initial-value nil)))) (si::putprop 'c-type 'c-type-propagator 'type-propagator) (defconstant +e+ 2.7182818284590451) (defun log-pole (&rest r &aux (x (pop r))(d (pole-d x))(x (bound-num x))(x (if (integerp x) (float x) x))) (if (zerop x) (let ((x (coerce -inf (pole-type x)))) (if (plusp d) x (complex (realpart x) (float +pi+ (realpart x))))) (apply 'log x (mapcar 'bound-num r)))) (setf (get 'log-pole 'pole) t) (defun log-propagator (f t1 &rest r) (declare (ignore f)) (reduce 'type-or1 (mapcar (lambda (x) (apply 'super-range 'log-pole (type-and t1 x) r)) '(#tcomplex #tpositive-real #tnegative-real)) :initial-value nil)) (si::putprop 'log 'log-propagator 'type-propagator) (defun last-cons-type (tp &optional l) (cond ((and l (atom tp)) tp) ((and (consp tp) (eq (car tp) 'cons) (cddr tp) (not (cdddr tp))) (last-cons-type (caddr tp) t)))) (defun cdr-propagator (f t1 &aux (t1 (type-and #tlist t1))) (declare (ignore f)) (cond ((type>= #tnull t1) t1) ;FIXME clb ccb do-setq-tp ((let ((a1 (atomic-tp t1))) (when a1 (let ((tp (cdar a1))) (unless (binding-p tp) (object-type tp))))));FIXME bind-type? ((and (consp t1) (eq (car t1) 'cons)) (caddr t1)) ((type>= #tproper-list t1) #tproper-list))) (si::putprop 'cdr 'cdr-propagator 'type-propagator) (defun make-list-propagator (f t1 &rest r &aux (a (atomic-tp t1))) (declare (ignore f r)) (cond ((and (type>= #t(integer 0 5) t1) a) ; (object-type (make-list (cadr t1)))) (cmp-norm-tp (reduce (lambda (y x) (declare (ignore x)) `(cons t ,y)) (make-list (car a)) :initial-value 'null))) (#tproper-list))) (si::putprop 'make-list 'make-list-propagator 'type-propagator) (defun nth-cons-tp (n tp) (cond ((= n 0) tp) ((and (consp tp) (eq 'cons (car tp)) (cddr tp) (not (cdddr tp))) (nth-cons-tp (1- n) (caddr tp))))) (defun nthcdr-propagator (f t1 t2) (declare (ignore f)) (let ((t1 (type-and #tinteger t1)) (t2 (type-and #tlist t2))) (cond ((type>= #tnull t2) t2) ;FIXME clb ccb do-setq-tp ((type>= #t(integer 0 0) t1) t2) ((and (consp t2) (eq (car t2) 'cons) (atomic-tp t1) (typep (cadr t1) 'seqind)) (nth-cons-tp (cadr t1) t2)) ((type>= #tproper-list t2) #tproper-list)))) (si::putprop 'nthcdr 'nthcdr-propagator 'type-propagator) (defun bump-pcons (v p) (let ((tp (if p #tproper-cons #tcons))) (unless (type>= (var-type v) tp) (when (type>= #tproper-cons (var-type v)) (do-setq-tp v nil tp) (mapc (lambda (x) (bump-pcons x p)) (var-aliases v)))))) (defun bump-pconsa (v ctp) (let ((tp (cons-propagator 'cons ctp (cdr-propagator 'cdr (var-type v))))) (unless (type>= (var-type v) tp) (do-setq-tp v nil tp) (mapc (lambda (x) (bump-pconsa x ctp)) (var-aliases v))))) (defun bump-cons-tp-if (f tp) (dolist (v *vars*) (when (var-p v) (unless (tp<= tp (var-type v)) (when (funcall f (var-type v)) (keyed-cmpnote (list (var-name v) 'type-propagation 'type 'bump-cons-tp-if) "Bumping var ~s cons type ~s -> ~s, tp ~s" (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp (tp-or (var-type v) tp)) (cmp-unnorm-tp tp)) (do-setq-tp v 'bump-cons-tp-if (tp-or (var-type v) tp)))) (let ((s (var-store v))) (when (listp s);FIXME (dolist (b s) (let* ((fm (binding-form b))(i (when fm (cadr fm)))(itp (when i (info-type i)))) (when (and fm (funcall f itp)) (setf (info-type i) (type-or1 itp tp)))))))))) (defun c1rplacd (args) (let* ((info (make-info :flags (iflags side-effects))) (nargs (c1args args info)) (tp1 (type-and #tcons (info-type (cadar nargs))))(tp2 (info-type (cadadr nargs))) (c1 (car (atomic-tp tp1)))(atp2 (atomic-tp tp2))(a2 (car atp2)) itp) (c1side-effects nil) (cond ((and c1 atp2 (not (eq c1 a2)) (if (typep c1 'proper-cons) (typep a2 'proper-list) (typep a2 '(not proper-list)))) (when *restore-vars-env* (keyed-cmpnote (list 'type-mod-unwind) "Winding type ~s for rplacd" tp1) (pushnew (list tp1 (mcpt tp1)) *restore-vars* :key 'car)) (setf (cdr c1) a2 itp tp1)) ((and (typep c1 'proper-cons) (type<= tp2 #tproper-list)) (bump-cons-tp-if (lambda (x &aux (c (car (atomic-tp x)))) (when (consp c) (tailp c1 c))) #tproper-cons)) ((and (typep c1 'si::improper-cons) (type<= tp2 #t(not proper-list))) (bump-cons-tp-if (lambda (x &aux (c (car (atomic-tp x)))) (when (consp c) (tailp c1 c))) #tsi::improper-cons)) ((and (type<= tp1 #tproper-cons) (type-and tp2 #t(not proper-list))) (bump-cons-tp-if (lambda (x) (type-and x #tproper-cons)) #tcons)) ((and (type<= tp1 #tsi::improper-cons) (type-and tp2 #tproper-list)) (bump-cons-tp-if (lambda (x) (type-and x #tsi::improper-cons)) #tcons))) (setf (info-type info) (or itp (if (type<= tp2 #tproper-list) #tproper-cons #tcons))) (list 'call-global info 'rplacd nargs))) (si::putprop 'rplacd 'c1rplacd 'c1) (defun c1rplaca (args) (let* ((info (make-info :flags (iflags side-effects))) (nargs (c1args args info)) (tp1 (info-type (cadar nargs))) (atp (car (atomic-tp tp1))) ; (atp1 (car (atomic-tp (narg-list-type (cdr nargs)))))) (atp1 (car (atomic-tp (info-type (cadadr nargs)))))) (c1side-effects nil) (when (consp atp) (when (eq atp atp1) (setq atp1 (copy-list atp1))) (when *restore-vars-env* (keyed-cmpnote (list 'type-mod-unwind) "Winding type ~s for rplaca" tp1) (let ((tp (info-type (cadar nargs)))) (pushnew (list tp (mcpt tp)) *restore-vars* :key 'car))) (setf (car atp) (or atp1 (new-bind)))) (when (eq (caar nargs) 'var) (bump-pconsa (caaddr (car nargs)) (info-type (cadadr nargs)))) (setf (info-type info) (cons-propagator 'cons (info-type (cadadr nargs)) (cdr-propagator 'cdr (info-type (cadar nargs))))) (list 'call-global info 'rplaca nargs))) (si::putprop 'rplaca 'c1rplaca 'c1) (defun cons-propagator (f t1 t2 &aux tmp) (declare (ignore f)) (cond ((let ((a1 (atomic-tp t1)) (a2 (atomic-tp t2))) (and a1 a2 (object-type (cons (car a1) (car a2)))))) ((cons-tp-limit (setq tmp `(cons ,t1 ,t2)) 0 0) (cmp-norm-tp tmp)) ((type>= #tproper-list t2) #tproper-cons) (#tcons))) (si::putprop 'cons 'cons-propagator 'type-propagator) (defun carcdr-c1form-narg (fm) (case (car fm) (inline (carcdr-c1form-narg (fourth fm))) (let* (carcdr-c1form-narg (fifth fm))) (lit (fourth (car (eighth fm)))))) (defun get-binding-form (b &aux (v (get-var b))) (if v (c1var v);FIXME? go through c1var when possible to pick up var-type (let ((f (when (and (binding-p b) (binding-repeatable b)) (binding-form b)))) (when (check-vs (find-vs f)) f)))) (defun co1carcdr (f x);FIXME c1 prop? (let* ((c1form (mi1 f x));NOTE this cannot be exponential/double eval, esp. for ACL2! (narg (carcdr-c1form-narg c1form)) (atp (when (and narg (ignorable-form narg)) (atomic-tp (info-type (cadr narg))))) (tp (car atp)) (b (when (consp tp) (funcall f tp))));FIXME nil (typecase b (null c1form) (binding (or (get-binding-form b) c1form)) (otherwise (atomic-type-constant-value atp))))) (setf (get 'car 'co1) 'co1carcdr) (setf (get 'cdr 'co1) 'co1carcdr) (defun car-propagator (f t1 &aux (t1 (type-and #tlist t1))) (declare (ignore f)) (cond ((type>= #tnull t1) t1) ;FIXME clb ccb do-setq-tp ((let ((a1 (atomic-tp t1))) (when a1 (let ((tp (caar a1))) (unless (binding-p tp) (object-type tp)))))) ((and (consp t1) (eq (car t1) 'cons)) (cadr t1)))) (si::putprop 'car 'car-propagator 'type-propagator) (defun contagion (t1 t2) (car (member (type-or1 t1 t2) `(,#tlong-float ,#tshort-float #tratio #tinteger) :test 'type-and))) (defun mod-propagator (f t1 t2 &aux (t1 (type-and #treal t1))(t2 (type-and #treal t2)) (r1 (range-decomp t1))(r2 (range-decomp t2))) (declare (ignore f)) (cond ((cdr r1) (reduce 'type-or1 (mapcar (lambda (x) (mod-propagator f (cdr x) t2)) r1) :initial-value nil)) ((cdr r2) (reduce 'type-or1 (mapcar (lambda (x) (mod-propagator f t1 (cdr x))) r2) :initial-value nil)) ((let ((a (atomic-tp t1))(b (atomic-tp t2))) (when (and a b) (unless (zerop (car b)) (object-tp (mod (car a) (car b))))))) ((and (type>= #treal t1) (type>= #treal t2)) (let* ((tp (super-range '* #t(integer 0 1) t2));FIXME this might break for integers in the future (r (real-bnds tp)) (r (labels ((b (x) (if (when (numberp x) (not (zerop x))) (list x) x))) (list (b (car r)) (b (cadr r)))))) (type-and (contagion t1 t2) (cmp-norm-tp (cons 'real r))))))) (si::putprop 'mod 'mod-propagator 'type-propagator) (defun random-propagator (f t1 &optional t2) (declare (ignore t2)) (mod-propagator f (super-range '* #t(integer 0 1) t1) t1)) (si::putprop 'random 'random-propagator 'type-propagator) (defun lgcd2-propagator (f t1 t2 t3 &aux (a1 (car (atomic-tp t1)))(a2 (car (atomic-tp t2))) (a3 (car (atomic-tp t3)))) (cond ((and a1 a2 a3) (object-type (funcall f a1 a2 a3))) ((type-and #t(not (integer 0 0)) (super-range '* #t(integer 0 1) (super-range 'min t1 t2)))))) (si::putprop 'si::lgcd2 'lgcd2-propagator 'type-propagator) (defun rem-propagator (f t1 t2 &aux (ta (abs-propagator 'abs t2))) (let ((tm (mod-propagator f t1 t2))) (when tm (cond ((type>= #tnon-negative-real t1) (type-or1 (type-and #tnon-negative-real tm) (super-range '+ (type-and #tnon-positive-real tm) ta))) ((type>= #tnon-positive-real t1) (type-or1 (type-and #tnon-positive-real tm) (super-range '- (type-and #tnon-negative-real tm) ta))) ((type-or1 tm (super-range '- tm))))))) (si::putprop 'rem 'rem-propagator 'type-propagator) (defun floor-propagator (f t1 &optional (t2 #t(member 1)) &aux (t1 (type-and #treal t1))(t2 (type-and #treal t2)) (i (member f '(floor truncate round ceiling)))) (let* ((sr (super-range (lambda (x) (cond ((isinf x) (if i (if (> x 0) '+iinf '-iinf) x)) ((isnan x) (if i 'inan x)) ((funcall f x)))) (/-propagator '/ t1 t2))) (sr (if i (type-and #tinteger sr) sr))) (when sr `(returns-exactly ,sr ,(cond ((member f '(floor ffloor)) (mod-propagator f t1 t2)) ((member f '(ceiling fceiling)) (super-range '- (mod-propagator f t1 t2))) ((member f '(truncate ftruncate round fround)) (rem-propagator f t1 t2))))))) (dolist (l '(floor ceiling truncate round ffloor fceiling ftruncate fround)) (si::putprop l 'floor-propagator 'type-propagator) (si::putprop l t 'c1no-side-effects)) (defun ash-propagator (f t1 t2) (and (type>= #tfixnum t1) (type>= #t(integer #.most-negative-fixnum #.(integer-length most-positive-fixnum)) t2) (super-range f t1 t2))) (si::putprop 'ash 'ash-propagator 'type-propagator) (si::putprop 'si::mpz_mul_2exp 'ash-propagator 'type-propagator) (si::putprop 'si::mpz_fdiv_q_2exp 'ash-propagator 'type-propagator) (defun <<-propagator (f t1 t2) (when (type>= #tfixnum t1) (super-range (lambda (x y) (if (when (typep y 'fixnum) (> (- #.(1+ (integer-length most-positive-fixnum)) (integer-length x)) y)) (funcall f x y) (return-from <<-propagator nil))) t1 t2))) (si::putprop 'si::<< '<<-propagator 'type-propagator) (defun >>-propagator (f t1 t2) (when (and (type>= #tfixnum t1) (type>= #t(integer 0 #.(integer-length most-positive-fixnum)) t2)) (super-range f t1 t2))) (si::putprop 'si::>> '>>-propagator 'type-propagator) (defun pexpt (x y) ;; x>=0, y>=0 (typecase y ((real 0 0) (1+ y)) ((integer 1000) (get-inf x)) (otherwise (expt x y)))) (defun expt-propagator (f t1 t2) (declare (ignore f)) (when (type>= #tnon-negative-real t1) (when (type>= #treal t2) (type-or1 (super-range 'pexpt t1 (type-and #tnon-negative-real t2)) (/-propagator '/ (super-range 'pexpt t1 (super-range '- (type-and #tnegative-real t2)))))))) (si::putprop 'expt 'expt-propagator 'type-propagator) ;; (defun exp-propagator (f t1) ;; (declare (ignore f)) ;; (expt-propagator 'expt (if (type>= #tshort-float t1) (object-type (float +e+ 0.0s0)) (object-type +e+)) t1)) ;; (si::putprop 'exp 'exp-propagator 'type-propagator) (defun integer-length-propagator (f t1) (when (type>= #tfixnum t1) (type-or1 (super-range f (type-and #tnon-negative-real t1)) (super-range f (type-and #tnon-positive-real t1))))) (si::putprop 'integer-length 'integer-length-propagator 'type-propagator) ;(defconstant +clzl0+ (let ((x (1+ (si::clzl 1)))) (cmp-norm-tp `(integer ,x ,x)))) ;(defconstant +clzl0+ (let ((x (1- si::fixnum-length))) (cmp-norm-tp `(integer ,x ,x)))) (defun bnd-clzl (x y) (let* ((lx (si::clzl x))(ly (si::clzl y))(m (if (if (minusp x) (plusp y) (minusp y)) (si::clzl 0) lx))) (cmp-norm-tp `(integer ,(min lx ly m) ,(max lx ly m))))) (defun clzl-propagator (f t1 &aux (t1 (type-and #tfixnum t1)));FIXME wrap (declare (ignorable f)) (unless (type<= #tfixnum t1) (if (atom t1) (apply 'bnd-clzl (real-bnds t1)) (reduce 'type-or1 (mapcar (lambda (x) (bnd-clzl (car x) (cdr x))) (cdr (assoc 'integer (caaddr t1)))) :initial-value nil)))) (si::putprop 'si::clzl 'clzl-propagator 'type-propagator) (si::putprop 'si::clzl t 'cmp-inline);FIXME no declaim (defun bnd-ctzl (x y &optional (i 0) res) (if (eql x y) (cmp-norm-tp (cons 'member (cons (+ (if (zerop x) 0 i) (si::ctzl x)) res))) (bnd-ctzl (>> (if (oddp x) (1+ x) x) 1) (>> (if (oddp y) (1- y) y) 1) (1+ i) (cons i res)))) (defun ctzl-propagator (f t1 &aux (t1 (type-and #tfixnum t1))) (declare (ignorable f)) (unless (type<= #tfixnum t1) (if (atom t1) (apply 'bnd-ctzl (real-bnds t1)) (reduce 'type-or1 (mapcar (lambda (x) (bnd-ctzl (car x) (cdr x))) (cdr (assoc 'integer (caaddr t1)))) :initial-value nil)))) (si::putprop 'si::ctzl 'ctzl-propagator 'compiler::type-propagator) (si::putprop 'si::ctzl t 'compiler::cmp-inline);FIXME no declaim (defun abs-propagator (f t1) (when t1 (type-and #tnon-negative-real (type-or1 (let ((t1 (type-and t1 #tcomplex))) (when t1 (super-range '+ (abs-propagator f (complex-real-type-propagator 'complex-real t1)) (abs-propagator f (complex-imag-type-propagator 'complex-imag t1))))) (let ((t1 (type-and #treal t1))) (type-or1 t1 (super-range '- t1))))))) (si::putprop 'abs 'abs-propagator 'type-propagator) (defun cosh-propagator (f t1) (type-or1 (super-range f (type-and t1 #t(not real))) (type-or1 (super-range f (type-and t1 #tnon-negative-real)) (super-range f (type-and t1 #tnegative-real))))) (si::putprop 'cosh 'cosh-propagator 'type-propagator) (defun shrnfm (t1 m o &aux (sf (type>= #tshort-float t1)) (m (if sf (float m 0.0s0) m)) (o (if sf (float o 0.0s0) o)));FIXME (let* ((r (real-bnds t1)) (s (if (numberp (car r)) (ftruncate (+ o (car r)) m) 0)) (k (cmp-norm-tp `(real ,(- o) (,(- m o))))) (st (super-range '- t1 (object-tp (* s m))))) (type-and k (type-or1 st (super-range '- st (object-tp m))))));FIXME max period (defconstant +pi+ (atan 0 -1)) (defconstant +pid2+ (* 0.5 (atan 0 -1))) (defun float-proxy-propagator (f t1) (declare (ignore f)) (reduce 'type-or1 (mapcar (lambda (x) (super-range (lambda (x) (cond ((isinf x) (if (> x 0) +inf -inf)) ((isnan x) nan) ((float x)))) (type-and t1 x))) '(#tnegative-real #tnon-negative-real)) :initial-value nil)) (si::putprop 'si::big-to-double 'float-proxy-propagator 'type-propagator) (si::putprop 'si::ratio-to-double 'float-proxy-propagator 'type-propagator) (defun sqrt-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (type-or1 (super-range f (type-and t1 #tnon-negative-real)) (super-range 'sqrt (type-and t1 #tnegative-real))))) (si::putprop 'sqrt 'sqrt-propagator 'type-propagator) (defun cos-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (let ((z (shrnfm (type-and t1 #treal) (* 2 +pi+) +pi+))) (type-or1 (super-range f (type-and z #tnon-negative-real)) (super-range f (type-and z #tnegative-real)))))) (si::putprop 'cos 'cos-propagator 'type-propagator) (defun sin-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (let ((z (shrnfm (type-and t1 #treal) (* 2 +pi+) +pid2+))) (type-or1 (super-range f (type-and z (cmp-norm-tp `(real * (,+pid2+))))) (super-range f (type-and z (cmp-norm-tp `(real ,+pid2+))))))));FIXME (si::putprop 'sin 'sin-propagator 'type-propagator) (defun tan-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (let ((z (shrnfm (type-and t1 #treal) +pi+ +pid2+))) (type-or1 (super-range f (type-and z #tnon-negative-real)) (super-range f (type-and z #tnegative-real)))))) (si::putprop 'tan 'tan-propagator 'type-propagator) (defun asin-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (type-or1 (super-range (lambda (x) (funcall f (/ x 6))) (super-range '* #t(integer 6 6) (type-and t1 #t(real -1 1)))) (super-range f (type-and t1 #t(not (real -1 1))))))) (si::putprop 'asin 'asin-propagator 'type-propagator) (si::putprop 'acos 'asin-propagator 'type-propagator) (defun atanh-pole (x &aux (d (pole-d x))(x (bound-num x))(x (if (integerp x) (float x) x))) (cond ((= x 1) (let ((x (coerce +inf (pole-type x)))) (if (minusp d) x (complex (realpart x) (float +pid2+ (realpart x)))))) ((= x -1) (let ((x (coerce -inf (pole-type x)))) (if (plusp d) x (complex (realpart x) (float +pid2+ (realpart x)))))) ((atanh x)))) (setf (get 'atanh-pole 'pole) t) (defun atanh-propagator (f t1) (declare (ignore f)) (reduce 'type-or1 (mapcar (lambda (x) (super-range 'atanh-pole (type-and t1 x))) `(,#tcomplex ,#t(real * (-1)) ,#t(real (-1) (1)) ,#t(real (1)))) :initial-value nil)) (si::putprop 'atanh 'atanh-propagator 'type-propagator) (defun acosh-propagator (f t1) (type-or1 (super-range f (type-and t1 #tcomplex)) (type-or1 (super-range f (type-and t1 #t(real 1))) (super-range f (type-and t1 #t(real * (1))))))) (si::putprop 'acosh 'acosh-propagator 'type-propagator) (defun make-vector-propagator (f et st &rest r) (declare (ignore f)) (cmp-norm-tp `(,(if (and (type>= #tnull (pop r)) (type>= #tnull (pop r)) (type>= #tnull (car r))) 'simple-array 'array) ,(or (car (atomic-tp et)) '*) (,(or (car (atomic-tp st)) '*))))) (si::putprop 'si::make-vector 'make-vector-propagator 'type-propagator) (defun make-array1-propagator (f &rest r) (declare (ignore f)) (cmp-norm-tp `(array ,(or (car (atomic-tp (car r))) '*) ,(or (let* ((x (car (atomic-tp (sixth r))));FIXME centralize (x (if (integerp x) (make-list x :initial-element '*) x))) (mapcar (lambda (x) (if (integerp x) x '*)) x)) '*)))) (si::putprop 'si::make-array1 'make-array1-propagator 'type-propagator) (defun promoted-c-type (type &aux r) (let ((type (coerce-to-one-value type))) (cond ((eq type 'object) type);FIXME ((setq r (member type +promoted-c-types+ :test 'type<=)) (car r)) (#tt)))) (defun single-type-p (type) (if (listp type) (case (car type) (returns-exactly (when (cdr type) (unless (cddr type) (cadr type)))) (values nil) (otherwise type)) (unless (eq type '*) type))) (defun coerce-to-one-value (type) (type-and type t)) (defun individuals (f x) (mapcan (lambda (y &aux (y (if (listp y) (car y) y))) (when (funcall f y) (list (cons (car x) y)))) (cdr x))) (defun ntp-kingdoms-with-individuals (ntp) (mapcan (lambda (x) (case (car x) ((complex-integer complex-integer-ratio complex-ratio-integer complex-short-float complex-long-float) (individuals 'complexp x)) ((integer ratio)) ((short-float long-float);FIXME conceptually this should not be here. (mapcan (lambda (y) (when (consp y) (labels ((d (z &aux (z (if (listp z) (car z) z))) (when (or (isinf z) (isnan z)) (list (cons (car x) z))))) (append (d (car y)) (d (cdr y)))))) (cdr x))) ((std-instance structure funcallable-std-instance) (individuals (lambda (y) (not (eq 'top (si::std-def y)))) x)) ((proper-cons si::improper-cons);FIXME (mapcan (lambda (y) (when (listp y) (append (ntp-kingdoms-with-individuals (car y)) (ntp-kingdoms-with-individuals (cadr y)) (when (caddr y) (list (cons (car x) (caddr y)))) (when (cadddr y) (list (cons (car x) (car (cadddr y)))))))) (cdr x))) (#.(mapcar 'cdr si::*all-array-types*) (individuals 'arrayp x)) (otherwise (individuals (lambda (y) (not (eq y t))) x)))) (car ntp))) (defun kingdoms-with-individuals (tp) (when (consp tp) (let ((ntp (caddr tp))) (if (caddr ntp) (mapcar 'car (car (si::ntp-and (caar ntp) (si::ntp-not (cadar ntp))))) (ntp-kingdoms-with-individuals ntp))))) (declaim (inline bump-individuals)) (defun bump-individuals (f tp) (cond ((cmpt tp) (cons (car tp) (mapcar (lambda (x) (bump-individuals f x)) (cdr tp)))) ((let* ((x (kingdoms-with-individuals tp)) (x (remove-if-not (lambda (x) (if (consp x) (funcall f (cdr x)) t)) x)) (x (remove-duplicates (mapcar (lambda (x) (if (consp x) (car x) x)) x)))) (if x (type-or1 (cmp-norm-tp (cons 'or x)) tp) tp))))) (declaim (inline unprintable-individual-p)) (defun unprintable-individual-p (x) (typecase x (float (or (isnan x) (isinf x)));t ((or string bit-vector number random-state character symbol pathname) nil) (cons (or (unprintable-individual-p (car x)) (unprintable-individual-p (cdr x)))) ((array t) (some 'unprintable-individual-p x)) ;FIXME assumes structure elements are printable (structure (si::s-data-print-function (c-structure-def x))) (t t))) (defun export-type (type) (bump-individuals 'unprintable-individual-p type)) (defun bump-tp (tp) (cond ((eq tp '*) tp) ((and (consp tp) (member (car tp) '(values returns-exactly))) `(,(car tp) ,@(mapcar 'bump-tp (cdr tp)))) ((type>= tp #tnull) (type-or1 #tnull (bump-tp (type-and #t(not null) tp)))) ((tsrch tp)) (t))) (defun c-structure-def-propagator (f t1) (declare (ignore f)) (when (symbolp t1) (let ((tem (get t1 's-data))) (when tem (object-type tem))))) (setf (get 'c-structure-def 'type-propagator) 'c-structure-def-propagator) (defun structure-name-propagator (f t1) (declare (ignore f)) (when (symbolp t1) (when (get t1 's-data) (object-type t1)))) (setf (get 'si::structure-name 'type-propagator) 'structure-name-propagator) (defun expand-type-propagator (f t1 &aux (a (atomic-tp t1))(b (car a)));FIXME organization (when a (when (constant-type-p b) (object-type (funcall f b))))) (dolist (l 'si::(expand-array-element-type cmp-norm-tp sequence-tp-nonsimple-p sequence-tp-lengths make-sequence-element-type expand-deftype sdata-includes lookup-simple-typep-fn lookup-typep-fn)) (setf (get l 'compiler::c1no-side-effects) t) (setf (get l 'compiler::type-propagator) 'compiler::expand-type-propagator)) (defun improper-consp-type-propagator (f t1 &optional t2) (declare (ignore f t2)) (cond ((not (type-and #tsi::improper-cons t1)) #tnull) ((type>= #tsi::improper-cons t1) #ttrue))) (dolist (l 'si::(improper-consp)) (setf (get l 'compiler::c1no-side-effects) t) (setf (get l 'compiler::type-propagator) 'compiler::improper-consp-type-propagator)) (defun symbol-gfdef-propagator (f t1 &aux (a (atomic-tp t1))) (declare (ignore f)) (if a (object-type (funid-to-fn (car a))) #tfunction));FIXME 0 (setf (get 'c-symbol-gfdef 'type-propagator) 'symbol-gfdef-propagator) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmplabel.lsp0000644000000000000000000000013114774225213015767 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.456939094 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmplabel.lsp0000644000175000017500000002301714774225213015371 0ustar00cammcamm;;; CMPLABEL Exit manager. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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-frames-bds (frames bds-cvar bds-bind) (dotimes (i frames) (wt-nl "frs_pop();")) (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 (frames 0)) (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 (rassoc *value-to-go* +return-alist+)) (not (eq *value-to-go* 'top)) (not (multiple-values-p)));FIXME cleanup (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*) (unless (and (consp *value-to-go*) (or (eq (car *value-to-go*) 'jump-true) (eq (car *value-to-go*) 'jump-false))) (set-loc loc)) (unwind-frames-bds frames bds-cvar bds-bind) (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 (rassoc *value-to-go* +return-alist+)) (not (eq *value-to-go* 'top))) (wt-nl "sup=V" (cdr ue) ";") (wt-nl) (reset-top))) ((setq jump-p t)))) ((numberp ue) (setq bds-cvar ue bds-bind 0)) ((eq ue 'bds-bind) (incf bds-bind)) ((eq ue 'return) (unless (eq *exit* ue) (wfs-error)) (set-loc loc) (unwind-frames-bds frames bds-cvar bds-bind) (wt-nl "return;") (return)) ((eq ue 'frame) (incf frames)) ((eq ue 'tail-recursion-mark)) ((eq ue 'jump) (setq jump-p t)) ((setq type.wt (assoc (car (rassoc ue +return-alist+)) +wt-loc-alist+)) (unless (eq *exit* ue) (wfs-error)) (cond (*mv-var* (let* ((nv (cond ((and (consp fname) (eq (car fname) 'values)) (1- (cdr fname))) ((or (not fname) (eq fname 'single-value)) 0) ((abs (vald (get-return-type fname)))))) (nv (if (= nv (- multiple-values-limit 2)) 0 nv)) (fv (cs-push (car type.wt) t)) (lbs (mapcar (lambda (x) (declare (ignore x)) (cs-push t t)) (make-list (max 0 nv)))) (*value-to-go* (append (mapcar (lambda (x) (list 'cvar x)) (cons fv lbs)) '(trash)))) (wt-nl "{" (rep-type (car type.wt)) "V" fv ";") (cond (lbs (wt-nl "if (V" (var-loc *mv-var*) ") {") (let ((i -1)) (mapc (lambda (x) (wt-nl "#define V" x " ((object *)V" (var-loc *mv-var*) ")[" (incf i) "]")) lbs)) (set-loc loc) (mapc (lambda (x) (wt-nl "#undef V" x)) lbs) (wt-nl "} else {") (let ((*value-to-go* (list 'cvar fv))) (set-loc loc)) (wt-nl "}")) ((set-loc loc))) (when (or (eq loc 'fun-val) ;FIXME believe this is fixed now -- check;FIXME this can lead to a value stack leak on vs_top, e.g. typep with local mvfun tpi (and (consp loc) (rassoc (car loc) +inline-types-alist+) (flag-p (cadr loc) sets-vs-top))) (setq nv -2)) (unwind-frames-bds frames bds-cvar bds-bind) (wt-nl "VMRV" *reservation-cmacro* "(V" fv "," nv ");}"))) ((let ((cvar (cs-push (car type.wt) t))) (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ") (funcall (cdr type.wt) loc) (wt ";") (unwind-frames-bds frames bds-cvar bds-bind) (wt-nl "VMR" *reservation-cmacro* "(V" cvar ");}")))) (return)) ((baboon))))) (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)) ((or (eq ue 'return) (rassoc ue +return-alist+)) (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))) ;;; 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.7.1/cmpnew/PaxHeaders/gcl_fasdmacros.lsp0000644000000000000000000000013114774225213016332 xustar0030 mtime=1743858315.801955256 30 atime=1744294961.297792721 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_fasdmacros.lsp0000755000175000017500000000370214774225213015736 0ustar00cammcamm (in-package :compiler) (defstruct (fasd (:type vector)) stream table eof direction package index filepos table_length evald_forms ; list of forms eval'd. (load-time-eval) ) (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 gcl. 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 put2 (n str) `(progn (write-bytei ,n 0 ,str) (write-bytei ,n 1 ,str))) (defmacro write-bytei (n i str) `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str)) (provide 'FASDMACROS) gcl-2.7.1/cmpnew/PaxHeaders/gcl_cmpenv.lsp0000644000000000000000000000013114774225213015500 xustar0030 mtime=1743858315.801955256 30 atime=1744340056.444939017 29 ctime=1744351535.63890782 gcl-2.7.1/cmpnew/gcl_cmpenv.lsp0000644000175000017500000004172514774225213015110 0ustar00cammcamm;;; CMPENV Environments of the Compiler. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; Copyright (C) 2024 Camm Maguire ;; 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) ;;; 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. (defvar *dlinks* (make-hash-table :test 'equal)) (defun init-env () (setq *tmpsyms* +tmpsyms+) (setq *gensym-counter* 0) (setq *next-cvar* 0) (setq *next-cmacro* 0) (setq *next-vv* -1) (setq *next-cfun* 0) (setq *last-label* 0) (setq *src-hash* (make-hash-table :test 'eq)) (setq *fn-src-fn* (make-hash-table :test 'eq)) (setq *objects* (make-hash-table :test 'eq)) (setq *dlinks* (make-hash-table :test 'equal)) (setq *local-funs* nil) (setq *hash-eq* nil) (setq *global-funs* nil) (setq *global-entries* nil) (setq *undefined-vars* nil) (setq *reservations* nil) (setq *top-level-forms* nil) (setq *function-declarations* nil) (setq *inline-functions* nil) (setq *function-links* nil) (setq *inline-blocks* 0) (setq *notinline* nil) ) (defvar *next-cvar* 0) (defvar *next-cmacro* 0) (defvar *next-vv* -1) (defvar *next-cfun* 0) (defvar *tmp-pack* nil) ;;; *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-libc (x) (add-dladdress (strcat "dl" x) (mdlsym x))) (defun add-dladdress (n l) (unless (gethash n *dlinks*) (wt-h "static void *" n #+static"=" #+static(symbol-name l) ";") (setf (gethash n *dlinks*) t) (add-init `(si::mdl ',(symbol-name l) ',(package-name (symbol-package l)) ,(add-address (concatenate 'string "&" n)))))) ;(defun add-symbol (symbol) symbol) (defun add-object2 (object) (let* ((init (if (when (consp object) (eq (car object) '|#,|)) (cdr object) `',object))) ; (unless init (break)) (cond ((gethash object *objects*)) ((push-data-incf nil) (when init (add-init `(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 nani-eq (x y) (and (consp x) (consp y) (eq (car x) 'si::nani) (eq (car y) 'si::nani) (eq (cadr x) (cadr y)))) ;(defun add-object (object) object) (defun add-constant (symbol) (cons '|#,| 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. ;; (defmacro t-to-nil (x) (let ((s (tmpsym))) `(let ((,s ,x)) (if (eq ,s t) nil ,s)))) ;; (defmacro nil-to-t (x) `(or ,x t)) (defun is-global-arg-type (x) (let ((x (promoted-c-type x))) (or (equal x #tt) (member x +c-global-arg-types+)))) (defun is-local-arg-type (x) (let ((x (promoted-c-type x))) (or (equal x #tt) (member x +c-local-arg-types+)))) (defun is-local-var-type (x) (let ((x (promoted-c-type x))) (or (equal x #tt) (member x +c-local-var-types+)))) ;; (defun coerce-to-one-value (type) ;; (or (not type) (type-and type t))) (defun readable-tp (x) (cmp-unnorm-tp (cmp-norm-tp x))) (defun function-arg-types (arg-types) (mapcar 'readable-tp arg-types)) ;; (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) ;; (reverse types)) ;; (declare (fixnum i)) ;; (cond ((or (member (car al) '(&optional &rest &key)) ;; (equal (car al) '* )) ;; (setq vararg t) ;; (return (reverse (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 (is-local-arg-type tem) (nil-to-t (car al)) t)));FIXME ;; (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) (cond ((endp return-types) nil) ((cmpt return-types) (cmp-norm-tp `(,(car return-types) ,@(function-return-type (cdr return-types))))) ((cmpt (car return-types)) (cmp-norm-tp `(,(caar return-types) ,@(function-return-type (cdar return-types))))) ((mapcar 'readable-tp return-types)))) (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)))) (defvar *assert-ftype-proclamations* nil) (defun get-arg-types (fname &aux x) (cond ((when *assert-ftype-proclamations* (setq x (when (symbolp fname) (get fname 'proclaimed-signature)))) (car x)) ((setq x (assoc fname *function-declarations*)) (mapcar 'cmp-norm-tp (cadr x))) ((setq x (local-fun-p fname)) (caar (fun-call x))) ((setq x (gethash fname *sigs*)) (caar x)) ((setq x (si::sig fname)) (car x)) ((setq x (when (symbolp fname) (get fname 'proclaimed-signature))) (car x)) ('(*)))) (defun get-return-type (fname &aux x) (cond ((when *assert-ftype-proclamations* (setq x (when (symbolp fname) (get fname 'proclaimed-signature)))) (cadr x)) ((setq x (assoc fname *function-declarations*)) (cmp-norm-tp (caddr x))) ((setq x (local-fun-p fname)) (cadar (fun-call x))) ((setq x (gethash fname *sigs*)) (cadar x)) ((setq x (si::sig fname)) (cadr x)) ((setq x (when (symbolp fname) (get fname 'proclaimed-signature))) (cadr x)) ('*))) (defun get-sig (fname) (list (get-arg-types fname) (get-return-type fname))) (defun cclosure-p (fname) (not (let ((x (or (fifth (gethash fname *sigs*)) (si::props fname)))) (when x (logbitp 0 x))))) (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 *vs-base-ori-used* nil) (defvar *sup-used* nil) (defvar *base-used* nil) (defvar *frame-used* nil) (defvar *bds-used* nil) (defun reset-top () (wt-nl "vs_top=sup;") (setq *sup-used* t)) (defmacro base-used () '(setq *base-used* t)) ;;; Proclamation and declaration handling. (defvar *alien-declarations* nil) (defvar *inline* nil) (defvar *notinline* nil) (defun inline-asserted (fname) (unless *compiler-push-events* (or (member fname *inline*) (local-fun-fn fname) (get fname 'cmp-inline) (member (symbol-package fname) (load-time-value (mapcar #'symbol-package (list 'c-t-tt (mdlsym "sin") (mdlsym "memmove")))))))) ;; (defun inline-asserted (fname) ;; (unless *compiler-push-events* ;; (or ;; (member fname *inline*) ;; (local-fun-fn fname) ;; (get fname 'cmp-inline)))) ;; (defun inline-asserted (fname) ;; (unless *compiler-push-events* ;; (or ;; (member fname *inline*) ;; (local-fun-fun fname) ;; (get fname 'cmp-inline)))) (defun inline-possible (fname) (cond ((eq fname 'funcall));FIXME ((eq fname 'apply));FIXME ((not (or *compiler-push-events* (member fname *notinline*) (get fname 'cmp-notinline)))))) ;; (defun inline-possible (fname) ;; (not (or *compiler-push-events* ;; (member fname *notinline*) ;; (get fname 'cmp-notinline)))) (defun max-vtp (tp) (coerce-to-one-value (cmp-norm-tp tp)));FIXME lose coerce? (defun body-safety (others &aux (*compiler-check-args* *compiler-check-args*) (*compiler-new-safety* *compiler-new-safety*) (*compiler-push-events* *compiler-push-events*) (*safe-compile* *safe-compile*)) (mapc (lambda (x) (when (eq (car x) 'optimize) (local-compile-decls (cdr x)))) others) (this-safety-level)) (defun c1body (body doc-p &aux ss is ts others cps) (multiple-value-bind (doc decls ctps body) (parse-body-header body (unless doc-p "")) (dolist (decl decls) (dolist (decl (cdr decl)) (cmpck (not (consp decl)) "The declaration ~s is illegal." decl) (let ((dtype (car decl))) (if (consp dtype) (let* ((dtype (max-vtp dtype)) (stype (if (consp dtype) (car dtype) dtype))) (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 (typep var '(or symbol (cons (member function) (cons function-name null))))) "The ignore declaration ~s is illegal ~s." decl var) (when (eq stype 'ignorable) (push 'ignorable is)) (push var is))) ((optimize ftype inline notinline) (push decl others)) ((hint type) (cmpck (endp (cdr decl)) "The type declaration ~s is illegal." decl) (let ((type (max-vtp (cadr decl)))) (when type (dolist (var (cddr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (cond ((unless (get var 'tmp) (eq stype 'hint)) (push (cons var type) cps) ;FIXME (push (cons var (global-type-bump type)) ts)) ((push (cons var type) ts))))))) (class ;FIXME pcl (cmpck (cdddr decl) "The type declaration ~s is illegal." decl) (let ((type (max-vtp (or (caddr decl) (car decl))))) (when type (let ((var (cadr 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))) (otherwise (let ((type (unless (member stype *alien-declarations*) (max-vtp stype)))) (if type (unless (eq type t) (dolist (var (cdr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var type) ts))) (push decl others)))))))))) (dolist (l ctps) (when (and (cadr l) (symbolp (cadr l))) (let ((tp (or (eq (car l) 'assert) (max-vtp (caddr l))))) (unless (eq tp t) (push (cons (cadr l) tp) cps))))) (let ((s (> (body-safety others) (if (top-level-src-p) 0 1)))) (when ctps (setq body (nconc (if s ctps (nconc (mapcar (lambda (x) `(infer-tp ,(car x) ,(cdr x))) cps) (mapcan (lambda (x) (when (eq (car x) 'assert) (list (cadr x)))) ctps))) body)))) (values body ss ts is others (when doc-p doc) cps))) (defun c1decl-body (decls body &aux dl) (let ((*function-declarations* *function-declarations*) (*alien-declarations* *alien-declarations*) (*notinline* *notinline*) (*inline* *inline*) (*space* *space*) (*compiler-check-args* *compiler-check-args*) (*compiler-new-safety* *compiler-new-safety*) (*compiler-push-events* *compiler-push-events*) (*safe-compile* *safe-compile*)) (dolist (decl decls dl) (case (car decl) (optimize (dolist (d (cdr decl)) (push d dl)) (local-compile-decls (cdr decl))) (ftype (if (or (endp (cdr decl)) (not (consp (cadr decl))) (not (eq (caadr decl) 'function)) (endp (cdadr decl))) (cmpwarn "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)))) (cmpwarn "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) (pushnew fun *inline*) (setq *notinline* (remove fun *notinline*))) (cmpwarn "The function name ~s is not a symbol." fun)))) (notinline (dolist (fun (cdr decl)) (if (symbolp fun) (progn (push (list 'notinline fun) dl) (pushnew fun *notinline*) (setq *inline* (remove fun *inline*))) (cmpwarn "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*)) (cmpwarn "The declaration specifier ~s is not a symbol." x)))) (otherwise (unless (member (car decl) *alien-declarations*) (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))) (let ((c1b (c1progn body))) (cond ((null dl) c1b) ((member (car c1b) '(var lit)) c1b) ((eq (car c1b) 'decl-body) (setf (third c1b) (nunion dl (third c1b))) c1b) ((list 'decl-body (copy-info (cadr c1b)) dl c1b)))))) (si:putprop 'decl-body 'c2decl-body 'c2) (defun local-compile-decls (decls) (dolist (decl decls) (unless (consp decl) (setq decl (list decl 3))) (case (car decl) (debug (setq *debug* (cadr decl))) (safety (let* ((tl (this-safety-level))(level (if (>= tl 3) tl (cadr decl)))) (declare (fixnum level)) (when (top-level-src-p) (setq *compiler-check-args* (>= level 1) *safe-compile* (>= level 2) *compiler-new-safety* (>= level 3) *compiler-push-events* (>= level 4)))));FIXME (space (setq *space* (cadr decl))) (notinline (push (cadr decl) *notinline*)) (speed) ;;FIXME (compilation-speed) ;;FIXME (inline (setq *notinline* (remove (cadr decl) *notinline*))) (otherwise (baboon))))) (defun c2decl-body (decls body) (let ((*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*compiler-new-safety* *compiler-new-safety*) (*notinline* *notinline*) (*space* *space*) (*debug* *debug*)) (local-compile-decls decls) (c2expr body))) (defun check-vdecl (vnames ts is) (dolist (d ts) (unless (member (car d) vnames);FIXME check error without this (keyed-cmpnote (list 'free-type-declaration (car d)) "free type declaration ~s ~s" (car d) (cdr d)) (c1infer-tp (list (car d) (cdr d))))) (dolist (x is) (unless (or (eq x 'ignorable) (member x vnames :test 'equal)) (cmpwarn "Ignore/ignorable declaration was found for not bound variable ~s." x)))) gcl-2.7.1/PaxHeaders/aclocal.m40000644000000000000000000000013214776130436013217 xustar0030 mtime=1744351518.387063711 30 atime=1744351518.487062801 30 ctime=1744351535.394910007 gcl-2.7.1/aclocal.m40000644000175000017500000014265514776130436012632 0ustar00cammcamm# generated automatically by aclocal 1.17 -*- Autoconf -*- # Copyright (C) 1996-2024 Free Software Foundation, Inc. # This file 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. m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.72],, [m4_warning([this file was generated for autoconf 2.72. You have another version of autoconf. It may work, but is not guaranteed to. If you have problems, you may need to regenerate the build system entirely. To do so, use the procedure documented by the package, typically 'autoreconf'.])]) # Copyright (C) 2002-2024 Free Software Foundation, Inc. # # This file 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. # AM_AUTOMAKE_VERSION(VERSION) # ---------------------------- # Automake X.Y traces this macro to ensure aclocal.m4 has been # generated from the m4 files accompanying Automake X.Y. # (This private macro should not be called outside this file.) AC_DEFUN([AM_AUTOMAKE_VERSION], [am__api_version='1.17' dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to dnl require some minimum version. Point them to the right macro. m4_if([$1], [1.17], [], [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl ]) # _AM_AUTOCONF_VERSION(VERSION) # ----------------------------- # aclocal traces this macro to find the Autoconf version. # This is a private macro too. Using m4_define simplifies # the logic in aclocal, which can simply ignore this definition. m4_define([_AM_AUTOCONF_VERSION], []) # AM_SET_CURRENT_AUTOMAKE_VERSION # ------------------------------- # Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. # This function is AC_REQUIREd by AM_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], [AM_AUTOMAKE_VERSION([1.17])dnl m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl _AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))]) # AM_AUX_DIR_EXPAND -*- Autoconf -*- # Copyright (C) 2001-2024 Free Software Foundation, Inc. # # This file 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. # For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets # $ac_aux_dir to '$srcdir/foo'. In other projects, it is set to # '$srcdir', '$srcdir/..', or '$srcdir/../..'. # # Of course, Automake must honor this variable whenever it calls a # tool from the auxiliary directory. The problem is that $srcdir (and # therefore $ac_aux_dir as well) can be either absolute or relative, # depending on how configure is run. This is pretty annoying, since # it makes $ac_aux_dir quite unusable in subdirectories: in the top # source directory, any form will work fine, but in subdirectories a # relative path needs to be adjusted first. # # $ac_aux_dir/missing # fails when called from a subdirectory if $ac_aux_dir is relative # $top_srcdir/$ac_aux_dir/missing # fails if $ac_aux_dir is absolute, # fails when called from a subdirectory in a VPATH build with # a relative $ac_aux_dir # # The reason of the latter failure is that $top_srcdir and $ac_aux_dir # are both prefixed by $srcdir. In an in-source build this is usually # harmless because $srcdir is '.', but things will broke when you # start a VPATH build or use an absolute $srcdir. # # So we could use something similar to $top_srcdir/$ac_aux_dir/missing, # iff we strip the leading $srcdir from $ac_aux_dir. That would be: # am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"` # and then we would define $MISSING as # MISSING="\${SHELL} $am_aux_dir/missing" # This will work as long as MISSING is not called from configure, because # unfortunately $(top_srcdir) has no meaning in configure. # However there are other variables, like CC, which are often used in # configure, and could therefore not use this "fixed" $ac_aux_dir. # # Another solution, used here, is to always expand $ac_aux_dir to an # absolute PATH. The drawback is that using absolute paths prevent a # configured tree to be moved without reconfiguration. AC_DEFUN([AM_AUX_DIR_EXPAND], [AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl # Expand $ac_aux_dir to an absolute path. am_aux_dir=`cd "$ac_aux_dir" && pwd` ]) # AM_CONDITIONAL -*- Autoconf -*- # Copyright (C) 1997-2024 Free Software Foundation, Inc. # # This file 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. # AM_CONDITIONAL(NAME, SHELL-CONDITION) # ------------------------------------- # Define a conditional. AC_DEFUN([AM_CONDITIONAL], [AC_PREREQ([2.52])dnl m4_if([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])], [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl AC_SUBST([$1_TRUE])dnl AC_SUBST([$1_FALSE])dnl _AM_SUBST_NOTMAKE([$1_TRUE])dnl _AM_SUBST_NOTMAKE([$1_FALSE])dnl m4_define([_AM_COND_VALUE_$1], [$2])dnl if $2; then $1_TRUE= $1_FALSE='#' else $1_TRUE='#' $1_FALSE= fi AC_CONFIG_COMMANDS_PRE( [if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then AC_MSG_ERROR([[conditional "$1" was never defined. Usually this means the macro was only invoked conditionally.]]) fi])]) # Copyright (C) 1999-2024 Free Software Foundation, Inc. # # This file 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. # There are a few dirty hacks below to avoid letting 'AC_PROG_CC' be # written in clear, in which case automake, when reading aclocal.m4, # will think it sees a *use*, and therefore will trigger all it's # C support machinery. Also note that it means that autoscan, seeing # CC etc. in the Makefile, will ask for an AC_PROG_CC use... # _AM_DEPENDENCIES(NAME) # ---------------------- # See how the compiler implements dependency checking. # NAME is "CC", "CXX", "OBJC", "OBJCXX", "UPC", or "GJC". # We try a few techniques and use that to set a single cache variable. # # We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was # modified to invoke _AM_DEPENDENCIES(CC); we would have a circular # dependency, and given that the user is not expected to run this macro, # just rely on AC_PROG_CC. AC_DEFUN([_AM_DEPENDENCIES], [AC_REQUIRE([AM_SET_DEPDIR])dnl AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl AC_REQUIRE([AM_MAKE_INCLUDE])dnl AC_REQUIRE([AM_DEP_TRACK])dnl m4_if([$1], [CC], [depcc="$CC" am_compiler_list=], [$1], [CXX], [depcc="$CXX" am_compiler_list=], [$1], [OBJC], [depcc="$OBJC" am_compiler_list='gcc3 gcc'], [$1], [OBJCXX], [depcc="$OBJCXX" am_compiler_list='gcc3 gcc'], [$1], [UPC], [depcc="$UPC" am_compiler_list=], [$1], [GCJ], [depcc="$GCJ" am_compiler_list='gcc3 gcc'], [depcc="$$1" am_compiler_list=]) AC_CACHE_CHECK([dependency style of $depcc], [am_cv_$1_dependencies_compiler_type], [if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named 'D' -- because '-MD' means "put the output # in D". rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_$1_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp` fi am__universal=false m4_case([$1], [CC], [case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac], [CXX], [case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac]) for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with # Solaris 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle '-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # After this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thus: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_$1_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_$1_dependencies_compiler_type=none fi ]) AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type]) AM_CONDITIONAL([am__fastdep$1], [ test "x$enable_dependency_tracking" != xno \ && test "$am_cv_$1_dependencies_compiler_type" = gcc3]) ]) # AM_SET_DEPDIR # ------------- # Choose a directory name for dependency files. # This macro is AC_REQUIREd in _AM_DEPENDENCIES. AC_DEFUN([AM_SET_DEPDIR], [AC_REQUIRE([AM_SET_LEADING_DOT])dnl AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl ]) # AM_DEP_TRACK # ------------ AC_DEFUN([AM_DEP_TRACK], [AC_ARG_ENABLE([dependency-tracking], [dnl AS_HELP_STRING( [--enable-dependency-tracking], [do not reject slow dependency extractors]) AS_HELP_STRING( [--disable-dependency-tracking], [speeds up one-time build])]) if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' am__nodep='_no' fi AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) AC_SUBST([AMDEPBACKSLASH])dnl _AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl AC_SUBST([am__nodep])dnl _AM_SUBST_NOTMAKE([am__nodep])dnl ]) # Generate code to set up dependency tracking. -*- Autoconf -*- # Copyright (C) 1999-2024 Free Software Foundation, Inc. # # This file 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. # _AM_OUTPUT_DEPENDENCY_COMMANDS # ------------------------------ AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], [{ # Older Autoconf quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. # TODO: see whether this extra hack can be removed once we start # requiring Autoconf 2.70 or later. AS_CASE([$CONFIG_FILES], [*\'*], [eval set x "$CONFIG_FILES"], [*], [set x $CONFIG_FILES]) shift # Used to flag and report bootstrapping failures. am_rc=0 for am_mf do # Strip MF so we end up with the name of the file. am_mf=`AS_ECHO(["$am_mf"]) | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile which includes # dependency-tracking related rules and includes. # Grep'ing the whole file directly is not great: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \ || continue am_dirpart=`AS_DIRNAME(["$am_mf"])` am_filepart=`AS_BASENAME(["$am_mf"])` AM_RUN_LOG([cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles]) || am_rc=$? done if test $am_rc -ne 0; then AC_MSG_FAILURE([Something went wrong bootstrapping makefile fragments for automatic dependency tracking. If GNU make was not used, consider re-running the configure script with MAKE="gmake" (or whatever is necessary). You can also try re-running configure with the '--disable-dependency-tracking' option to at least be able to build the package (albeit without support for automatic dependency tracking).]) fi AS_UNSET([am_dirpart]) AS_UNSET([am_filepart]) AS_UNSET([am_mf]) AS_UNSET([am_rc]) rm -f conftest-deps.mk } ])# _AM_OUTPUT_DEPENDENCY_COMMANDS # AM_OUTPUT_DEPENDENCY_COMMANDS # ----------------------------- # This macro should only be invoked once -- use via AC_REQUIRE. # # This code is only required when automatic dependency tracking is enabled. # This creates each '.Po' and '.Plo' makefile fragment that we'll need in # order to bootstrap the dependency handling code. AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], [AC_CONFIG_COMMANDS([depfiles], [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS], [AMDEP_TRUE="$AMDEP_TRUE" MAKE="${MAKE-make}"])]) # Do all the work for Automake. -*- Autoconf -*- # Copyright (C) 1996-2024 Free Software Foundation, Inc. # # This file 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 macro actually does too much. Some checks are only needed if # your package does certain things. But this isn't really a big deal. dnl Redefine AC_PROG_CC to automatically invoke _AM_PROG_CC_C_O. m4_define([AC_PROG_CC], m4_defn([AC_PROG_CC]) [_AM_PROG_CC_C_O ]) # AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) # AM_INIT_AUTOMAKE([OPTIONS]) # ----------------------------------------------- # The call with PACKAGE and VERSION arguments is the old style # call (pre autoconf-2.50), which is being phased out. PACKAGE # and VERSION should now be passed to AC_INIT and removed from # the call to AM_INIT_AUTOMAKE. # We support both call styles for the transition. After # the next Automake release, Autoconf can make the AC_INIT # arguments mandatory, and then we can depend on a new Autoconf # release and drop the old call support. AC_DEFUN([AM_INIT_AUTOMAKE], [AC_PREREQ([2.65])dnl m4_ifdef([_$0_ALREADY_INIT], [m4_fatal([$0 expanded multiple times ]m4_defn([_$0_ALREADY_INIT]))], [m4_define([_$0_ALREADY_INIT], m4_expansion_stack)])dnl dnl Autoconf wants to disallow AM_ names. We explicitly allow dnl the ones we care about. m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl AC_REQUIRE([AC_PROG_INSTALL])dnl if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl # test to see if srcdir already configured if test -f $srcdir/config.status; then AC_MSG_ERROR([source directory already configured; run "make distclean" there first]) fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi AC_SUBST([CYGPATH_W]) # Define the identity of the package. dnl Distinguish between old-style and new-style calls. m4_ifval([$2], [AC_DIAGNOSE([obsolete], [$0: two- and three-arguments forms are deprecated.]) m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl AC_SUBST([PACKAGE], [$1])dnl AC_SUBST([VERSION], [$2])], [_AM_SET_OPTIONS([$1])dnl dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT. m4_if( m4_ifset([AC_PACKAGE_NAME], [ok]):m4_ifset([AC_PACKAGE_VERSION], [ok]), [ok:ok],, [m4_fatal([AC_INIT should be called with package and version arguments])])dnl AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl _AM_IF_OPTION([no-define],, [AC_DEFINE_UNQUOTED([PACKAGE], ["$PACKAGE"], [Name of package]) AC_DEFINE_UNQUOTED([VERSION], ["$VERSION"], [Version number of package])])dnl # Some tools Automake needs. AC_REQUIRE([AM_SANITY_CHECK])dnl AC_REQUIRE([AC_ARG_PROGRAM])dnl AM_MISSING_PROG([ACLOCAL], [aclocal-${am__api_version}]) AM_MISSING_PROG([AUTOCONF], [autoconf]) AM_MISSING_PROG([AUTOMAKE], [automake-${am__api_version}]) AM_MISSING_PROG([AUTOHEADER], [autoheader]) AM_MISSING_PROG([MAKEINFO], [makeinfo]) AC_REQUIRE([AM_PROG_INSTALL_SH])dnl AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl AC_REQUIRE([AC_PROG_MKDIR_P])dnl # For better backward compatibility. To be removed once Automake 1.9.x # dies out for good. For more background, see: # # AC_SUBST([mkdir_p], ['$(MKDIR_P)']) # We need awk for the "check" target (and possibly the TAP driver). The # system "awk" is bad on some platforms. AC_REQUIRE([AC_PROG_AWK])dnl AC_REQUIRE([AC_PROG_MAKE_SET])dnl AC_REQUIRE([AM_SET_LEADING_DOT])dnl _AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])], [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])], [_AM_PROG_TAR([v7])])]) _AM_IF_OPTION([no-dependencies],, [AC_PROVIDE_IFELSE([AC_PROG_CC], [_AM_DEPENDENCIES([CC])], [m4_define([AC_PROG_CC], m4_defn([AC_PROG_CC])[_AM_DEPENDENCIES([CC])])])dnl AC_PROVIDE_IFELSE([AC_PROG_CXX], [_AM_DEPENDENCIES([CXX])], [m4_define([AC_PROG_CXX], m4_defn([AC_PROG_CXX])[_AM_DEPENDENCIES([CXX])])])dnl AC_PROVIDE_IFELSE([AC_PROG_OBJC], [_AM_DEPENDENCIES([OBJC])], [m4_define([AC_PROG_OBJC], m4_defn([AC_PROG_OBJC])[_AM_DEPENDENCIES([OBJC])])])dnl AC_PROVIDE_IFELSE([AC_PROG_OBJCXX], [_AM_DEPENDENCIES([OBJCXX])], [m4_define([AC_PROG_OBJCXX], m4_defn([AC_PROG_OBJCXX])[_AM_DEPENDENCIES([OBJCXX])])])dnl ]) # Variables for tags utilities; see am/tags.am if test -z "$CTAGS"; then CTAGS=ctags fi AC_SUBST([CTAGS]) if test -z "$ETAGS"; then ETAGS=etags fi AC_SUBST([ETAGS]) if test -z "$CSCOPE"; then CSCOPE=cscope fi AC_SUBST([CSCOPE]) AC_REQUIRE([_AM_SILENT_RULES])dnl dnl The testsuite driver may need to know about EXEEXT, so add the dnl 'am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen. This dnl macro is hooked onto _AC_COMPILER_EXEEXT early, see below. AC_CONFIG_COMMANDS_PRE(dnl [m4_provide_if([_AM_COMPILER_EXEEXT], [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl AC_REQUIRE([_AM_PROG_RM_F]) AC_REQUIRE([_AM_PROG_XARGS_N]) dnl The trailing newline in this macro's definition is deliberate, for dnl backward compatibility and to allow trailing 'dnl'-style comments dnl after the AM_INIT_AUTOMAKE invocation. See automake bug#16841. ]) dnl Hook into '_AC_COMPILER_EXEEXT' early to learn its expansion. Do not dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further dnl mangled by Autoconf and run in a shell conditional statement. m4_define([_AC_COMPILER_EXEEXT], m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])]) # When config.status generates a header, we must update the stamp-h file. # This file resides in the same directory as the config header # that is generated. The stamp files are numbered to have different names. # Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the # loop where config.status creates the headers, so we can generate # our stamp files there. AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK], [# Compute $1's index in $config_headers. _am_arg=$1 _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) # Copyright (C) 2001-2024 Free Software Foundation, Inc. # # This file 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. # AM_PROG_INSTALL_SH # ------------------ # Define $install_sh. AC_DEFUN([AM_PROG_INSTALL_SH], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; *) install_sh="\${SHELL} $am_aux_dir/install-sh" esac fi AC_SUBST([install_sh])]) # Copyright (C) 2003-2024 Free Software Foundation, Inc. # # This file 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. # Check whether the underlying file-system supports filenames # with a leading dot. For instance MS-DOS doesn't. AC_DEFUN([AM_SET_LEADING_DOT], [rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null AC_SUBST([am__leading_dot])]) # Copyright (C) 1996-2024 Free Software Foundation, Inc. # # This file 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. # AM_PATH_LISPDIR # --------------- AC_DEFUN([AM_PATH_LISPDIR], [AC_PREREQ([2.60])dnl # If set to t, that means we are running in a shell under Emacs. # If you have an Emacs named "t", then use the full path. test x"$EMACS" = xt && EMACS= AC_CHECK_PROGS([EMACS], [emacs xemacs], [no]) AC_ARG_VAR([EMACS], [the Emacs editor command]) AC_ARG_VAR([EMACSLOADPATH], [the Emacs library search path]) AC_ARG_WITH([lispdir], [AS_HELP_STRING([--with-lispdir], [override the default lisp directory])], [ lispdir="$withval" AC_MSG_CHECKING([where .elc files should go]) AC_MSG_RESULT([$lispdir])], [ AC_CACHE_CHECK([where .elc files should go], [am_cv_lispdir], [ if test $EMACS != "no"; then if test x${lispdir+set} != xset; then # If $EMACS isn't GNU Emacs or XEmacs, this can blow up pretty badly # Some emacsen will start up in interactive mode, requiring C-x C-c to exit, # which is non-obvious for non-emacs users. # Redirecting /dev/null should help a bit; pity we can't detect "broken" # emacsen earlier and avoid running this altogether. AC_RUN_LOG([$EMACS -batch -no-site-file -eval '(while load-path (princ (concat (car load-path) "\n")) (setq load-path (cdr load-path)))' conftest.out]) am_cv_lispdir=`sed -n \ -e 's,/$,,' \ -e '/.*\/lib\/x*emacs\/site-lisp$/{s,.*/lib/\(x*emacs/site-lisp\)$,${libdir}/\1,;p;q;}' \ -e '/.*\/share\/x*emacs\/site-lisp$/{s,.*/share/\(x*emacs/site-lisp\),${datarootdir}/\1,;p;q;}' \ conftest.out` rm conftest.out fi fi test -z "$am_cv_lispdir" && am_cv_lispdir='${datadir}/emacs/site-lisp' ]) lispdir="$am_cv_lispdir" ]) AC_SUBST([lispdir]) ])# AM_PATH_LISPDIR # Check to see how 'make' treats includes. -*- Autoconf -*- # Copyright (C) 2001-2024 Free Software Foundation, Inc. # # This file 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. # AM_MAKE_INCLUDE() # ----------------- # Check whether make has an 'include' directive that can support all # the idioms we need for our automatic dependency tracking code. AC_DEFUN([AM_MAKE_INCLUDE], [AC_MSG_CHECKING([whether ${MAKE-make} supports the include directive]) cat > confinc.mk << 'END' am__doit: @echo this is the am__doit target >confinc.out .PHONY: am__doit END am__include="#" am__quote= # BSD make does it like this. echo '.include "confinc.mk" # ignored' > confmf.BSD # Other make implementations (GNU, Solaris 10, AIX) do it like this. echo 'include confinc.mk # ignored' > confmf.GNU _am_result=no for s in GNU BSD; do AM_RUN_LOG([${MAKE-make} -f confmf.$s && cat confinc.out]) AS_CASE([$?:`cat confinc.out 2>/dev/null`], ['0:this is the am__doit target'], [AS_CASE([$s], [BSD], [am__include='.include' am__quote='"'], [am__include='include' am__quote=''])]) if test "$am__include" != "#"; then _am_result="yes ($s style)" break fi done rm -f confinc.* confmf.* AC_MSG_RESULT([${_am_result}]) AC_SUBST([am__include])]) AC_SUBST([am__quote])]) # Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- # Copyright (C) 1997-2024 Free Software Foundation, Inc. # # This file 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. # AM_MISSING_PROG(NAME, PROGRAM) # ------------------------------ AC_DEFUN([AM_MISSING_PROG], [AC_REQUIRE([AM_MISSING_HAS_RUN]) $1=${$1-"${am_missing_run}$2"} AC_SUBST($1)]) # AM_MISSING_HAS_RUN # ------------------ # Define MISSING if not defined so far and test if it is modern enough. # If it is, set am_missing_run to use it, otherwise, to nothing. AC_DEFUN([AM_MISSING_HAS_RUN], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([missing])dnl if test x"${MISSING+set}" != xset; then MISSING="\${SHELL} '$am_aux_dir/missing'" fi # Use eval to expand $SHELL if eval "$MISSING --is-lightweight"; then am_missing_run="$MISSING " else am_missing_run= AC_MSG_WARN(['missing' script is too old or missing]) fi ]) # Helper functions for option handling. -*- Autoconf -*- # Copyright (C) 2001-2024 Free Software Foundation, Inc. # # This file 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. # _AM_MANGLE_OPTION(NAME) # ----------------------- AC_DEFUN([_AM_MANGLE_OPTION], [[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])]) # _AM_SET_OPTION(NAME) # -------------------- # Set option NAME. Presently that only means defining a flag for this option. AC_DEFUN([_AM_SET_OPTION], [m4_define(_AM_MANGLE_OPTION([$1]), [1])]) # _AM_SET_OPTIONS(OPTIONS) # ------------------------ # OPTIONS is a space-separated list of Automake options. AC_DEFUN([_AM_SET_OPTIONS], [m4_foreach_w([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])]) # _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET]) # ------------------------------------------- # Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. AC_DEFUN([_AM_IF_OPTION], [m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) # Copyright (C) 1999-2024 Free Software Foundation, Inc. # # This file 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. # _AM_PROG_CC_C_O # --------------- # Like AC_PROG_CC_C_O, but changed for automake. We rewrite AC_PROG_CC # to automatically call this. AC_DEFUN([_AM_PROG_CC_C_O], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([compile])dnl AC_LANG_PUSH([C])dnl AC_CACHE_CHECK( [whether $CC understands -c and -o together], [am_cv_prog_cc_c_o], [AC_LANG_CONFTEST([AC_LANG_PROGRAM([])]) # Make sure it works both with $CC and with simple cc. # Following AC_PROG_CC_C_O, we do the test twice because some # compilers refuse to overwrite an existing .o file with -o, # though they will create one. am_cv_prog_cc_c_o=yes for am_i in 1 2; do if AM_RUN_LOG([$CC -c conftest.$ac_ext -o conftest2.$ac_objext]) \ && test -f conftest2.$ac_objext; then : OK else am_cv_prog_cc_c_o=no break fi done rm -f core conftest* unset am_i]) if test "$am_cv_prog_cc_c_o" != yes; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" fi AC_LANG_POP([C])]) # For backward compatibility. AC_DEFUN_ONCE([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC])]) # Copyright (C) 2022-2024 Free Software Foundation, Inc. # # This file 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. # _AM_PROG_RM_F # --------------- # Check whether 'rm -f' without any arguments works. # https://bugs.gnu.org/10828 AC_DEFUN([_AM_PROG_RM_F], [am__rm_f_notfound= AS_IF([(rm -f && rm -fr && rm -rf) 2>/dev/null], [], [am__rm_f_notfound='""']) AC_SUBST(am__rm_f_notfound) ]) # Copyright (C) 2001-2024 Free Software Foundation, Inc. # # This file 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. # AM_RUN_LOG(COMMAND) # ------------------- # Run COMMAND, save the exit status in ac_status, and log it. # (This has been adapted from Autoconf's _AC_RUN_LOG macro.) AC_DEFUN([AM_RUN_LOG], [{ echo "$as_me:$LINENO: $1" >&AS_MESSAGE_LOG_FD ($1) >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD (exit $ac_status); }]) # Check to make sure that the build environment is sane. -*- Autoconf -*- # Copyright (C) 1996-2024 Free Software Foundation, Inc. # # This file 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. # _AM_SLEEP_FRACTIONAL_SECONDS # ---------------------------- AC_DEFUN([_AM_SLEEP_FRACTIONAL_SECONDS], [dnl AC_CACHE_CHECK([whether sleep supports fractional seconds], am_cv_sleep_fractional_seconds, [dnl AS_IF([sleep 0.001 2>/dev/null], [am_cv_sleep_fractional_seconds=yes], [am_cv_sleep_fractional_seconds=no]) ])]) # _AM_FILESYSTEM_TIMESTAMP_RESOLUTION # ----------------------------------- # Determine the filesystem's resolution for file modification # timestamps. The coarsest we know of is FAT, with a resolution # of only two seconds, even with the most recent "exFAT" extensions. # The finest (e.g. ext4 with large inodes, XFS, ZFS) is one # nanosecond, matching clock_gettime. However, it is probably not # possible to delay execution of a shell script for less than one # millisecond, due to process creation overhead and scheduling # granularity, so we don't check for anything finer than that. (See below.) AC_DEFUN([_AM_FILESYSTEM_TIMESTAMP_RESOLUTION], [dnl AC_REQUIRE([_AM_SLEEP_FRACTIONAL_SECONDS]) AC_CACHE_CHECK([filesystem timestamp resolution], am_cv_filesystem_timestamp_resolution, [dnl # Default to the worst case. am_cv_filesystem_timestamp_resolution=2 # Only try to go finer than 1 sec if sleep can do it. # Don't try 1 sec, because if 0.01 sec and 0.1 sec don't work, # - 1 sec is not much of a win compared to 2 sec, and # - it takes 2 seconds to perform the test whether 1 sec works. # # Instead, just use the default 2s on platforms that have 1s resolution, # accept the extra 1s delay when using $sleep in the Automake tests, in # exchange for not incurring the 2s delay for running the test for all # packages. # am_try_resolutions= if test "$am_cv_sleep_fractional_seconds" = yes; then # Even a millisecond often causes a bunch of false positives, # so just try a hundredth of a second. The time saved between .001 and # .01 is not terribly consequential. am_try_resolutions="0.01 0.1 $am_try_resolutions" fi # In order to catch current-generation FAT out, we must *modify* files # that already exist; the *creation* timestamp is finer. Use names # that make ls -t sort them differently when they have equal # timestamps than when they have distinct timestamps, keeping # in mind that ls -t prints the *newest* file first. rm -f conftest.ts? : > conftest.ts1 : > conftest.ts2 : > conftest.ts3 # Make sure ls -t actually works. Do 'set' in a subshell so we don't # clobber the current shell's arguments. (Outer-level square brackets # are removed by m4; they're present so that m4 does not expand # ; be careful, easy to get confused.) if ( set X `[ls -t conftest.ts[12]]` && { test "$[]*" != "X conftest.ts1 conftest.ts2" || test "$[]*" != "X conftest.ts2 conftest.ts1"; } ); then :; else # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". _AS_ECHO_UNQUOTED( ["Bad output from ls -t: \"`[ls -t conftest.ts[12]]`\""], [AS_MESSAGE_LOG_FD]) AC_MSG_FAILURE([ls -t produces unexpected output. Make sure there is not a broken ls alias in your environment.]) fi for am_try_res in $am_try_resolutions; do # Any one fine-grained sleep might happen to cross the boundary # between two values of a coarser actual resolution, but if we do # two fine-grained sleeps in a row, at least one of them will fall # entirely within a coarse interval. echo alpha > conftest.ts1 sleep $am_try_res echo beta > conftest.ts2 sleep $am_try_res echo gamma > conftest.ts3 # We assume that 'ls -t' will make use of high-resolution # timestamps if the operating system supports them at all. if (set X `ls -t conftest.ts?` && test "$[]2" = conftest.ts3 && test "$[]3" = conftest.ts2 && test "$[]4" = conftest.ts1); then # # Ok, ls -t worked. If we're at a resolution of 1 second, we're done, # because we don't need to test make. make_ok=true if test $am_try_res != 1; then # But if we've succeeded so far with a subsecond resolution, we # have one more thing to check: make. It can happen that # everything else supports the subsecond mtimes, but make doesn't; # notably on macOS, which ships make 3.81 from 2006 (the last one # released under GPLv2). https://bugs.gnu.org/68808 # # We test $MAKE if it is defined in the environment, else "make". # It might get overridden later, but our hope is that in practice # it does not matter: it is the system "make" which is (by far) # the most likely to be broken, whereas if the user overrides it, # probably they did so with a better, or at least not worse, make. # https://lists.gnu.org/archive/html/automake/2024-06/msg00051.html # # Create a Makefile (real tab character here): rm -f conftest.mk echo 'conftest.ts1: conftest.ts2' >conftest.mk echo ' touch conftest.ts2' >>conftest.mk # # Now, running # touch conftest.ts1; touch conftest.ts2; make # should touch ts1 because ts2 is newer. This could happen by luck, # but most often, it will fail if make's support is insufficient. So # test for several consecutive successes. # # (We reuse conftest.ts[12] because we still want to modify existing # files, not create new ones, per above.) n=0 make=${MAKE-make} until test $n -eq 3; do echo one > conftest.ts1 sleep $am_try_res echo two > conftest.ts2 # ts2 should now be newer than ts1 if $make -f conftest.mk | grep 'up to date' >/dev/null; then make_ok=false break # out of $n loop fi n=`expr $n + 1` done fi # if $make_ok; then # Everything we know to check worked out, so call this resolution good. am_cv_filesystem_timestamp_resolution=$am_try_res break # out of $am_try_res loop fi # Otherwise, we'll go on to check the next resolution. fi done rm -f conftest.ts? # (end _am_filesystem_timestamp_resolution) ])]) # AM_SANITY_CHECK # --------------- AC_DEFUN([AM_SANITY_CHECK], [AC_REQUIRE([_AM_FILESYSTEM_TIMESTAMP_RESOLUTION]) # This check should not be cached, as it may vary across builds of # different projects. AC_MSG_CHECKING([whether build environment is sane]) # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[[\\\"\#\$\&\'\`$am_lf]]*) AC_MSG_ERROR([unsafe absolute working directory name]);; esac case $srcdir in *[[\\\"\#\$\&\'\`$am_lf\ \ ]]*) AC_MSG_ERROR([unsafe srcdir value: '$srcdir']);; esac # Do 'set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). am_build_env_is_sane=no am_has_slept=no rm -f conftest.file for am_try in 1 2; do echo "timestamp, slept: $am_has_slept" > conftest.file if ( set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` if test "$[]*" = "X"; then # -L didn't work. set X `ls -t "$srcdir/configure" conftest.file` fi test "$[]2" = conftest.file ); then am_build_env_is_sane=yes break fi # Just in case. sleep "$am_cv_filesystem_timestamp_resolution" am_has_slept=yes done AC_MSG_RESULT([$am_build_env_is_sane]) if test "$am_build_env_is_sane" = no; then AC_MSG_ERROR([newly created file is older than distributed files! Check your system clock]) fi # If we didn't sleep, we still need to ensure time stamps of config.status and # generated files are strictly newer. am_sleep_pid= AS_IF([test -e conftest.file || grep 'slept: no' conftest.file >/dev/null 2>&1],, [dnl ( sleep "$am_cv_filesystem_timestamp_resolution" ) & am_sleep_pid=$! ]) AC_CONFIG_COMMANDS_PRE( [AC_MSG_CHECKING([that generated files are newer than configure]) if test -n "$am_sleep_pid"; then # Hide warnings about reused PIDs. wait $am_sleep_pid 2>/dev/null fi AC_MSG_RESULT([done])]) rm -f conftest.file ]) # Copyright (C) 2009-2024 Free Software Foundation, Inc. # # This file 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. # _AM_SILENT_RULES # ---------------- # Enable less verbose build rules support. AC_DEFUN([_AM_SILENT_RULES], [AM_DEFAULT_VERBOSITY=1 AC_ARG_ENABLE([silent-rules], [dnl AS_HELP_STRING( [--enable-silent-rules], [less verbose build output (undo: "make V=1")]) AS_HELP_STRING( [--disable-silent-rules], [verbose build output (undo: "make V=0")])dnl ]) dnl dnl A few 'make' implementations (e.g., NonStop OS and NextStep) dnl do not support nested variable expansions. dnl See automake bug#9928 and bug#10237. am_make=${MAKE-make} AC_CACHE_CHECK([whether $am_make supports nested variables], [am_cv_make_support_nested_variables], [if AS_ECHO([['TRUE=$(BAR$(V)) BAR0=false BAR1=true V=1 am__doit: @$(TRUE) .PHONY: am__doit']]) | $am_make -f - >/dev/null 2>&1; then am_cv_make_support_nested_variables=yes else am_cv_make_support_nested_variables=no fi]) AC_SUBST([AM_V])dnl AM_SUBST_NOTMAKE([AM_V])dnl AC_SUBST([AM_DEFAULT_V])dnl AM_SUBST_NOTMAKE([AM_DEFAULT_V])dnl AC_SUBST([AM_DEFAULT_VERBOSITY])dnl AM_BACKSLASH='\' AC_SUBST([AM_BACKSLASH])dnl _AM_SUBST_NOTMAKE([AM_BACKSLASH])dnl dnl Delay evaluation of AM_DEFAULT_VERBOSITY to the end to allow multiple calls dnl to AM_SILENT_RULES to change the default value. AC_CONFIG_COMMANDS_PRE([dnl case $enable_silent_rules in @%:@ ((( yes) AM_DEFAULT_VERBOSITY=0;; no) AM_DEFAULT_VERBOSITY=1;; esac if test $am_cv_make_support_nested_variables = yes; then dnl Using '$V' instead of '$(V)' breaks IRIX make. AM_V='$(V)' AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' else AM_V=$AM_DEFAULT_VERBOSITY AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY fi ])dnl ]) # AM_SILENT_RULES([DEFAULT]) # -------------------------- # Set the default verbosity level to DEFAULT ("yes" being less verbose, "no" or # empty being verbose). AC_DEFUN([AM_SILENT_RULES], [AC_REQUIRE([_AM_SILENT_RULES]) AM_DEFAULT_VERBOSITY=m4_if([$1], [yes], [0], [1])]) # Copyright (C) 2001-2024 Free Software Foundation, Inc. # # This file 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. # AM_PROG_INSTALL_STRIP # --------------------- # One issue with vendor 'install' (even GNU) is that you can't # specify the program used to strip binaries. This is especially # annoying in cross-compiling environments, where the build's strip # is unlikely to handle the host's binaries. # Fortunately install-sh will honor a STRIPPROG variable, so we # always use install-sh in "make install-strip", and initialize # STRIPPROG with the value of the STRIP variable (set by the user). AC_DEFUN([AM_PROG_INSTALL_STRIP], [AC_REQUIRE([AM_PROG_INSTALL_SH])dnl # Installed binaries are usually stripped using 'strip' when the user # run "make install-strip". However 'strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the 'STRIP' environment variable to overrule this program. dnl Don't test for $cross_compiling = yes, because it might be 'maybe'. if test "$cross_compiling" != no; then AC_CHECK_TOOL([STRIP], [strip], :) fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" AC_SUBST([INSTALL_STRIP_PROGRAM])]) # Copyright (C) 2006-2024 Free Software Foundation, Inc. # # This file 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. # _AM_SUBST_NOTMAKE(VARIABLE) # --------------------------- # Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in. # This macro is traced by Automake. AC_DEFUN([_AM_SUBST_NOTMAKE]) # AM_SUBST_NOTMAKE(VARIABLE) # -------------------------- # Public sister of _AM_SUBST_NOTMAKE. AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)]) # Check how to create a tarball. -*- Autoconf -*- # Copyright (C) 2004-2024 Free Software Foundation, Inc. # # This file 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. # _AM_PROG_TAR(FORMAT) # -------------------- # Check how to create a tarball in format FORMAT. # FORMAT should be one of 'v7', 'ustar', or 'pax'. # # Substitute a variable $(am__tar) that is a command # writing to stdout a FORMAT-tarball containing the directory # $tardir. # tardir=directory && $(am__tar) > result.tar # # Substitute a variable $(am__untar) that extract such # a tarball read from stdin. # $(am__untar) < result.tar # AC_DEFUN([_AM_PROG_TAR], [# Always define AMTAR for backward compatibility. Yes, it's still used # in the wild :-( We should find a proper way to deprecate it ... AC_SUBST([AMTAR], ['$${TAR-tar}']) # We'll loop over all known methods to create a tar archive until one works. _am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' m4_if([$1], [v7], [am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'], [m4_case([$1], [ustar], [# The POSIX 1988 'ustar' format is defined with fixed-size fields. # There is notably a 21 bits limit for the UID and the GID. In fact, # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343 # and bug#13588). am_max_uid=2097151 # 2^21 - 1 am_max_gid=$am_max_uid # The $UID and $GID variables are not portable, so we need to resort # to the POSIX-mandated id(1) utility. Errors in the 'id' calls # below are definitely unexpected, so allow the users to see them # (that is, avoid stderr redirection). am_uid=`id -u || echo unknown` am_gid=`id -g || echo unknown` AC_MSG_CHECKING([whether UID '$am_uid' is supported by ustar format]) if test x$am_uid = xunknown; then AC_MSG_WARN([ancient id detected; assuming current UID is ok, but dist-ustar might not work]) elif test $am_uid -le $am_max_uid; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) _am_tools=none fi AC_MSG_CHECKING([whether GID '$am_gid' is supported by ustar format]) if test x$gm_gid = xunknown; then AC_MSG_WARN([ancient id detected; assuming current GID is ok, but dist-ustar might not work]) elif test $am_gid -le $am_max_gid; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) _am_tools=none fi], [pax], [], [m4_fatal([Unknown tar format])]) AC_MSG_CHECKING([how to create a $1 tar archive]) # Go ahead even if we have the value already cached. We do so because we # need to set the values for the 'am__tar' and 'am__untar' variables. _am_tools=${am_cv_prog_tar_$1-$_am_tools} for _am_tool in $_am_tools; do case $_am_tool in gnutar) for _am_tar in tar gnutar gtar; do AM_RUN_LOG([$_am_tar --version]) && break done am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"' am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"' am__untar="$_am_tar -xf -" ;; plaintar) # Must skip GNU tar: if it does not support --format= it doesn't create # ustar tarball either. (tar --version) >/dev/null 2>&1 && continue am__tar='tar chf - "$$tardir"' am__tar_='tar chf - "$tardir"' am__untar='tar xf -' ;; pax) am__tar='pax -L -x $1 -w "$$tardir"' am__tar_='pax -L -x $1 -w "$tardir"' am__untar='pax -r' ;; cpio) am__tar='find "$$tardir" -print | cpio -o -H $1 -L' am__tar_='find "$tardir" -print | cpio -o -H $1 -L' am__untar='cpio -i -H $1 -d' ;; none) am__tar=false am__tar_=false am__untar=false ;; esac # If the value was cached, stop now. We just wanted to have am__tar # and am__untar set. test -n "${am_cv_prog_tar_$1}" && break # tar/untar a dummy directory, and stop if the command works. rm -rf conftest.dir mkdir conftest.dir echo GrepMe > conftest.dir/file AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar]) rm -rf conftest.dir if test -s conftest.tar; then AM_RUN_LOG([$am__untar /dev/null 2>&1 && break fi done rm -rf conftest.dir AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool]) AC_MSG_RESULT([$am_cv_prog_tar_$1])]) AC_SUBST([am__tar]) AC_SUBST([am__untar]) ]) # _AM_PROG_TAR # Copyright (C) 2022-2024 Free Software Foundation, Inc. # # This file 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. # _AM_PROG_XARGS_N # ---------------- # Check whether 'xargs -n' works. It should work everywhere, so the fallback # is not optimized at all as we never expect to use it. AC_DEFUN([_AM_PROG_XARGS_N], [AC_CACHE_CHECK([xargs -n works], am_cv_xargs_n_works, [dnl AS_IF([test "`echo 1 2 3 | xargs -n2 echo`" = "1 2 3"], [am_cv_xargs_n_works=yes], [am_cv_xargs_n_works=no])]) AS_IF([test "$am_cv_xargs_n_works" = yes], [am__xargs_n='xargs -n'], [dnl am__xargs_n='am__xargs_n () { shift; sed "s/ /\\n/g" | while read am__xargs_n_arg; do "$@" "$am__xargs_n_arg"; done; }' ])dnl AC_SUBST(am__xargs_n) ]) gcl-2.7.1/PaxHeaders/configure0000644000000000000000000000013214776130436013263 xustar0030 mtime=1744351518.943058648 30 atime=1744351520.003049004 30 ctime=1744351535.394910007 gcl-2.7.1/configure0000755000175000017500000132603214776130436012673 0ustar00cammcamm#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.72 for gcl 2.7.1. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 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 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 case e in #( e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; 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="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 case e in #( e) case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; 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 case e in #( e) exitcode=1; echo positional parameters were not saved. ;; esac 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 case e in #( e) as_have_required=no ;; esac fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : else case e in #( e) 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 case e in #( e) 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 ;; esac 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 ;; esac 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_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 case e in #( e) as_fn_append () { eval $1=\$$1\$2 } ;; esac 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 case e in #( e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } ;; esac fi # as_fn_arith # 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 ' t clear :clear 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_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" as_tr_sh="eval sed '$as_sed_sh'" # deprecated 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='gcl' PACKAGE_TARNAME='gcl' PACKAGE_VERSION='2.7.1' PACKAGE_STRING='gcl 2.7.1' 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='am__EXEEXT_FALSE am__EXEEXT_TRUE LTLIBOBJS LIBOBJS LI_INIT_LSP LI_OPT_TWO LI_OPT_THREE LI_LD_LIBS LI_LD LI_DFP LI_CC LI_RELEASE LI_GITTAG LI_MAJVERS LI_MINVERS LI_EXTVERS GNU_LD LEADING_UNDERSCORE EXTRA_LOBJS O2FLAGS O3FLAGS BASE_CPPFLAGS BASE_CFLAGS NIFLAGS FINAL_CFLAGS BASE_LDFLAGS ALLOCA EXT TCL_LIB_SPEC TK_LIB_SPEC TCL_INCLUDE TK_INCLUDE TCL_LIBRARY TK_LIBRARY TK_XLIB_DIR TK_CONFIG_PREFIX AMM_TK_FALSE AMM_TK_TRUE TCLSH HAVE_SIGEMT HAVE_SIGSYS HAVE_SV_ONSTACK USE_CLEANUP HAVE_PUTENV HAVE_SETENV NO_PROFILE RL_LIB RL_OBJS HAVE_LONG_LONG PAGEWIDTH DOUBLE_BIGENDIAN WORDS_BIGENDIAN X_CFLAGS X_LIBS AMM_XGCL_FALSE AMM_XGCL_TRUE XMKMF GMPDIR GMP HAVE_MALLOC_ZONE_MEMALIGN AMM_GPROF_FALSE AMM_GPROF_TRUE GCL_CC CPP RANLIB am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE am__nodep AMDEPBACKSLASH AMDEP_FALSE AMDEP_TRUE am__include DEPDIR 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 lispdir EMACSLOADPATH EMACS am__xargs_n am__rm_f_notfound AM_BACKSLASH AM_DEFAULT_VERBOSITY AM_DEFAULT_V AM_V CSCOPE ETAGS CTAGS am__untar am__tar AMTAR am__leading_dot SET_MAKE AWK mkdir_p MKDIR_P INSTALL_STRIP_PROGRAM STRIP install_sh MAKEINFO AUTOHEADER AUTOMAKE AUTOCONF ACLOCAL VERSION PACKAGE CYGPATH_W am__isrc INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM 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 am__quote' ac_subst_files='' ac_user_opts=' enable_option_checking enable_silent_rules with_lispdir enable_machine enable_widecons enable_safecdr enable_safecdrdbg enable_prelink enable_vssize enable_bdssize enable_ihssize enable_frssize enable_infodir enable_xgcl enable_debug enable_static enable_pic enable_dependency_tracking enable_gprof with_x enable_xdr enable_immfix enable_fastimmfix enable_min_pagewidth enable_readline enable_tcltk enable_tkconfig enable_tclconfig ' ac_precious_vars='build_alias host_alias target_alias EMACS EMACSLOADPATH 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_TARNAME}' 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 gcl 2.7.1 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/gcl] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF Program names: --program-prefix=PREFIX prepend PREFIX to installed program names --program-suffix=SUFFIX append SUFFIX to installed program names --program-transform-name=PROGRAM run sed PROGRAM on installed program names 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 case $ac_init_help in short | recursive ) echo "Configuration of gcl 2.7.1:";; esac 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-silent-rules less verbose build output (undo: "make V=1") --disable-silent-rules verbose build output (undo: "make V=0") --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-xgcl=yes will compile in support for XGCL --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-dependency-tracking do not reject slow dependency extractors --disable-dependency-tracking speeds up one-time build --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof --enable-xdr=yes will compile in support for XDR --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-min_pagewidth=xxx sets 1< 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 gcl configure 2.7.1 generated by GNU Autoconf 2.72 Copyright (C) 2023 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 case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac 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_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 case e in #( e) 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 case e in #( e) eval "$3=no" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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_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 case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac 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 case e in #( e) 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 ;; esac 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_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 case e in #( e) 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 case e in #( e) 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 case e in #( e) eval "$4=no" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac 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 case e in #( e) 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 (void); 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 (void); /* 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 case e in #( e) eval "$3=no" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext ;; esac 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 case e in #( e) 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 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done else case e in #( e) 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 case e in #( e) 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 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done else case e in #( e) ac_lo= ac_hi= ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val ;; esac 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 whether $as_decl_name is declared... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else case e in #( e) as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` eval ac_save_FLAGS=\$$6 as_fn_append $6 " $5" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { #ifndef $as_decl_name #ifdef __cplusplus (void) $as_decl_use; #else (void) $as_decl_name; #endif #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" else case e in #( e) eval "$3=no" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext eval $6=\$ac_save_FLAGS ;; esac 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_check_decl # ac_fn_c_check_type LINENO TYPE VAR INCLUDES # ------------------------------------------- # Tests whether TYPE exists after having included INCLUDES, setting cache # variable VAR accordingly. ac_fn_c_check_type () { 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 case e in #( e) 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 case e in #( e) eval "$3=yes" ;; esac 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 ;; esac 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 gcl $as_me 2.7.1, which was generated by GNU Autoconf 2.72. 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 as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" # 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 (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; } /* C89 style stringification. */ #define noexpand_stringify(a) #a const char *stringified = noexpand_stringify(arbitrary+token=sequence); /* C89 style token pasting. Exercises some of the corner cases that e.g. old MSVC gets wrong, but not very hard. */ #define noexpand_concat(a,b) a##b #define expand_concat(a,b) noexpand_concat(a,b) extern int vA; extern int vbee; #define aye A #define bee B int *pvA = &expand_concat(v,aye); int *pvbee = &noexpand_concat(v,bee); /* 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 // See if C++-style comments work. #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); extern void free (void *); // 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) { // 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; // Work around memory leak warnings. free (ia); // 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 " 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" as_fn_append ac_header_c_list " wchar.h wchar_h HAVE_WCHAR_H" as_fn_append ac_header_c_list " minix/config.h minix_config_h HAVE_MINIX_CONFIG_H" # Auxiliary files required by this configure script. ac_aux_files="compile config.guess config.sub missing install-sh" # 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 case e in #( e) as_fn_error $? "cannot find required auxiliary files:$ac_missing_aux_files" "$LINENO" 5 ;; esac 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" am__api_version='1.17' # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 printf %s "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if test ${ac_cv_path_install+y} then : printf %s "(cached) " >&6 else case e in #( e) 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 # Account for fact that we put trailing slashes in our PATH walk. case $as_dir in #(( ./ | /[cC]/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_prog$ac_exec_ext"; then if test $ac_prog = install && grep dspmsg "$as_dir$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir/" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir ;; esac fi if test ${ac_cv_path_install+y}; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 printf "%s\n" "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether sleep supports fractional seconds" >&5 printf %s "checking whether sleep supports fractional seconds... " >&6; } if test ${am_cv_sleep_fractional_seconds+y} then : printf %s "(cached) " >&6 else case e in #( e) if sleep 0.001 2>/dev/null then : am_cv_sleep_fractional_seconds=yes else case e in #( e) am_cv_sleep_fractional_seconds=no ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_sleep_fractional_seconds" >&5 printf "%s\n" "$am_cv_sleep_fractional_seconds" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking filesystem timestamp resolution" >&5 printf %s "checking filesystem timestamp resolution... " >&6; } if test ${am_cv_filesystem_timestamp_resolution+y} then : printf %s "(cached) " >&6 else case e in #( e) # Default to the worst case. am_cv_filesystem_timestamp_resolution=2 # Only try to go finer than 1 sec if sleep can do it. # Don't try 1 sec, because if 0.01 sec and 0.1 sec don't work, # - 1 sec is not much of a win compared to 2 sec, and # - it takes 2 seconds to perform the test whether 1 sec works. # # Instead, just use the default 2s on platforms that have 1s resolution, # accept the extra 1s delay when using $sleep in the Automake tests, in # exchange for not incurring the 2s delay for running the test for all # packages. # am_try_resolutions= if test "$am_cv_sleep_fractional_seconds" = yes; then # Even a millisecond often causes a bunch of false positives, # so just try a hundredth of a second. The time saved between .001 and # .01 is not terribly consequential. am_try_resolutions="0.01 0.1 $am_try_resolutions" fi # In order to catch current-generation FAT out, we must *modify* files # that already exist; the *creation* timestamp is finer. Use names # that make ls -t sort them differently when they have equal # timestamps than when they have distinct timestamps, keeping # in mind that ls -t prints the *newest* file first. rm -f conftest.ts? : > conftest.ts1 : > conftest.ts2 : > conftest.ts3 # Make sure ls -t actually works. Do 'set' in a subshell so we don't # clobber the current shell's arguments. (Outer-level square brackets # are removed by m4; they're present so that m4 does not expand # ; be careful, easy to get confused.) if ( set X `ls -t conftest.ts[12]` && { test "$*" != "X conftest.ts1 conftest.ts2" || test "$*" != "X conftest.ts2 conftest.ts1"; } ); then :; else # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". printf "%s\n" ""Bad output from ls -t: \"`ls -t conftest.ts[12]`\""" >&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 $? "ls -t produces unexpected output. Make sure there is not a broken ls alias in your environment. See 'config.log' for more details" "$LINENO" 5; } fi for am_try_res in $am_try_resolutions; do # Any one fine-grained sleep might happen to cross the boundary # between two values of a coarser actual resolution, but if we do # two fine-grained sleeps in a row, at least one of them will fall # entirely within a coarse interval. echo alpha > conftest.ts1 sleep $am_try_res echo beta > conftest.ts2 sleep $am_try_res echo gamma > conftest.ts3 # We assume that 'ls -t' will make use of high-resolution # timestamps if the operating system supports them at all. if (set X `ls -t conftest.ts?` && test "$2" = conftest.ts3 && test "$3" = conftest.ts2 && test "$4" = conftest.ts1); then # # Ok, ls -t worked. If we're at a resolution of 1 second, we're done, # because we don't need to test make. make_ok=true if test $am_try_res != 1; then # But if we've succeeded so far with a subsecond resolution, we # have one more thing to check: make. It can happen that # everything else supports the subsecond mtimes, but make doesn't; # notably on macOS, which ships make 3.81 from 2006 (the last one # released under GPLv2). https://bugs.gnu.org/68808 # # We test $MAKE if it is defined in the environment, else "make". # It might get overridden later, but our hope is that in practice # it does not matter: it is the system "make" which is (by far) # the most likely to be broken, whereas if the user overrides it, # probably they did so with a better, or at least not worse, make. # https://lists.gnu.org/archive/html/automake/2024-06/msg00051.html # # Create a Makefile (real tab character here): rm -f conftest.mk echo 'conftest.ts1: conftest.ts2' >conftest.mk echo ' touch conftest.ts2' >>conftest.mk # # Now, running # touch conftest.ts1; touch conftest.ts2; make # should touch ts1 because ts2 is newer. This could happen by luck, # but most often, it will fail if make's support is insufficient. So # test for several consecutive successes. # # (We reuse conftest.ts[12] because we still want to modify existing # files, not create new ones, per above.) n=0 make=${MAKE-make} until test $n -eq 3; do echo one > conftest.ts1 sleep $am_try_res echo two > conftest.ts2 # ts2 should now be newer than ts1 if $make -f conftest.mk | grep 'up to date' >/dev/null; then make_ok=false break # out of $n loop fi n=`expr $n + 1` done fi # if $make_ok; then # Everything we know to check worked out, so call this resolution good. am_cv_filesystem_timestamp_resolution=$am_try_res break # out of $am_try_res loop fi # Otherwise, we'll go on to check the next resolution. fi done rm -f conftest.ts? # (end _am_filesystem_timestamp_resolution) ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_filesystem_timestamp_resolution" >&5 printf "%s\n" "$am_cv_filesystem_timestamp_resolution" >&6; } # This check should not be cached, as it may vary across builds of # different projects. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5 printf %s "checking whether build environment is sane... " >&6; } # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[\\\"\#\$\&\'\`$am_lf]*) as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; esac case $srcdir in *[\\\"\#\$\&\'\`$am_lf\ \ ]*) as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; esac # Do 'set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). am_build_env_is_sane=no am_has_slept=no rm -f conftest.file for am_try in 1 2; do echo "timestamp, slept: $am_has_slept" > conftest.file if ( set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` if test "$*" = "X"; then # -L didn't work. set X `ls -t "$srcdir/configure" conftest.file` fi test "$2" = conftest.file ); then am_build_env_is_sane=yes break fi # Just in case. sleep "$am_cv_filesystem_timestamp_resolution" am_has_slept=yes done { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_build_env_is_sane" >&5 printf "%s\n" "$am_build_env_is_sane" >&6; } if test "$am_build_env_is_sane" = no; then as_fn_error $? "newly created file is older than distributed files! Check your system clock" "$LINENO" 5 fi # If we didn't sleep, we still need to ensure time stamps of config.status and # generated files are strictly newer. am_sleep_pid= if test -e conftest.file || grep 'slept: no' conftest.file >/dev/null 2>&1 then : else case e in #( e) ( sleep "$am_cv_filesystem_timestamp_resolution" ) & am_sleep_pid=$! ;; esac fi rm -f conftest.file test "$program_prefix" != NONE && program_transform_name="s&^&$program_prefix&;$program_transform_name" # Use a double $ so make ignores it. test "$program_suffix" != NONE && program_transform_name="s&\$&$program_suffix&;$program_transform_name" # Double any \ or $. # By default was 's,x,x', remove it if useless. ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' program_transform_name=`printf "%s\n" "$program_transform_name" | sed "$ac_script"` # Expand $ac_aux_dir to an absolute path. am_aux_dir=`cd "$ac_aux_dir" && pwd` if test x"${MISSING+set}" != xset; then MISSING="\${SHELL} '$am_aux_dir/missing'" fi # Use eval to expand $SHELL if eval "$MISSING --is-lightweight"; then am_missing_run="$MISSING " else am_missing_run= { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 printf "%s\n" "$as_me: WARNING: 'missing' script is too old or missing" >&2;} fi if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; *) install_sh="\${SHELL} $am_aux_dir/install-sh" esac fi # Installed binaries are usually stripped using 'strip' when the user # run "make install-strip". However 'strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the 'STRIP' environment variable to overrule this program. if test "$cross_compiling" != no; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; 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_STRIP+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # 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_STRIP="${ac_tool_prefix}strip" 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 ;; esac fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 printf "%s\n" "$STRIP" >&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_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; 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_STRIP+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # 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_STRIP="strip" 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 ;; esac fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 printf "%s\n" "$ac_ct_STRIP" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_STRIP" = x; then STRIP=":" 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 STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a race-free mkdir -p" >&5 printf %s "checking for a race-free mkdir -p... " >&6; } if test -z "$MKDIR_P"; then if test ${ac_cv_path_mkdir+y} then : printf %s "(cached) " >&6 else case e in #( e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_prog in mkdir gmkdir; do for ac_exec_ext in '' $ac_executable_extensions; do as_fn_executable_p "$as_dir$ac_prog$ac_exec_ext" || continue case `"$as_dir$ac_prog$ac_exec_ext" --version 2>&1` in #( 'mkdir ('*'coreutils) '* | \ *'BusyBox '* | \ 'mkdir (fileutils) '4.1*) ac_cv_path_mkdir=$as_dir$ac_prog$ac_exec_ext break 3;; esac done done done IFS=$as_save_IFS ;; esac fi test -d ./--version && rmdir ./--version if test ${ac_cv_path_mkdir+y}; then MKDIR_P="$ac_cv_path_mkdir -p" else # As a last resort, use plain mkdir -p, # in the hope it doesn't have the bugs of ancient mkdir. MKDIR_P='mkdir -p' fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 printf "%s\n" "$MKDIR_P" >&6; } for ac_prog in gawk mawk 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 case e in #( e) 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 ;; esac 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 printf %s "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`printf "%s\n" "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval test \${ac_cv_prog_make_${ac_make}_set+y} then : printf %s "(cached) " >&6 else case e in #( e) cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make ;; esac fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } SET_MAKE= else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null AM_DEFAULT_VERBOSITY=1 # Check whether --enable-silent-rules was given. if test ${enable_silent_rules+y} then : enableval=$enable_silent_rules; fi am_make=${MAKE-make} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 printf %s "checking whether $am_make supports nested variables... " >&6; } if test ${am_cv_make_support_nested_variables+y} then : printf %s "(cached) " >&6 else case e in #( e) if printf "%s\n" 'TRUE=$(BAR$(V)) BAR0=false BAR1=true V=1 am__doit: @$(TRUE) .PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then am_cv_make_support_nested_variables=yes else am_cv_make_support_nested_variables=no fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 printf "%s\n" "$am_cv_make_support_nested_variables" >&6; } AM_BACKSLASH='\' am__rm_f_notfound= if (rm -f && rm -fr && rm -rf) 2>/dev/null then : else case e in #( e) am__rm_f_notfound='""' ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking xargs -n works" >&5 printf %s "checking xargs -n works... " >&6; } if test ${am_cv_xargs_n_works+y} then : printf %s "(cached) " >&6 else case e in #( e) if test "`echo 1 2 3 | xargs -n2 echo`" = "1 2 3" then : am_cv_xargs_n_works=yes else case e in #( e) am_cv_xargs_n_works=no ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_xargs_n_works" >&5 printf "%s\n" "$am_cv_xargs_n_works" >&6; } if test "$am_cv_xargs_n_works" = yes then : am__xargs_n='xargs -n' else case e in #( e) am__xargs_n='am__xargs_n () { shift; sed "s/ /\\n/g" | while read am__xargs_n_arg; do "" "$am__xargs_n_arg"; done; }' ;; esac fi if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." am__isrc=' -I$(srcdir)' # test to see if srcdir already configured if test -f $srcdir/config.status; then as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi # Define the identity of the package. PACKAGE='gcl' VERSION='2.7.1' printf "%s\n" "#define PACKAGE \"$PACKAGE\"" >>confdefs.h printf "%s\n" "#define VERSION \"$VERSION\"" >>confdefs.h # Some tools Automake needs. ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} # For better backward compatibility. To be removed once Automake 1.9.x # dies out for good. For more background, see: # # mkdir_p='$(MKDIR_P)' # We need awk for the "check" target (and possibly the TAP driver). The # system "awk" is bad on some platforms. # Always define AMTAR for backward compatibility. Yes, it's still used # in the wild :-( We should find a proper way to deprecate it ... AMTAR='$${TAR-tar}' # We'll loop over all known methods to create a tar archive until one works. _am_tools='gnutar pax cpio none' { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to create a pax tar archive" >&5 printf %s "checking how to create a pax tar archive... " >&6; } # Go ahead even if we have the value already cached. We do so because we # need to set the values for the 'am__tar' and 'am__untar' variables. _am_tools=${am_cv_prog_tar_pax-$_am_tools} for _am_tool in $_am_tools; do case $_am_tool in gnutar) for _am_tar in tar gnutar gtar; do { echo "$as_me:$LINENO: $_am_tar --version" >&5 ($_am_tar --version) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && break done am__tar="$_am_tar --format=posix -chf - "'"$$tardir"' am__tar_="$_am_tar --format=posix -chf - "'"$tardir"' am__untar="$_am_tar -xf -" ;; plaintar) # Must skip GNU tar: if it does not support --format= it doesn't create # ustar tarball either. (tar --version) >/dev/null 2>&1 && continue am__tar='tar chf - "$$tardir"' am__tar_='tar chf - "$tardir"' am__untar='tar xf -' ;; pax) am__tar='pax -L -x pax -w "$$tardir"' am__tar_='pax -L -x pax -w "$tardir"' am__untar='pax -r' ;; cpio) am__tar='find "$$tardir" -print | cpio -o -H pax -L' am__tar_='find "$tardir" -print | cpio -o -H pax -L' am__untar='cpio -i -H pax -d' ;; none) am__tar=false am__tar_=false am__untar=false ;; esac # If the value was cached, stop now. We just wanted to have am__tar # and am__untar set. test -n "${am_cv_prog_tar_pax}" && break # tar/untar a dummy directory, and stop if the command works. rm -rf conftest.dir mkdir conftest.dir echo GrepMe > conftest.dir/file { echo "$as_me:$LINENO: tardir=conftest.dir && eval $am__tar_ >conftest.tar" >&5 (tardir=conftest.dir && eval $am__tar_ >conftest.tar) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } rm -rf conftest.dir if test -s conftest.tar; then { echo "$as_me:$LINENO: $am__untar &5 ($am__untar &5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { echo "$as_me:$LINENO: cat conftest.dir/file" >&5 (cat conftest.dir/file) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } grep GrepMe conftest.dir/file >/dev/null 2>&1 && break fi done rm -rf conftest.dir if test ${am_cv_prog_tar_pax+y} then : printf %s "(cached) " >&6 else case e in #( e) am_cv_prog_tar_pax=$_am_tool ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_tar_pax" >&5 printf "%s\n" "$am_cv_prog_tar_pax" >&6; } # Variables for tags utilities; see am/tags.am if test -z "$CTAGS"; then CTAGS=ctags fi if test -z "$ETAGS"; then ETAGS=etags fi if test -z "$CSCOPE"; then CSCOPE=cscope fi # If set to t, that means we are running in a shell under Emacs. # If you have an Emacs named "t", then use the full path. test x"$EMACS" = xt && EMACS= for ac_prog in emacs xemacs 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_EMACS+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$EMACS"; then ac_cv_prog_EMACS="$EMACS" # 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_EMACS="$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 ;; esac fi EMACS=$ac_cv_prog_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 test -n "$EMACS" && break done test -n "$EMACS" || EMACS="no" # Check whether --with-lispdir was given. if test ${with_lispdir+y} then : withval=$with_lispdir; lispdir="$withval" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking where .elc files should go" >&5 printf %s "checking where .elc files should go... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lispdir" >&5 printf "%s\n" "$lispdir" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking where .elc files should go" >&5 printf %s "checking where .elc files should go... " >&6; } if test ${am_cv_lispdir+y} then : printf %s "(cached) " >&6 else case e in #( e) if test $EMACS != "no"; then if test x${lispdir+set} != xset; then # If $EMACS isn't GNU Emacs or XEmacs, this can blow up pretty badly # Some emacsen will start up in interactive mode, requiring C-x C-c to exit, # which is non-obvious for non-emacs users. # Redirecting /dev/null should help a bit; pity we can't detect "broken" # emacsen earlier and avoid running this altogether. { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$EMACS -batch -no-site-file -eval '(while load-path (princ (concat (car load-path) \"\\n\")) (setq load-path (cdr load-path)))' conftest.out"; } >&5 ($EMACS -batch -no-site-file -eval '(while load-path (princ (concat (car load-path) "\n")) (setq load-path (cdr load-path)))' conftest.out) 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } am_cv_lispdir=`sed -n \ -e 's,/$,,' \ -e '/.*\/lib\/x*emacs\/site-lisp$/{s,.*/lib/\(x*emacs/site-lisp\)$,${libdir}/\1,;p;q;}' \ -e '/.*\/share\/x*emacs\/site-lisp$/{s,.*/share/\(x*emacs/site-lisp\),${datarootdir}/\1,;p;q;}' \ conftest.out` rm conftest.out fi fi test -z "$am_cv_lispdir" && am_cv_lispdir='${datadir}/emacs/site-lisp' ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_lispdir" >&5 printf "%s\n" "$am_cv_lispdir" >&6; } lispdir="$am_cv_lispdir" ;; esac fi ac_config_files="$ac_config_files Makefile" #AC_USE_SYSTEM_EXTENSIONS #LT_INIT MAJVERS=`cat $srcdir/majvers` MINVERS=`cat $srcdir/minvers` GIT_TAG=`cat $srcdir/git.tag` RELEASE=`cat $srcdir/release` VERSION=$MAJVERS.$MINVERS # # Host information # 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 case e in #( e) 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 ;; esac 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 # 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 { 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_64*gnu*) use=amd64-gnu;; *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;; loongarch64*linux*) use=loongarch64-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_pic="no"; case $use in *kfreebsd) if ! test -d h ; then mkdir h; fi;; # ln -snf ../$srcdir/h/linux.defs h/$use.defs;; *gnu) if ! test -d h ; then mkdir h; fi;; # ln -snf ../$srcdir/h/linux.defs h/$use.defs;; *linux) if ! test -d h ; then mkdir h; fi; # ln -snf ../$srcdir/h/linux.defs h/$use.defs; case $use in hppa*) # FIXME 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 case e in #( e) INFO_DIR=$prefix/share/info ;; esac fi INFO_DIR=`eval echo $INFO_DIR/` # Check whether --enable-xgcl was given. if test ${enable_xgcl+y} then : enableval=$enable_xgcl; else case e in #( e) enable_xgcl=yes ;; esac fi # Check whether --enable-debug was given. if test ${enable_debug+y} then : enableval=$enable_debug; else case e in #( e) enable_debug=$def_debug ;; esac fi # Check whether --enable-static was given. if test ${enable_static+y} then : enableval=$enable_static; else case e in #( e) enable_static=$def_static ;; esac fi # Check whether --enable-pic was given. if test ${enable_pic+y} then : enableval=$enable_pic; else case e in #( e) enable_pic=$def_pic ;; esac 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 DEPDIR="${am__leading_dot}deps" ac_config_commands="$ac_config_commands depfiles" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} supports the include directive" >&5 printf %s "checking whether ${MAKE-make} supports the include directive... " >&6; } cat > confinc.mk << 'END' am__doit: @echo this is the am__doit target >confinc.out .PHONY: am__doit END am__include="#" am__quote= # BSD make does it like this. echo '.include "confinc.mk" # ignored' > confmf.BSD # Other make implementations (GNU, Solaris 10, AIX) do it like this. echo 'include confinc.mk # ignored' > confmf.GNU _am_result=no for s in GNU BSD; do { echo "$as_me:$LINENO: ${MAKE-make} -f confmf.$s && cat confinc.out" >&5 (${MAKE-make} -f confmf.$s && cat confinc.out) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } case $?:`cat confinc.out 2>/dev/null` in #( '0:this is the am__doit target') : case $s in #( BSD) : am__include='.include' am__quote='"' ;; #( *) : am__include='include' am__quote='' ;; esac ;; #( *) : ;; esac if test "$am__include" != "#"; then _am_result="yes ($s style)" break fi done rm -f confinc.* confmf.* { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${_am_result}" >&5 printf "%s\n" "${_am_result}" >&6; } # Check whether --enable-dependency-tracking was given. if test ${enable_dependency_tracking+y} then : enableval=$enable_dependency_tracking; fi if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' am__nodep='_no' fi if test "x$enable_dependency_tracking" != xno; then AMDEP_TRUE= AMDEP_FALSE='#' else AMDEP_TRUE='#' AMDEP_FALSE= 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) ac_file='' ;; esac 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } ;; esac 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 case e in #( e) { { 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; } ;; esac 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"); if (!f) return 1; 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.o conftest.obj 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 case e in #( e) 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 case e in #( e) 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; } ;; esac fi rm -f conftest.$ac_cv_objext conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) ac_compiler_gnu=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu ;; esac 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 case e in #( e) 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 case e in #( e) 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 case e in #( e) 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 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 case e in #( e) { 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" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 case e in #( e) { 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" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 case e in #( e) { 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" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 ;; esac 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 whether $CC understands -c and -o together" >&5 printf %s "checking whether $CC understands -c and -o together... " >&6; } if test ${am_cv_prog_cc_c_o+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF # Make sure it works both with $CC and with simple cc. # Following AC_PROG_CC_C_O, we do the test twice because some # compilers refuse to overwrite an existing .o file with -o, # though they will create one. am_cv_prog_cc_c_o=yes for am_i in 1 2; do if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } \ && test -f conftest2.$ac_objext; then : OK else am_cv_prog_cc_c_o=no break fi done rm -f core conftest* unset am_i ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 printf "%s\n" "$am_cv_prog_cc_c_o" >&6; } if test "$am_cv_prog_cc_c_o" != yes; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" 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 depcc="$CC" am_compiler_list= { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 printf %s "checking dependency style of $depcc... " >&6; } if test ${am_cv_CC_dependencies_compiler_type+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named 'D' -- because '-MD' means "put the output # in D". rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CC_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi am__universal=false case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with # Solaris 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle '-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # After this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thus: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CC_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CC_dependencies_compiler_type=none fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 printf "%s\n" "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then am__fastdepCC_TRUE= am__fastdepCC_FALSE='#' else am__fastdepCC_TRUE='#' am__fastdepCC_FALSE= fi 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether it is safe to define __EXTENSIONS__" >&5 printf %s "checking whether it is safe to define __EXTENSIONS__... " >&6; } if test ${ac_cv_safe_to_define___extensions__+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ # define __EXTENSIONS__ 1 $ac_includes_default int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_safe_to_define___extensions__=yes else case e in #( e) ac_cv_safe_to_define___extensions__=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_safe_to_define___extensions__" >&5 printf "%s\n" "$ac_cv_safe_to_define___extensions__" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether _XOPEN_SOURCE should be defined" >&5 printf %s "checking whether _XOPEN_SOURCE should be defined... " >&6; } if test ${ac_cv_should_define__xopen_source+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_should_define__xopen_source=no if test $ac_cv_header_wchar_h = yes then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include mbstate_t x; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _XOPEN_SOURCE 500 #include mbstate_t x; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_should_define__xopen_source=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_should_define__xopen_source" >&5 printf "%s\n" "$ac_cv_should_define__xopen_source" >&6; } printf "%s\n" "#define _ALL_SOURCE 1" >>confdefs.h printf "%s\n" "#define _DARWIN_C_SOURCE 1" >>confdefs.h printf "%s\n" "#define _GNU_SOURCE 1" >>confdefs.h printf "%s\n" "#define _HPUX_ALT_XOPEN_SOCKET_API 1" >>confdefs.h printf "%s\n" "#define _NETBSD_SOURCE 1" >>confdefs.h printf "%s\n" "#define _OPENBSD_SOURCE 1" >>confdefs.h printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_BFP_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_DFP_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_IEC_60559_TYPES_EXT__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_LIB_EXT2__ 1" >>confdefs.h printf "%s\n" "#define __STDC_WANT_MATH_SPEC_FUNCS__ 1" >>confdefs.h printf "%s\n" "#define _TANDEM_SOURCE 1" >>confdefs.h if test $ac_cv_header_minix_config_h = yes then : MINIX=yes printf "%s\n" "#define _MINIX 1" >>confdefs.h printf "%s\n" "#define _POSIX_SOURCE 1" >>confdefs.h printf "%s\n" "#define _POSIX_1_SOURCE 2" >>confdefs.h else case e in #( e) MINIX= ;; esac fi if test $ac_cv_safe_to_define___extensions__ = yes then : printf "%s\n" "#define __EXTENSIONS__ 1" >>confdefs.h fi if test $ac_cv_should_define__xopen_source = yes then : printf "%s\n" "#define _XOPEN_SOURCE 500" >>confdefs.h fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; 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_RANLIB+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # 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_RANLIB="${ac_tool_prefix}ranlib" 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 ;; esac fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 printf "%s\n" "$RANLIB" >&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_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; 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_RANLIB+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # 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_RANLIB="ranlib" 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 ;; esac fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 printf "%s\n" "$ac_ct_RANLIB" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_RANLIB" = x; then RANLIB=":" 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 RANLIB=$ac_ct_RANLIB fi else RANLIB="$ac_cv_prog_RANLIB" 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 { 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 case e in #( e) 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 case e in #( e) ac_compiler_gnu=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu ;; esac 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 case e in #( e) 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 case e in #( e) 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 case e in #( e) 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 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 case e in #( e) { 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" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 case e in #( e) { 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" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 ;; esac 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 case e in #( e) { 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" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 ;; esac 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 whether $CC understands -c and -o together" >&5 printf %s "checking whether $CC understands -c and -o together... " >&6; } if test ${am_cv_prog_cc_c_o+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF # Make sure it works both with $CC and with simple cc. # Following AC_PROG_CC_C_O, we do the test twice because some # compilers refuse to overwrite an existing .o file with -o, # though they will create one. am_cv_prog_cc_c_o=yes for am_i in 1 2; do if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } \ && test -f conftest2.$ac_objext; then : OK else am_cv_prog_cc_c_o=no break fi done rm -f core conftest* unset am_i ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 printf "%s\n" "$am_cv_prog_cc_c_o" >&6; } if test "$am_cv_prog_cc_c_o" != yes; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" 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 depcc="$CC" am_compiler_list= { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 printf %s "checking dependency style of $depcc... " >&6; } if test ${am_cv_CC_dependencies_compiler_type+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named 'D' -- because '-MD' means "put the output # in D". rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CC_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi am__universal=false case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with # Solaris 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle '-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # After this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thus: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CC_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CC_dependencies_compiler_type=none fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 printf "%s\n" "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then am__fastdepCC_TRUE= am__fastdepCC_FALSE='#' else am__fastdepCC_TRUE='#' am__fastdepCC_FALSE= 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 { 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 case e in #( e) # 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 case e in #( e) # Broken: fails on valid input. continue ;; esac 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 case e in #( e) # Passes both tests. ac_preproc_ok=: break ;; esac 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 ;; esac 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 case e in #( e) # Broken: fails on valid input. continue ;; esac 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 case e in #( e) # Passes both tests. ac_preproc_ok=: break ;; esac 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 case e in #( e) { { 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; } ;; esac 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 GCL_CC=`basename $CC` if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 \ -std=gnu17 \ -Wall \ -Wno-builtin-requires-header -Wno-empty-body -Wno-self-assign \ -Wno-unused-but-set-variable -D_FILE_OFFSET_BITS=64 -D_TIME_BITS=64 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 case e in #( e) as_fn_error $? "need to probe inline semantics" "$LINENO" 5 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi else case e in #( e) as_fn_error $? "need to probe inline semantics" "$LINENO" 5 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext 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-linux) if ! add_arg_to_cflags -msse2 || ! add_arg_to_cflags -mfpmath=sse ; then add_arg_to_cflags -ffloat-store; fi;; loongarch64-linux) add_arg_to_cflags -mno-relax add_arg_to_cflags -Wa,-mno-relax;; 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="" TOSFLAGS="" 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 case e in #( e) 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 ;; esac 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 GPROF="gprof_objs" # Check whether --enable-gprof was given. if test ${enable_gprof+y} then : enableval=$enable_gprof; if test "$enableval" != "yes" ; then GPROF=""; fi fi if test "$GPROF" != "" ; then case $use in sh4*) GPROF="";; m68k*) GPROF="";; ia64*) GPROF="";; gnuwin95*) GPROF="";; esac OLD_CFLAGS=$CFLAGS if ! add_arg_to_cflags -pg ; then GPROF="" ; fi CFLAGS=$OLD_CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking working gprof" >&5 printf %s "checking working gprof... " >&6; } if test "$GPROF" = "" ; 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; } printf "%s\n" "#define USE_GPROF 1" >>confdefs.h fi fi if test "$GPROF" != ""; then AMM_GPROF_TRUE= AMM_GPROF_FALSE='#' else AMM_GPROF_TRUE='#' AMM_GPROF_FALSE= fi if test "$enable_debug" = "yes" ; then assert_arg_to_cflags -g # for subconfigurations CFLAGS="$CFLAGS -g" else TOSFLAGS="-O2" # "-Os $TFPFLAG" 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*) 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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo $TOSFLAGS | 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'` TOSFLAGS=`echo "$TOSFLAGS" | 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'` TOSFLAGS=`echo $TOSFLAGS | sed 's,-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" 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 case e in #( e) 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 ;; esac 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) 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 case e in #( e) as_fn_error $? "need malloc.h on macosx" "$LINENO" 5 ;; esac 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char sysconf (void); int main (void) { return sysconf (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_c_sysconf=yes else case e in #( e) ac_cv_lib_c_sysconf=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) 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 ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $hz" >&5 printf "%s\n" "$hz" >&6; } fi fi done 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char __gmpz_init (void); 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 case e in #( e) ac_cv_lib_gmp___gmpz_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) 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=`$CC -E 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 ;; esac fi fi fi done if test "$MP_INCLUDE" = "" ; then as_fn_error $? "Cannot use dynamic gmp lib" "$LINENO" 5 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 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 case e in #( e) 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 case e in #( e) as_fn_error $? "Cannot determine mpsize" "$LINENO" 5 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi GMP=1 printf "%s\n" "#define GMP 1" >>confdefs.h { 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 foo.c $CC -o foo -Wl,-Map map foo.c >/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 # # 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 case e in #( e) # 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 case e in #( e) 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 ;; esac 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 case e in #( e) 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 ;; esac 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 ;; 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 case e in #( e) 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 case e in #( e) ac_cv_lib_X11_main=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) { 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; } ;; esac fi fi if test "$X_LIBS" != ""; then AMM_XGCL_TRUE= AMM_XGCL_FALSE='#' else AMM_XGCL_TRUE='#' AMM_XGCL_FALSE= fi # # Dynamic loading # # boot.so requires dlopen { 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char dlopen (void); int main (void) { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes else case e in #( e) ac_cv_lib_dl_dlopen=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) as_fn_error $? "Cannot find dlopen" "$LINENO" 5 ;; esac 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 case e in #( e) { 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char xdr_double (void); 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 case e in #( e) ac_cv_lib_tirpc_xdr_double=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) { 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char xdr_double (void); 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 case e in #( e) ac_cv_lib_gssrpc_xdr_double=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) { 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char xdr_double (void); 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 case e in #( e) ac_cv_lib_rpc_xdr_double=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) { 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char xdr_double (void); 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 case e in #( e) ac_cv_lib_oncrpc_xdr_double=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 ;; esac fi ;; esac fi ;; esac fi ;; esac 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default" then : else case e in #( e) 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 ;; esac fi ;; esac 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 # 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 short" >&5 printf %s "checking size of short... " >&6; } if test ${ac_cv_sizeof_short+y} then : printf %s "(cached) " >&6 else case e in #( e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (short))" "ac_cv_sizeof_short" "$ac_includes_default" then : else case e in #( e) if test "$ac_cv_type_short" = 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 (short) See 'config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_short=0 fi ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_short" >&5 printf "%s\n" "$ac_cv_sizeof_short" >&6; } printf "%s\n" "#define SIZEOF_SHORT $ac_cv_sizeof_short" >>confdefs.h # 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 int" >&5 printf %s "checking size of int... " >&6; } if test ${ac_cv_sizeof_int+y} then : printf %s "(cached) " >&6 else case e in #( e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int))" "ac_cv_sizeof_int" "$ac_includes_default" then : else case e in #( e) if test "$ac_cv_type_int" = 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 (int) See 'config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_int=0 fi ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_int" >&5 printf "%s\n" "$ac_cv_sizeof_int" >&6; } printf "%s\n" "#define SIZEOF_INT $ac_cv_sizeof_int" >>confdefs.h # 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 char" >&5 printf %s "checking size of char... " >&6; } if test ${ac_cv_sizeof_char+y} then : printf %s "(cached) " >&6 else case e in #( e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (char))" "ac_cv_sizeof_char" "$ac_includes_default" then : else case e in #( e) if test "$ac_cv_type_char" = 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 (char) See 'config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_char=0 fi ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_char" >&5 printf "%s\n" "$ac_cv_sizeof_char" >&6; } printf "%s\n" "#define SIZEOF_CHAR $ac_cv_sizeof_char" >>confdefs.h # 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 case e in #( e) enable_fastimmfix=64 ;; esac 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 #### 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 case e in #( e) 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 case e in #( e) { 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 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) { 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 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi # pagewidth case $use in mips*) min_pagewidth=14;; *) min_pagewidth=12;; esac { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for hugepagewidth" >&5 printf %s "checking for hugepagewidth... " >&6; } j="" if test -e /proc/meminfo ; then j=`awk '/^Hugepagesize:/ {if ($3!="kB") next;j=1;for (i=0;i<20 && j!=$2;i++) j=j*2;if (j==$2) printf("%d\n",i+10)}' /proc/meminfo` fi if test "$j" != "" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $j" >&5 printf "%s\n" "$j" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC options needed to detect all undeclared functions" >&5 printf %s "checking for $CC options needed to detect all undeclared functions... " >&6; } if test ${ac_cv_c_undeclared_builtin_options+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_save_CFLAGS=$CFLAGS ac_cv_c_undeclared_builtin_options='cannot detect' for ac_arg in '' -fno-builtin; do CFLAGS="$ac_save_CFLAGS $ac_arg" # This test program should *not* compile successfully. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { (void) strchr; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else case e in #( e) # This test program should compile successfully. # No library function is consistently available on # freestanding implementations, so test against a dummy # declaration. Include always-available headers on the # off chance that they somehow elicit warnings. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include extern void ac_decl (int, char *); int main (void) { (void) ac_decl (0, (char *) 0); (void) ac_decl; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : if test x"$ac_arg" = x then : ac_cv_c_undeclared_builtin_options='none needed' else case e in #( e) ac_cv_c_undeclared_builtin_options=$ac_arg ;; esac fi break fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done CFLAGS=$ac_save_CFLAGS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5 printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; } case $ac_cv_c_undeclared_builtin_options in #( 'cannot detect') : { { 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 make $CC report undeclared builtins See 'config.log' for more details" "$LINENO" 5; } ;; #( 'none needed') : ac_c_undeclared_builtin_options='' ;; #( *) : ac_c_undeclared_builtin_options=$ac_cv_c_undeclared_builtin_options ;; esac 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 : ac_fn_c_check_func "$LINENO" "madvise" "ac_cv_func_madvise" if test "x$ac_cv_func_madvise" = xyes then : ac_fn_check_decl "$LINENO" "MADV_HUGEPAGE" "ac_cv_have_decl_MADV_HUGEPAGE" "#include " "$ac_c_undeclared_builtin_options" "CFLAGS" if test "x$ac_cv_have_decl_MADV_HUGEPAGE" = xyes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking madvise works" >&5 printf %s "checking madvise works... " >&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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { unsigned long k=(1UL<<$j); void *p=malloc(2*k); int i; p=(void *)((((unsigned long)p)+k-1)&~(k-1)); i=madvise(p,k,MADV_HUGEPAGE); return i; ; 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_MADVISE_HUGEPAGE 1" >>confdefs.h if test $min_pagewidth -lt $j ; then min_pagewidth=$j ; fi else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi fi fi fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi # Check whether --enable-min_pagewidth was given. if test ${enable_min_pagewidth+y} then : enableval=$enable_min_pagewidth; min_pagewidth=$enableval fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pagewidth" >&5 printf %s "checking for pagewidth... " >&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 case e in #( e) 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 case e in #( e) PAGEWIDTH=0 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "$srcdir/h/enum.h" #define OBJ_ALIGN #include "$srcdir/h/type.h" #include "$srcdir/h/lu.h" #include "$srcdir/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 case e in #( e) as_fn_error $? "Cannot find object alignent" "$LINENO" 5 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) as_fn_error $? "Need alignment attributes" "$LINENO" 5 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) no_return= ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "$srcdir/h/enum.h" #include "$srcdir/h/type.h" #include "$srcdir/h/lu.h" #include "$srcdir/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 case e in #( e) as_fn_error $? "Cannot find sizeof struct contblock" "$LINENO" 5 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); 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 case e in #( e) cstack_direction=0 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include int main(int argc,char **argv,char **envp) { void *b,*c; FILE *fp = fopen("conftest1","w"); long n; 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 case e in #( e) cstack_alignment=0 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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; } if test $cstack_direction -eq 1 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking CSTACK_TOP" >&5 printf %s "checking CSTACK_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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"),*f=fopen("/proc/self/maps","r"); unsigned long i,j; char b[4096]; i=(unsigned long)alloca(sizeof(void *)); for (j=0;j&5 printf "%s\n" "$cstack_top" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking relocated CSTACK_TOP" >&5 printf %s "checking relocated CSTACK_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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"),*f=fopen("/proc/self/maps","r"); unsigned long i,j; char b[4096],*stack_map_base; #include "$srcdir/h/cstack.h" i=(unsigned long)alloca(sizeof(void *)); for (j=0;j&5 printf "%s\n" "$cstack_top" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking CSTACK_TOP" >&5 printf %s "checking CSTACK_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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); unsigned long i,j; j=getpagesize(); i=(unsigned long)alloca(sizeof(void *)); 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_top=`cat conftest1` else case e in #( e) cstack_top=0 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_top" >&5 printf "%s\n" "$cstack_top" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking relocated CSTACK_TOP" >&5 printf %s "checking relocated CSTACK_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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); unsigned long i,j; char *stack_map_base; #include "$srcdir/h/cstack.h" j=getpagesize(); i=(unsigned long)alloca(sizeof(void *)); 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_top=`cat conftest1` else case e in #( e) cstack_top=0 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_top" >&5 printf "%s\n" "$cstack_top" >&6; } fi { 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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); long i,j; char *stack_map_base; #include "$srcdir/h/cstack.h" j=getpagesize(); i=$cstack_top; 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 case e in #( e) cstack_bits=0 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { 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 case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include #include #include int main(int argc,char **argv,char **envp) { char *stack_map_base; #include "$srcdir/h/cstack.h" return (long)$cstack_top<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 else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } neg_cstack_address=0 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) enable_fastimmfix=64 ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking finding default linker script" >&5 printf %s "checking finding default linker script... " >&6; } if ! test -d unixport ; then mkdir unixport ; fi 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:|tr '-' '_'`; 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}: checking output_mach" >&5 printf %s "checking output_mach... " >&6; } output_mach=`cat gcl.script |grep OUTPUT_ARCH|head -n 1|sed 's,.*(\(.*\)).*,\1:,1'|cut -f2 -d:|tr '-' '_'|tr -d '.'`; if test "$output_mach" = "common" ; then #FIXME output_mach="" fi defaulted="" if test "$output_mach" = "" ; then if test "$output_arch" = "i386" ; then output_mach="i386_i386"; defaulted="(defaulted)" fi fi if test "$output_mach" != "" ; then printf "%s\n" "#define OUTPUT_MACH bfd_mach_${output_mach}" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $defaulted bfd_mach_${output_mach}" >&5 printf "%s\n" "$defaulted bfd_mach_${output_mach}" >&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 >/dev/null 2>&1 && ./foo >/dev/null 2>&1 ) >/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 # Workaround for false island of acceptability on riscv64, 20240716 if test `$AWK 'END {print n-m}' m=$min n=$max &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 # Need to get over default cstack and related maps between 0x1000000 and 0x2000000 if test "$use" == "386-gnu" || test "$use" == "amd64-gnu" ; then if test "$use" == "386-gnu" ; then q=24; else q=23; fi if test $min -lt $q && test $q -lt $max && test $q -lt 30; then min=$q { printf "%s\n" "$as_me:${as_lineno-$LINENO}: min log text start increased to $min over c stack address" >&5 printf "%s\n" "$as_me: min log text start increased to $min over 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 0x$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 0x$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" != "-1" ; then cat gcl.script.def | $AWK '/SEGMENT_START/ {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 # AC_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object]) #fi printf "%s\n" "#define CSSIZE $enable_cssize" >>confdefs.h 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 case e in #( e) 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_top; for (i=j=k;j && i>=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 case e in #( e) mem_top="0x0" ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) mem_range="0x0" ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $mem_range" >&5 printf "%s\n" "$mem_range" >&6; } 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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("config.log",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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi fi done # 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" "rename" "ac_cv_func_rename" if test "x$ac_cv_func_rename" = xyes then : printf "%s\n" "#define HAVE_RENAME 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 case e in #( e) printf "%s\n" "#define NO_UNAME 1" >>confdefs.h ;; esac fi for ac_func in readlinkat do : ac_fn_c_check_func "$LINENO" "readlinkat" "ac_cv_func_readlinkat" if test "x$ac_cv_func_readlinkat" = xyes then : printf "%s\n" "#define HAVE_READLINKAT 1" >>confdefs.h else case e in #( e) as_fn_error $? "must have readlinkat" "$LINENO" 5 ;; esac fi done 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 if test "$use" != "mingw" ; then { 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char sin (void); int main (void) { return sin (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_m_sin=yes else case e in #( e) ac_cv_lib_m_sin=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) true ;; esac fi 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 case e in #( e) 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 case e in #( e) ac_cv_lib_mingwex_main=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) true ;; esac fi # # 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 case e in #( e) 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 case e in #( e) { 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 case e in #( e) 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) 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 case e in #( e) { 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 case e in #( e) 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 case e in #( e) as_fn_error $? "no" "$LINENO" 5 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) tcl_checkSocket=1 ;; esac 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 case e in #( e) 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 case e in #( e) ac_cv_lib_socket_main=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) tcl_checkBoth=1 ;; esac 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 case e in #( e) TLIBS=$tk_oldLibs ;; esac fi fi ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname" if test "x$ac_cv_func_gethostbyname" = xyes then : else case e in #( e) { 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 case e in #( e) 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 case e in #( e) ac_cv_lib_nsl_main=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 ;; esac 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char rl_initialize (void); 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 case e in #( e) ac_cv_lib_readline_rl_initialize=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char el_getc (void); 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 case e in #( e) ac_cv_lib_readline_el_getc=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char rl_completion_matches (void); 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 case e in #( e) ac_cv_lib_readline_rl_completion_matches=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) { 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 case e in #( e) { 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 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 case e in #( e) { 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 case e in #( e) { 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 ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac 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 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac 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 case e in #( e) printf "%s\n" "#define NO_PROFILE 1" >>confdefs.h ;; esac 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 case e in #( e) no_setenv=1 ;; esac 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 { 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac 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 case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } ;; esac 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char init_disassemble_info (void); 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 case e in #( e) ac_cv_lib_opcodes_init_disassemble_info=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 case e in #( e) 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. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char dlopen (void); int main (void) { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes else case e in #( e) ac_cv_lib_dl_dlopen=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac 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 for ac_func in print_insn_i386 do : ac_fn_c_check_func "$LINENO" "print_insn_i386" "ac_cv_func_print_insn_i386" if test "x$ac_cv_func_print_insn_i386" = xyes then : printf "%s\n" "#define HAVE_PRINT_INSN_I386 1" >>confdefs.h LIBS="$MLIBS -ldl" fi done fi fi done # 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 fi # Check whether --enable-tclconfig was given. if test ${enable_tclconfig+y} then : enableval=$enable_tclconfig; TCL_CONFIG_PREFIX=$enableval 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 case e in #( e) 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 ;; esac 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 TCL_VERSION=`echo 'puts [set tcl_version]' | ${TCLSH}` fi if test -e /usr/lib/tcl$TCL_VERSION/tclConfig.sh ; then TCL_CONFIG_PREFIX=/usr/lib/tcl$TCL_VERSION fi fi if test -e ${TCL_CONFIG_PREFIX}/tclConfig.sh ; then . ${TCL_CONFIG_PREFIX}/tclConfig.sh ; fi if test -d "${TK_CONFIG_PREFIX}" ; then true ; else if test -e ${TCL_CONFIG_PREFIX}/tkConfig.sh ; then TK_CONFIG_PREFIX=${TCL_CONFIG_PREFIX} else if test -e `echo $TCL_CONFIG_PREFIX | sed 's,tcl,tk,g'`/tkConfig.sh ; then TK_CONFIG_PREFIX=`echo $TCL_CONFIG_PREFIX | sed 's,tcl,tk,g'` fi fi fi if test -e ${TK_CONFIG_PREFIX}/tkConfig.sh ; then . ${TK_CONFIG_PREFIX}/tkConfig.sh ; fi if test -d ${TCL_CONFIG_PREFIX}/tcl${TCL_VERSION} ; then TCL_LIBRARY=${TCL_CONFIG_PREFIX}/tcl${TCL_VERSION} else if test -d ${TCL_CONFIG_PREFIX}/../tcl${TCL_VERSION} ; then TCL_LIBRARY=${TCL_CONFIG_PREFIX}/../tcl${TCL_VERSION} fi 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 -e ${TCL_CONFIG_PREFIX}/../include/tcl.h ; then TCL_INCLUDE=-I${TCL_CONFIG_PREFIX}/../include else if test -e /usr/include/tcl${TCL_VERSION}/tcl.h ; then TCL_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi if test -e ${TK_CONFIG_PREFIX}/../include/tk.h ; then TK_INCLUDE=-I${TK_CONFIG_PREFIX}/../include else if test -e /usr/include/tcl${TCL_VERSION}/tk.h ; then TK_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi fi if test "$TK_CONFIG_PREFIX" != ""; then AMM_TK_TRUE= AMM_TK_FALSE='#' else AMM_TK_TRUE='#' AMM_TK_FALSE= 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; } ac_config_files="$ac_config_files gcl-tk/gcltksrv" else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi ac_config_files="$ac_config_files bin/gcl" 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 case e in #( e) printf "%s\n" "#define size_t unsigned int" >>confdefs.h ;; esac 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 case e in #( e) 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 case e in #( e) ac_cv_working_alloca_h=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext ;; esac 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 case e in #( e) ac_cv_func_alloca_works=$ac_cv_working_alloca_h if test "$ac_cv_func_alloca_works" != yes then : 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 fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi ;; esac 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; } 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 case e in #( e) if test "$cross_compiling" = yes then : ac_cv_c_stack_direction=0 else case e in #( e) 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 case e in #( e) ac_cv_c_stack_direction=-1 ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi ;; esac 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'`" LDFLAGS="`echo $GPL_FLAG $LDFLAGS`" #AM_LDFLAGS = $LDFLAGS BASE_LDFLAGS="$LDFLAGS" LDFLAGS="" LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $LIBS $TLIBS" #AM_LIBS = $LIBS CFLAGS="$CFLAGS $GP_FLAG" FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS" # Work around bug with gcc on ppc -- CM NIFLAGS="$CFLAGS $CPPFLAGS $TONIFLAGS -I o" CFLAGS="$CFLAGS $CPPFLAGS $TO3FLAGS -I o" BASE_CFLAGS="$CFLAGS" CFLAGS="" BASE_CPPFLAGS="-I h -I /usr/include/tirpc $CPPFLAGS" CPPFLAGS= O3FLAGS=$TOSFLAGS O2FLAGS=$TO2FLAGS LI_EXTVERS=`echo $MINVERS | cut -f2 -d.` LI_MINVERS=`echo $MINVERS | cut -f1 -d.` LI_MAJVERS=$MAJVERS LI_GITTAG="$GIT_TAG" LI_RELEASE="$RELEASE" LI_CC="\"$GCL_CC -c `echo " $FINAL_CFLAGS" | sed 's,-pg\b,,g'`\"" LI_DFP="\"$GPL_FLAG\"" LI_LD="\"$GCL_CC $BASE_LDFLAGS -o\"" LI_LD_LIBS="\"$LIBS\"" LI_OPT_THREE="\"$O3FLAGS\"" LI_OPT_TWO="\"$O2FLAGS\"" LI_INIT_LSP="\"init_raw.lsp\"" ac_config_files="$ac_config_files unixport/init_raw.lsp" if test "$use" != "" ; then 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 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5 printf %s "checking that generated files are newer than configure... " >&6; } if test -n "$am_sleep_pid"; then # Hide warnings about reused PIDs. wait $am_sleep_pid 2>/dev/null fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: done" >&5 printf "%s\n" "done" >&6; } case $enable_silent_rules in # ((( yes) AM_DEFAULT_VERBOSITY=0;; no) AM_DEFAULT_VERBOSITY=1;; esac if test $am_cv_make_support_nested_variables = yes; then AM_V='$(V)' AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' else AM_V=$AM_DEFAULT_VERBOSITY AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY fi if test -n "$EXEEXT"; then am__EXEEXT_TRUE= am__EXEEXT_FALSE='#' else am__EXEEXT_TRUE='#' am__EXEEXT_FALSE= fi if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then as_fn_error $? "conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${AMM_GPROF_TRUE}" && test -z "${AMM_GPROF_FALSE}"; then as_fn_error $? "conditional \"AMM_GPROF\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${AMM_XGCL_TRUE}" && test -z "${AMM_XGCL_FALSE}"; then as_fn_error $? "conditional \"AMM_XGCL\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${AMM_TK_TRUE}" && test -z "${AMM_TK_FALSE}"; then as_fn_error $? "conditional \"AMM_TK\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi : "${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 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 case e in #( e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; 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 case e in #( e) as_fn_append () { eval $1=\$$1\$2 } ;; esac 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 case e in #( e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } ;; esac 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_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" as_tr_sh="eval sed '$as_sed_sh'" # deprecated 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 gcl $as_me 2.7.1, which was generated by GNU Autoconf 2.72. 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" config_commands="$ac_config_commands" _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 Configuration commands: $config_commands 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="\\ gcl config.status 2.7.1 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" Copyright (C) 2023 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' INSTALL='$INSTALL' MKDIR_P='$MKDIR_P' AWK='$AWK' 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 # # INIT-COMMANDS # AMDEP_TRUE="$AMDEP_TRUE" MAKE="${MAKE-make}" _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" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "gcl-tk/gcltksrv") CONFIG_FILES="$CONFIG_FILES gcl-tk/gcltksrv" ;; "bin/gcl") CONFIG_FILES="$CONFIG_FILES bin/gcl" ;; "unixport/init_raw.lsp") CONFIG_FILES="$CONFIG_FILES unixport/init_raw.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 test ${CONFIG_COMMANDS+y} || CONFIG_COMMANDS=$config_commands 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 :C $CONFIG_COMMANDS" 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 # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac ac_MKDIR_P=$MKDIR_P case $MKDIR_P in [\\/$]* | ?:[\\/]* ) ;; */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; esac _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 s&@INSTALL@&$ac_INSTALL&;t t s&@MKDIR_P@&$ac_MKDIR_P&;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 # Compute "$ac_file"'s index in $config_headers. _am_arg="$ac_file" _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || $as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$_am_arg" : 'X\(//\)[^/]' \| \ X"$_am_arg" : 'X\(//\)$' \| \ X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$_am_arg" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'`/stamp-h$_am_stamp_count ;; :C) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 printf "%s\n" "$as_me: executing $ac_file commands" >&6;} ;; esac case $ac_file$ac_mode in "depfiles":C) test x"$AMDEP_TRUE" != x"" || { # Older Autoconf quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. # TODO: see whether this extra hack can be removed once we start # requiring Autoconf 2.70 or later. case $CONFIG_FILES in #( *\'*) : eval set x "$CONFIG_FILES" ;; #( *) : set x $CONFIG_FILES ;; #( *) : ;; esac shift # Used to flag and report bootstrapping failures. am_rc=0 for am_mf do # Strip MF so we end up with the name of the file. am_mf=`printf "%s\n" "$am_mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile which includes # dependency-tracking related rules and includes. # Grep'ing the whole file directly is not great: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \ || continue am_dirpart=`$as_dirname -- "$am_mf" || $as_expr X"$am_mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$am_mf" : 'X\(//\)[^/]' \| \ X"$am_mf" : 'X\(//\)$' \| \ X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$am_mf" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` am_filepart=`$as_basename -- "$am_mf" || $as_expr X/"$am_mf" : '.*/\([^/][^/]*\)/*$' \| \ X"$am_mf" : 'X\(//\)$' \| \ X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$am_mf" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` { echo "$as_me:$LINENO: cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles" >&5 (cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } || am_rc=$? done if test $am_rc -ne 0; 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 $? "Something went wrong bootstrapping makefile fragments for automatic dependency tracking. If GNU make was not used, consider re-running the configure script with MAKE=\"gmake\" (or whatever is necessary). You can also try re-running configure with the '--disable-dependency-tracking' option to at least be able to build the package (albeit without support for automatic dependency tracking). See 'config.log' for more details" "$LINENO" 5; } fi { am_dirpart=; unset am_dirpart;} { am_filepart=; unset am_filepart;} { am_mf=; unset am_mf;} { am_rc=; unset am_rc;} rm -f conftest-deps.mk } ;; 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 cmp $srcdir/h/$use.h h/config.h || cp $srcdir/h/$use.h h/config.h echo configuration for $use done 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 exit 1 fi gcl-2.7.1/PaxHeaders/xbin0000644000000000000000000000013214776006046012241 xustar0030 mtime=1744309286.194034556 30 atime=1744351538.814879383 30 ctime=1744351535.718907102 gcl-2.7.1/xbin/0000755000175000017500000000000014776006046011714 5ustar00cammcammgcl-2.7.1/xbin/PaxHeaders/ar_merge0000644000000000000000000000013214776006046014022 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.266034904 30 ctime=1744351535.718907102 gcl-2.7.1/xbin/ar_merge0000755000175000017500000000054714776006046013431 0ustar00cammcamm#!/bin/bash #set -x FLAGS=$1 shift ARCHIVE=$1 shift TMPDIR=$(mktemp -d) while [ $# -gt 0 ] ; do case $(basename $1) in *.o) cp $1 $TMPDIR;; *.go) cp $1 $TMPDIR/$(echo $(basename $1)|sed 's,\.go,.o,g');; *.a) ar x $1 --output $TMPDIR;; recompile);; *) echo Bad arg $1 ; exit 1 ;; esac shift done ar $FLAGS $ARCHIVE $TMPDIR/*.o rm -rf $TMPDIR gcl-2.7.1/xbin/PaxHeaders/mktmp0000644000000000000000000000013214776006046013371 xustar0030 mtime=1744309286.194034556 30 atime=1744309286.266034904 30 ctime=1744351535.718907102 gcl-2.7.1/xbin/mktmp0000755000175000017500000000012414776006046012767 0ustar00cammcamm#!/bin/bash mktemp -p $(dirname $1) $(echo $(basename $1 | sed 's,\..*,,g'))XXXXXX gcl-2.7.1/PaxHeaders/COPYING0000644000000000000000000000013214776006046012411 xustar0030 mtime=1744309286.146034324 30 atime=1744309286.270034924 30 ctime=1744351535.442909577 gcl-2.7.1/COPYING0000755000175000017500000006126114776006046012020 0ustar00cammcamm 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.7.1/PaxHeaders/NEWS0000644000000000000000000000013214776006046012055 xustar0030 mtime=1744309286.146034324 30 atime=1744340055.632933832 30 ctime=1744351535.442909577 gcl-2.7.1/NEWS0000644000175000017500000000000014776006046011441 0ustar00cammcamm