From: Camm Maguire Date: Sun, 13 Nov 2022 12:55:14 +0000 (+0000) Subject: X-Git-Tag: archive/raspbian/2.7.1-4+rpi1~2^2^2~100 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=f51226faad200025679c3236543108285c6385b5;p=gcl27.git TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it. gcl (2.6.12-38) unstable; urgency=medium * Version_2_6_13pre50 Gbp-Pq: Name pathnames1.1 --- diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 305954a..6f84d2c 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -80,6 +80,10 @@ Results: ~A~%" expected-number form n results)))) "Like EQUALP, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) +(defun equalpt-or-report (x y) + "Like EQUALPT, but return either T or a list of the arguments." + (or (equalpt x y) (list x y))) + (defun =t (x &rest args) "Like =, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) @@ -223,6 +227,13 @@ Results: ~A~%" expected-number form n results)))) P x p1 x TYPE p2) t))))) +(defun check-predicate (predicate &optional guard (universe *universe*)) + "Return all elements of UNIVERSE for which the guard (if present) is false + and for which PREDICATE is false." + (remove-if #'(lambda (e) (or (and guard (funcall guard e)) + (funcall predicate e))) + universe)) + (declaim (special *catch-error-type*)) (defun catch-continue-debugger-hook (condition dbh) @@ -296,7 +307,167 @@ the condition to go uncaught if it cannot be classified." (defmacro classify-error (form) `(classify-error** ',form)) +(defun sequencep (x) (typep x 'sequence)) + ;;; +(defun typef (type) #'(lambda (x) (typep x type))) + +(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) + `(handler-bind + ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + (proclaim '(optimize (safety 3))) + (handler-case + (apply #'values + nil + (multiple-value-list + ,(cond + (inline form) + (regression-test::*compile-tests* + `(funcall (compile nil '(lambda () + (declare (optimize (safety ,safety))) + ,form)))) + (t `(eval ',form))))) + (,error-name (c) + (cond + ,@(case error-name + (type-error + `(((typep (type-error-datum c) + (type-error-expected-type c)) + (values + nil + (list (list 'typep (list 'quote + (type-error-datum c)) + (list 'quote + (type-error-expected-type c))) + "==> true"))))) + ((undefined-function unbound-variable) + (and name-p + `(((not (eq (cell-error-name c) ',name)) + (values + nil + (list 'cell-error-name "==>" + (cell-error-name c))))))) + ((stream-error end-of-file reader-error) + `(((not (streamp (stream-error-stream c))) + (values + nil + (list 'stream-error-stream "==>" + (stream-error-stream c)))))) + (file-error + `(((not (pathnamep (pathname (file-error-pathname c)))) + (values + nil + (list 'file-error-pathname "==>" + (file-error-pathname c)))))) + (t nil)) + (t (printable-p c))))))) + +(defmacro signals-error-always (form error-name) + `(values + (signals-error ,form ,error-name) + (signals-error ,form ,error-name :safety 0))) + +(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) + (let ((lambda-form + `(lambda (,var) + (declare (optimize (safety ,safety))) + ,form))) + `(let ((,var ,datum-form)) + (declare (optimize safety)) + (handler-bind + ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + ; (proclaim '(optimize (safety 3))) + (handler-case + (apply #'values + nil + (multiple-value-list + (funcall + ,(cond + (inline `(function ,lambda-form)) + (regression-test::*compile-tests* + `(compile nil ',lambda-form)) + (t `(eval ',lambda-form))) + ,var))) + (type-error + (c) + (let ((datum (type-error-datum c)) + (expected-type (type-error-expected-type c))) + (cond + ((not (eql ,var datum)) + (list :datum-mismatch ,var datum)) + ((typep datum expected-type) + (list :is-typep datum expected-type)) + (t (printable-p c)))))))))) + +(declaim (special *mini-universe*)) + +(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) + "Check that for all elements in some set, either guard-fn is true or + pred-fn signals a type error." + (let (val) + (loop for e in universe + unless (or (funcall guard-fn e) + (equal + (setf val (multiple-value-list + (signals-type-error x e (funcall pred-fn x) :inline t))) + '(t))) + collect (list e val)))) + +(defmacro check-type-error (&body args) + `(locally (declare (optimize safety)) (check-type-error* ,@args))) + +(defun printable-p (obj) + "Returns T iff obj can be printed to a string." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-escape* nil)) + (declare (optimize safety)) + (handler-case (and (stringp (write-to-string obj)) t) + (condition (c) (declare (ignore c)) nil))))) + +(defun make-special-string (string &key fill adjust displace base) + (let* ((len (length string)) + (len2 (if fill (+ len 4) len)) + (etype (if base 'base-char 'character))) + (if displace + (let ((s0 (make-array (+ len2 5) + :initial-contents + (concatenate 'string + (make-string 2 :initial-element #\X) + string + (make-string (if fill 7 3) + :initial-element #\Y)) + :element-type etype))) + (make-array len2 :element-type etype + :adjustable adjust + :fill-pointer (if fill len nil) + :displaced-to s0 + :displaced-index-offset 2)) + (make-array len2 :element-type etype + :initial-contents + (if fill (concatenate 'string string "ZZZZ") string) + :fill-pointer (if fill len nil) + :adjustable adjust)))) + +(defmacro do-special-strings ((var string-form &optional ret-form) &body forms) + (let ((string (gensym)) + (fill (gensym "FILL")) + (adjust (gensym "ADJUST")) + (base (gensym "BASE")) + (displace (gensym "DISPLACE"))) + `(let ((,string ,string-form)) + (dolist (,fill '(nil t) ,ret-form) + (dolist (,adjust '(nil t)) + (dolist (,base '(nil t)) + (dolist (,displace '(nil t)) + (let ((,var (make-special-string + ,string + :fill ,fill :adjust ,adjust + :base ,base :displace ,displace))) + ,@forms)))))))) + ;;; A scaffold is a structure that is used to remember the object ;;; identities of the cons cells in a (noncircular) data structure. ;;; This lets us check if the data structure has been changed by @@ -1307,6 +1478,13 @@ the condition to go uncaught if it cannot be classified." (unuse-package package using-package))) (delete-package package)))) +(defun delete-all-versions (pathspec) + "Replace the versions field of the pathname specified by pathspec with + :wild, and delete all the files this refers to." + (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec))) + (truenames (directory wild-pathname))) + (mapc #'delete-file truenames))) + (defconstant +fail-count-limit+ 20) (defmacro test-with-package-iterator (package-list-expr &rest symbol-types) @@ -1455,3 +1633,5 @@ the condition to go uncaught if it cannot be classified." (list n1) (random-partition n3 (- p 1 r)))))))))) +(defmacro expand-in-current-env (macro-form &environment env) + (macroexpand macro-form env)) diff --git a/ansi-tests/broadcast-stream-streams.lsp b/ansi-tests/broadcast-stream-streams.lsp new file mode 100644 index 0000000..f0aef32 --- /dev/null +++ b/ansi-tests/broadcast-stream-streams.lsp @@ -0,0 +1,30 @@ +;-*- 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) + + + + + diff --git a/ansi-tests/clear-input.lsp b/ansi-tests/clear-input.lsp new file mode 100644 index 0000000..73c12f8 --- /dev/null +++ b/ansi-tests/clear-input.lsp @@ -0,0 +1,64 @@ +;-*- 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) diff --git a/ansi-tests/clear-output.lsp b/ansi-tests/clear-output.lsp new file mode 100644 index 0000000..03f0ae8 --- /dev/null +++ b/ansi-tests/clear-output.lsp @@ -0,0 +1,53 @@ +;-*- 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) diff --git a/ansi-tests/compile-file-test-file.lsp b/ansi-tests/compile-file-test-file.lsp new file mode 100644 index 0000000..ec47795 --- /dev/null +++ b/ansi-tests/compile-file-test-file.lsp @@ -0,0 +1,3 @@ +(in-package "CL-TEST") + +(defun compile-file-test-fun.1 () nil) diff --git a/ansi-tests/concatenated-stream-streams.lsp b/ansi-tests/concatenated-stream-streams.lsp new file mode 100644 index 0000000..0cc7e29 --- /dev/null +++ b/ansi-tests/concatenated-stream-streams.lsp @@ -0,0 +1,67 @@ +;-*- 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) + + diff --git a/ansi-tests/delete-file.lsp b/ansi-tests/delete-file.lsp new file mode 100644 index 0000000..99a958e --- /dev/null +++ b/ansi-tests/delete-file.lsp @@ -0,0 +1,95 @@ +;-*- 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) +|# + diff --git a/ansi-tests/directory-namestring.lsp b/ansi-tests/directory-namestring.lsp new file mode 100644 index 0000000..a330001 --- /dev/null +++ b/ansi-tests/directory-namestring.lsp @@ -0,0 +1,50 @@ +;-*- 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) diff --git a/ansi-tests/directory.lsp b/ansi-tests/directory.lsp new file mode 100644 index 0000000..2cc7085 --- /dev/null +++ b/ansi-tests/directory.lsp @@ -0,0 +1,71 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Jan 1 12:00:18 2004 +;;;; Contains: Tests of DIRECTORY + +(in-package :cl-test) + +(deftest directory.1 + (directory "nonexistent") + nil) + +(deftest directory.2 + (directory #p"nonexistent") + nil) + +(deftest directory.3 + (directory "nonexistent" :allow-other-keys nil) + nil) + +(deftest directory.4 + (directory "nonexistent" :allow-other-keys t :foo 'bar) + nil) + +(deftest directory.5 + (directory "nonexistent" :foo 0 :allow-other-keys t) + nil) + +(deftest directory.6 + (let* ((pattern-pathname (make-pathname :name :wild :type :wild + :defaults *default-pathname-defaults*)) + (pathnames (directory pattern-pathname))) + (values + (remove-if #'pathnamep pathnames) + (loop for pn in pathnames + unless (equal pn (truename pn)) + collect pn) +;; (loop for pn in pathnames +;; unless (pathname-match-p pn pattern-pathname) +;; collect pn)) + )) + nil nil ;; nil + ) + +(deftest directory.7 + (let* ((pattern-pathname (make-pathname :name :wild :type :wild + :defaults *default-pathname-defaults*)) + (pathnames (directory pattern-pathname))) + (loop for pn in pathnames + unless (equal pn (probe-file pn)) + collect pn)) + nil) + +(deftest directory.8 + (let* ((pathname-pattern "CLTEST:*.*") + (len (length (directory pathname-pattern)))) + (if (< len 300) len nil)) + nil) + +;;; Specialized string tests + +(deftest directory.9 + (do-special-strings + (s "nonexistent" nil) + (assert (null (directory s)))) + nil) + +;;; Error tests + +(deftest directory.error.1 + (signals-error (directory) program-error) + t) diff --git a/ansi-tests/echo-stream-input-stream.lsp b/ansi-tests/echo-stream-input-stream.lsp new file mode 100644 index 0000000..d654cc1 --- /dev/null +++ b/ansi-tests/echo-stream-input-stream.lsp @@ -0,0 +1,27 @@ +;-*- 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) + diff --git a/ansi-tests/echo-stream-output-stream.lsp b/ansi-tests/echo-stream-output-stream.lsp new file mode 100644 index 0000000..769bfc3 --- /dev/null +++ b/ansi-tests/echo-stream-output-stream.lsp @@ -0,0 +1,26 @@ +;-*- 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) diff --git a/ansi-tests/enough-namestring.lsp b/ansi-tests/enough-namestring.lsp new file mode 100644 index 0000000..33825b8 --- /dev/null +++ b/ansi-tests/enough-namestring.lsp @@ -0,0 +1,84 @@ +;-*- 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) diff --git a/ansi-tests/ensure-directories-exist.lsp b/ansi-tests/ensure-directories-exist.lsp new file mode 100644 index 0000000..af79efa --- /dev/null +++ b/ansi-tests/ensure-directories-exist.lsp @@ -0,0 +1,166 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 5 20:53:03 2004 +;;;; Contains: Tests of ENSURE-DIRECTORIES-EXIST + +(in-package :cl-test) + +(deftest ensure-directories-exist.1 + (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list (ensure-directories-exist pn)))))) + (values + (length results) + (equalt (truename pn) (truename (first results))) + (second results) + verbosity)) + 2 t nil "") + +(deftest ensure-directories-exist.2 + (with-open-file + (s "ensure-directories-exist.lsp" :direction :input) + (let* ((results (multiple-value-list (ensure-directories-exist s)))) + (values + (length results) + (equalt (truename (first results)) (truename s)) + (second results)))) + 2 t nil) + +(deftest ensure-directories-exist.3 + (let ((s (open "ensure-directories-exist.lsp" :direction :input))) + (close s) + (let* ((results (multiple-value-list (ensure-directories-exist s)))) + (values + (length results) + (equalt (truename (first results)) (truename s)) + (second results)))) + 2 t nil) + +(deftest ensure-directories-exist.4 + (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist pn :verbose nil)))))) + (values + (length results) + (equalt (truename pn) (truename (first results))) + (second results) + verbosity)) + 2 t nil "") + +(deftest ensure-directories-exist.5 + (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist pn :verbose t)))))) + (values + (length results) + (equalt (truename pn) (truename (first results))) + (second results) + verbosity)) + 2 t nil "") + +(deftest ensure-directories-exist.6 + (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist + pn :allow-other-keys nil)))))) + (values + (length results) + (equalt (truename pn) (truename (first results))) + (second results) + verbosity)) + 2 t nil "") + +(deftest ensure-directories-exist.7 + (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist + pn :allow-other-keys t :nonsense t)))))) + (values + (length results) + (equalt (truename pn) (truename (first results))) + (second results) + verbosity)) + 2 t nil "") + +;;; Case where directory shouldn't exist + +;; The directort ansi-tests/scratch must not exist before this +;; test is run +(deftest ensure-directories-exist.8 + (let* ((subdir (make-pathname :directory '(:relative "scratch") + :defaults *default-pathname-defaults*)) + (pn (make-pathname :name "foo" :type "txt" + :defaults subdir))) + (ignore-errors (delete-file pn) (delete-file subdir)) + (assert (not (probe-file pn)) () + "Delete subdirectory scratch and its contents!") + (let* ((results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list (ensure-directories-exist pn))))) + (result-pn (first results)) + (created (second results))) + ;; Create the file and write to it + (with-open-file (*standard-output* + pn :direction :output :if-exists :error + :if-does-not-exist :create) + (print nil)) + (values + (length results) + (notnot created) + (equalt pn result-pn) + (notnot (probe-file pn)) + verbosity + ))) + 2 t t t "") + +;;; Specialized string tests + +(deftest ensure-directories-exist.9 + (do-special-strings + (str "ensure-directories-exist.lsp" nil) + (let* ((results (multiple-value-list (ensure-directories-exist str)))) + (assert (eql (length results) 2)) + (assert (equalt (truename (first results)) (truename str))) + (assert (null (second results))))) + nil) + +;; FIXME +;; Need to add a LPN test + +(deftest ensure-directories-exist.error.1 + (signals-error-always + (ensure-directories-exist + (make-pathname :directory '(:relative :wild) + :defaults *default-pathname-defaults*)) + file-error) + t t) + +(deftest ensure-directories-exist.error.2 + (signals-error (ensure-directories-exist) program-error) + t) diff --git a/ansi-tests/file-author.lsp b/ansi-tests/file-author.lsp new file mode 100644 index 0000000..20cf87b --- /dev/null +++ b/ansi-tests/file-author.lsp @@ -0,0 +1,88 @@ +;-*- 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) diff --git a/ansi-tests/file-error.lsp b/ansi-tests/file-error.lsp new file mode 100644 index 0000000..6023c8d --- /dev/null +++ b/ansi-tests/file-error.lsp @@ -0,0 +1,89 @@ +;-*- 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) + + + + + diff --git a/ansi-tests/file-length.lsp b/ansi-tests/file-length.lsp new file mode 100644 index 0000000..cb0d422 --- /dev/null +++ b/ansi-tests/file-length.lsp @@ -0,0 +1,176 @@ +;-*- 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) diff --git a/ansi-tests/file-namestring.lsp b/ansi-tests/file-namestring.lsp new file mode 100644 index 0000000..f837c95 --- /dev/null +++ b/ansi-tests/file-namestring.lsp @@ -0,0 +1,44 @@ +;-*- 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) diff --git a/ansi-tests/file-position.lsp b/ansi-tests/file-position.lsp new file mode 100644 index 0000000..c623014 --- /dev/null +++ b/ansi-tests/file-position.lsp @@ -0,0 +1,170 @@ +;-*- 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) +|# + + \ No newline at end of file diff --git a/ansi-tests/file-string-length.lsp b/ansi-tests/file-string-length.lsp new file mode 100644 index 0000000..f8a8d78 --- /dev/null +++ b/ansi-tests/file-string-length.lsp @@ -0,0 +1,73 @@ +;-*- 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) + + + + diff --git a/ansi-tests/file-write-date.lsp b/ansi-tests/file-write-date.lsp new file mode 100644 index 0000000..de48dac --- /dev/null +++ b/ansi-tests/file-write-date.lsp @@ -0,0 +1,89 @@ +;-*- 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) diff --git a/ansi-tests/finish-output.lsp b/ansi-tests/finish-output.lsp new file mode 100644 index 0000000..f6fab14 --- /dev/null +++ b/ansi-tests/finish-output.lsp @@ -0,0 +1,54 @@ +;-*- 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) + diff --git a/ansi-tests/force-output.lsp b/ansi-tests/force-output.lsp new file mode 100644 index 0000000..af3584b --- /dev/null +++ b/ansi-tests/force-output.lsp @@ -0,0 +1,56 @@ +;-*- 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) + + diff --git a/ansi-tests/fresh-line.lsp b/ansi-tests/fresh-line.lsp new file mode 100644 index 0000000..41542e0 --- /dev/null +++ b/ansi-tests/fresh-line.lsp @@ -0,0 +1,87 @@ +;-*- 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) diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index ab760ff..3ae4833 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -46,6 +46,15 @@ ;;; Tests of strings (load "load-strings.lsp") +;;; Tests of pathnames +(load "load-pathnames.lsp") + +;;; Tests of file operations +(load "load-files.lsp") + +;;; Tests of streams +(load "load-streams.lsp") + ;;; Tests for character functions (compile-and-load "char-aux.lsp") (load "character.lsp") diff --git a/ansi-tests/get-output-stream-string.lsp b/ansi-tests/get-output-stream-string.lsp new file mode 100644 index 0000000..7fc390c --- /dev/null +++ b/ansi-tests/get-output-stream-string.lsp @@ -0,0 +1,32 @@ +;-*- 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) + + + + diff --git a/ansi-tests/host-namestring.lsp b/ansi-tests/host-namestring.lsp new file mode 100644 index 0000000..274b1f5 --- /dev/null +++ b/ansi-tests/host-namestring.lsp @@ -0,0 +1,49 @@ +;-*- 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) + diff --git a/ansi-tests/input-stream-p.lsp b/ansi-tests/input-stream-p.lsp new file mode 100644 index 0000000..ca5f1d0 --- /dev/null +++ b/ansi-tests/input-stream-p.lsp @@ -0,0 +1,40 @@ +;-*- 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) diff --git a/ansi-tests/interactive-stream-p.lsp b/ansi-tests/interactive-stream-p.lsp new file mode 100644 index 0000000..e29cb0f --- /dev/null +++ b/ansi-tests/interactive-stream-p.lsp @@ -0,0 +1,28 @@ +;-*- 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) diff --git a/ansi-tests/ldtest.lsp b/ansi-tests/ldtest.lsp new file mode 100644 index 0000000..e84259d --- /dev/null +++ b/ansi-tests/ldtest.lsp @@ -0,0 +1 @@ +(in-package :cl-test) (defun LOAD-TEST-FUN-3 () :foo) \ No newline at end of file diff --git a/ansi-tests/listen.lsp b/ansi-tests/listen.lsp new file mode 100644 index 0000000..148f552 --- /dev/null +++ b/ansi-tests/listen.lsp @@ -0,0 +1,73 @@ +;-*- 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) diff --git a/ansi-tests/load-files.lsp b/ansi-tests/load-files.lsp new file mode 100644 index 0000000..8a9b765 --- /dev/null +++ b/ansi-tests/load-files.lsp @@ -0,0 +1,16 @@ +;-*- 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") diff --git a/ansi-tests/load-logical-pathname-translations.lsp b/ansi-tests/load-logical-pathname-translations.lsp new file mode 100644 index 0000000..c9c11bf --- /dev/null +++ b/ansi-tests/load-logical-pathname-translations.lsp @@ -0,0 +1,34 @@ +;-*- 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) + diff --git a/ansi-tests/load-pathnames.lsp b/ansi-tests/load-pathnames.lsp new file mode 100644 index 0000000..6e0fa05 --- /dev/null +++ b/ansi-tests/load-pathnames.lsp @@ -0,0 +1,36 @@ +;-*- 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") \ No newline at end of file diff --git a/ansi-tests/load-streams.lsp b/ansi-tests/load-streams.lsp new file mode 100644 index 0000000..ee9bb9a --- /dev/null +++ b/ansi-tests/load-streams.lsp @@ -0,0 +1,57 @@ +;-*- 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") + diff --git a/ansi-tests/load-system-construction.lsp b/ansi-tests/load-system-construction.lsp new file mode 100644 index 0000000..32d25c0 --- /dev/null +++ b/ansi-tests/load-system-construction.lsp @@ -0,0 +1,12 @@ +;-*- 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") diff --git a/ansi-tests/load-test-file-2.lsp b/ansi-tests/load-test-file-2.lsp new file mode 100644 index 0000000..d2941cc --- /dev/null +++ b/ansi-tests/load-test-file-2.lsp @@ -0,0 +1,7 @@ +(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*)) + diff --git a/ansi-tests/load-test-file.lsp b/ansi-tests/load-test-file.lsp new file mode 100644 index 0000000..2e56d2a --- /dev/null +++ b/ansi-tests/load-test-file.lsp @@ -0,0 +1,9 @@ +(in-package :cl-test) + +(defun load-file-test-fun.1 () + '#.*load-pathname*) + +(defun load-file-test-fun.2 () + '#.*load-truename*) + + diff --git a/ansi-tests/load.lsp b/ansi-tests/load.lsp index af6f617..65a2e08 100644 --- a/ansi-tests/load.lsp +++ b/ansi-tests/load.lsp @@ -1,15 +1,227 @@ -;; Get the MK package -;; I've hardwired a path here; fix for your system -;; I assume the package is already compiled. -(unless (find-package "MK") - (load #.(concatenate 'string "../defsys30/defsystem." - #+cmu (C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) - #+allegro "fasl" - #+(or akcl gcl) "o"))) - -(load "rt/rt.system") -(mk::load-system "rt") -(mk::compile-system "cltest") +;-*- 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) diff --git a/ansi-tests/logical-pathname-translations.lsp b/ansi-tests/logical-pathname-translations.lsp new file mode 100644 index 0000000..b03718e --- /dev/null +++ b/ansi-tests/logical-pathname-translations.lsp @@ -0,0 +1,8 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Dec 31 09:46:08 2003 +;;;; Contains: Tests of LOGICAL-PATHNAME-TRANSLATIONS + +(in-package :cl-test) + + diff --git a/ansi-tests/logical-pathname.lsp b/ansi-tests/logical-pathname.lsp new file mode 100644 index 0000000..aebbd39 --- /dev/null +++ b/ansi-tests/logical-pathname.lsp @@ -0,0 +1,93 @@ +;-*- 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) diff --git a/ansi-tests/make-broadcast-stream.lsp b/ansi-tests/make-broadcast-stream.lsp new file mode 100644 index 0000000..25615a9 --- /dev/null +++ b/ansi-tests/make-broadcast-stream.lsp @@ -0,0 +1,99 @@ +;-*- 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) diff --git a/ansi-tests/make-concatenated-stream.lsp b/ansi-tests/make-concatenated-stream.lsp new file mode 100644 index 0000000..97da920 --- /dev/null +++ b/ansi-tests/make-concatenated-stream.lsp @@ -0,0 +1,323 @@ +;-*- 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) + diff --git a/ansi-tests/make-echo-stream.lsp b/ansi-tests/make-echo-stream.lsp new file mode 100644 index 0000000..223a232 --- /dev/null +++ b/ansi-tests/make-echo-stream.lsp @@ -0,0 +1,332 @@ +;-*- 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) + + + + diff --git a/ansi-tests/make-pathname.lsp b/ansi-tests/make-pathname.lsp new file mode 100644 index 0000000..8ccfd3f --- /dev/null +++ b/ansi-tests/make-pathname.lsp @@ -0,0 +1,171 @@ +;-*- 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) diff --git a/ansi-tests/make-string-input-stream.lsp b/ansi-tests/make-string-input-stream.lsp new file mode 100644 index 0000000..b56b8b1 --- /dev/null +++ b/ansi-tests/make-string-input-stream.lsp @@ -0,0 +1,93 @@ +;-*- 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) diff --git a/ansi-tests/make-string-output-stream.lsp b/ansi-tests/make-string-output-stream.lsp new file mode 100644 index 0000000..9b3e7fd --- /dev/null +++ b/ansi-tests/make-string-output-stream.lsp @@ -0,0 +1,139 @@ +;-*- 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) + + + + diff --git a/ansi-tests/make-synonym-stream.lsp b/ansi-tests/make-synonym-stream.lsp new file mode 100644 index 0000000..b5bab2d --- /dev/null +++ b/ansi-tests/make-synonym-stream.lsp @@ -0,0 +1,97 @@ +;-*- 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) diff --git a/ansi-tests/make-two-way-stream.lsp b/ansi-tests/make-two-way-stream.lsp new file mode 100644 index 0000000..e1a43d7 --- /dev/null +++ b/ansi-tests/make-two-way-stream.lsp @@ -0,0 +1,244 @@ +;-*- 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) + + + + \ No newline at end of file diff --git a/ansi-tests/merge-pathnames.lsp b/ansi-tests/merge-pathnames.lsp new file mode 100644 index 0000000..7435e98 --- /dev/null +++ b/ansi-tests/merge-pathnames.lsp @@ -0,0 +1,124 @@ +;-*- 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) diff --git a/ansi-tests/namestring.lsp b/ansi-tests/namestring.lsp new file mode 100644 index 0000000..794ab9c --- /dev/null +++ b/ansi-tests/namestring.lsp @@ -0,0 +1,64 @@ +;-*- 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) diff --git a/ansi-tests/open-stream-p.lsp b/ansi-tests/open-stream-p.lsp new file mode 100644 index 0000000..ea4ed22 --- /dev/null +++ b/ansi-tests/open-stream-p.lsp @@ -0,0 +1,54 @@ +;-*- 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) diff --git a/ansi-tests/open.lsp b/ansi-tests/open.lsp new file mode 100644 index 0000000..e8d1790 --- /dev/null +++ b/ansi-tests/open.lsp @@ -0,0 +1,1238 @@ +;-*- 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 diff --git a/ansi-tests/output-stream-p.lsp b/ansi-tests/output-stream-p.lsp new file mode 100644 index 0000000..e4f13c0 --- /dev/null +++ b/ansi-tests/output-stream-p.lsp @@ -0,0 +1,39 @@ +;-*- 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) diff --git a/ansi-tests/parse-namestring.lsp b/ansi-tests/parse-namestring.lsp new file mode 100644 index 0000000..0d83e89 --- /dev/null +++ b/ansi-tests/parse-namestring.lsp @@ -0,0 +1,89 @@ +;-*- 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) + + diff --git a/ansi-tests/pathname-device.lsp b/ansi-tests/pathname-device.lsp new file mode 100644 index 0000000..228682c --- /dev/null +++ b/ansi-tests/pathname-device.lsp @@ -0,0 +1,74 @@ +;-*- 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) \ No newline at end of file diff --git a/ansi-tests/pathname-directory.lsp b/ansi-tests/pathname-directory.lsp new file mode 100644 index 0000000..01d86cd --- /dev/null +++ b/ansi-tests/pathname-directory.lsp @@ -0,0 +1,89 @@ +;-*- 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) diff --git a/ansi-tests/pathname-host.lsp b/ansi-tests/pathname-host.lsp new file mode 100644 index 0000000..7c29c27 --- /dev/null +++ b/ansi-tests/pathname-host.lsp @@ -0,0 +1,79 @@ +;-*- 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) diff --git a/ansi-tests/pathname-match-p.lsp b/ansi-tests/pathname-match-p.lsp new file mode 100644 index 0000000..09bbd27 --- /dev/null +++ b/ansi-tests/pathname-match-p.lsp @@ -0,0 +1,103 @@ +;-*- 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) diff --git a/ansi-tests/pathname-name.lsp b/ansi-tests/pathname-name.lsp new file mode 100644 index 0000000..df030d6 --- /dev/null +++ b/ansi-tests/pathname-name.lsp @@ -0,0 +1,75 @@ +;-*- 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) diff --git a/ansi-tests/pathname-type.lsp b/ansi-tests/pathname-type.lsp new file mode 100644 index 0000000..136977b --- /dev/null +++ b/ansi-tests/pathname-type.lsp @@ -0,0 +1,75 @@ +;-*- 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) diff --git a/ansi-tests/pathname-version.lsp b/ansi-tests/pathname-version.lsp new file mode 100644 index 0000000..e97ac4a --- /dev/null +++ b/ansi-tests/pathname-version.lsp @@ -0,0 +1,40 @@ +;-*- 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) + diff --git a/ansi-tests/pathname.lsp b/ansi-tests/pathname.lsp new file mode 100644 index 0000000..08ac128 --- /dev/null +++ b/ansi-tests/pathname.lsp @@ -0,0 +1,88 @@ +;-*- 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) diff --git a/ansi-tests/pathnamep.lsp b/ansi-tests/pathnamep.lsp new file mode 100644 index 0000000..398e8e5 --- /dev/null +++ b/ansi-tests/pathnamep.lsp @@ -0,0 +1,31 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Dec 6 10:26:45 2003 +;;;; Contains: Tests of PATHNAMEP + +(in-package :cl-test) + +(deftest pathnamep.1 + (check-type-predicate #'pathnamep 'pathname) + 0) + +(deftest pathnamep.2 + (check-predicate #'(lambda (x) (eql (length (multiple-value-list (pathnamep x))) 1))) + nil) + +(deftest pathnamep.3 + (check-predicate (typef '(not logical-pathname)) #'pathnamep) + nil) + +(deftest pathnamep.error.1 + (signals-error (pathnamep) program-error) + t) + +(deftest pathnamep.error.2 + (signals-error (pathnamep nil nil) program-error) + t) + +(deftest pathnamep.error.3 + (signals-error (pathnamep *default-pathname-defaults* nil) + program-error) + t) diff --git a/ansi-tests/pathnames-aux.lsp b/ansi-tests/pathnames-aux.lsp new file mode 100644 index 0000000..659ea24 --- /dev/null +++ b/ansi-tests/pathnames-aux.lsp @@ -0,0 +1,25 @@ +;-*- 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))) + diff --git a/ansi-tests/pathnames.lsp b/ansi-tests/pathnames.lsp new file mode 100644 index 0000000..d916461 --- /dev/null +++ b/ansi-tests/pathnames.lsp @@ -0,0 +1,19 @@ +;-*- 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) diff --git a/ansi-tests/peek-char.lsp b/ansi-tests/peek-char.lsp new file mode 100644 index 0000000..36b0212 --- /dev/null +++ b/ansi-tests/peek-char.lsp @@ -0,0 +1,329 @@ +;-*- 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) +|# diff --git a/ansi-tests/probe-file.lsp b/ansi-tests/probe-file.lsp new file mode 100644 index 0000000..7e8d506 --- /dev/null +++ b/ansi-tests/probe-file.lsp @@ -0,0 +1,58 @@ +;-*- 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) diff --git a/ansi-tests/read-byte.lsp b/ansi-tests/read-byte.lsp new file mode 100644 index 0000000..5b17972 --- /dev/null +++ b/ansi-tests/read-byte.lsp @@ -0,0 +1,194 @@ +;-*- 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) + + + + + diff --git a/ansi-tests/read-char-no-hang.lsp b/ansi-tests/read-char-no-hang.lsp new file mode 100644 index 0000000..9a6e168 --- /dev/null +++ b/ansi-tests/read-char-no-hang.lsp @@ -0,0 +1,123 @@ +;-*- 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) diff --git a/ansi-tests/read-char.lsp b/ansi-tests/read-char.lsp new file mode 100644 index 0000000..0b63540 --- /dev/null +++ b/ansi-tests/read-char.lsp @@ -0,0 +1,121 @@ +;-*- 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) diff --git a/ansi-tests/read-line.lsp b/ansi-tests/read-line.lsp new file mode 100644 index 0000000..8f9c744 --- /dev/null +++ b/ansi-tests/read-line.lsp @@ -0,0 +1,104 @@ +;-*- 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) + diff --git a/ansi-tests/read-sequence.lsp b/ansi-tests/read-sequence.lsp new file mode 100644 index 0000000..0250aac --- /dev/null +++ b/ansi-tests/read-sequence.lsp @@ -0,0 +1,300 @@ +;-*- 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) diff --git a/ansi-tests/rename-file.lsp b/ansi-tests/rename-file.lsp new file mode 100644 index 0000000..d8a3021 --- /dev/null +++ b/ansi-tests/rename-file.lsp @@ -0,0 +1,199 @@ +;-*- 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) + diff --git a/ansi-tests/rt.lsp b/ansi-tests/rt.lsp index 7ebb8cb..e52c991 100644 --- a/ansi-tests/rt.lsp +++ b/ansi-tests/rt.lsp @@ -21,81 +21,147 @@ | SOFTWARE. | |----------------------------------------------------------------------------|# -;This is the December 19, 1990 version of the regression tester. +;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* '(nil) "Test database") +(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 *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.") -(defstruct (entry (:conc-name nil) - (:type list)) - pend name form) +(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))))) -(defmacro vals (entry) `(cdddr ,entry)) +(defun entry-notes (entry) + (let* ((props (props entry)) + (notes (getf props :notes))) + (if (listp notes) + notes + (list notes)))) -(defmacro defn (entry) `(cdr ,entry)) +(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 () - (do ((l (cdr *entries*) (cdr l)) - (r nil)) - ((null l) (nreverse r)) - (when (pend (car l)) - (push (name (car l)) r)))) + (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*)) - (do ((l *entries* (cdr l))) - ((null (cdr l)) nil) - (when (equal (name (cadr l)) name) - (setf (cdr l) (cddr l)) - (return name)))) + (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 (cdr *entries*) - :key #'name - :test #'equal))) + (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 form &rest values) - `(add-entry '(t ,name ,form .,values))) +(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-list entry)) - (do ((l *entries* (cdr l))) (nil) - (when (null (cdr l)) - (setf (cdr l) (list entry)) - (return nil)) - (when (equal (name (cadr l)) - (name entry)) - (setf (cadr l) 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)) - (return nil))) + (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))) @@ -105,53 +171,59 @@ them.") (apply #'format t args) (if error? (throw '*debug* nil))) (error? (apply #'error args)) - (t (apply #'warn 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 do-test (&optional (name *test*)) - (do-entry (get-entry name))) +(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 (aref x) (aref y))) + (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 e1 across x - for e2 across y + 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) - #| - ((and (typep x 'array) - (= (array-rank x) 2)) - (let ((dim (array-dimensions x))) - (loop for i from 0 below (first dim) - always (loop for j from 0 below (second dim) - always (equalp-with-case (aref x i j) - (aref y i j)))))) - |# ((typep x 'array) (and (typep y 'array) (let ((size (array-total-size x))) (loop for i from 0 below size - always (equalp-with-case (row-major-aref x i) - (row-major-aref y i)))))) - + 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 @@ -165,49 +237,110 @@ them.") r) ;; (declare (special *break-on-warnings*)) - (flet ((%do - () - (setf r - (multiple-value-list - (if *compile-tests* - (funcall (compile - nil - `(lambda () - (declare - (optimize ,@*optimization-settings*)) - ,(form entry)))) - (eval (form entry))))))) - (block aborted - (if *catch-errors* - (handler-bind (#-ecl (style-warning #'muffle-warning) - (error #'(lambda (c) - (setf aborted t) - (setf r (list c)) - (return-from aborted nil)))) - (%do)) - (%do)))) - + (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:~%" - *test* (form entry) (length (vals entry))) - (dolist (v (vals entry)) (format s "~10t~S~%" v)) - (format s "Actual value~P:~%" (length r)) - (dolist (v r) - (format s "~10t~S~:[~; [~2:*~A]~]~%" - v (typep v 'condition))))))) + (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 (&optional - (out *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) @@ -219,13 +352,19 @@ them.") (defun do-entries (s) (format s "~&Doing ~A pending test~:P ~ of ~A tests total.~%" - (count t (cdr *entries*) - :key #'pend) + (count t (the list (cdr *entries*)) :key #'pend) (length (cdr *entries*))) + (finish-output s) (dolist (entry (cdr *entries*)) - (when (pend entry) - (format s "~@[~<~%~:; ~:@(~S~)~>~]" - (do-entry entry s)))) + (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*) @@ -252,19 +391,46 @@ them.") ~^, ~}~)." (length new-failures) new-failures))) - (when *expected-failures* - (let ((pending-table (make-hash-table :test #'equal))) - (dolist (ex pending) - (setf (gethash ex pending-table) t)) - (let ((unexpected-successes - (loop :for ex :in *expected-failures* - :unless (gethash ex pending-table) :collect ex))) - (if unexpected-successes - (format t "~&~:D unexpected successes: ~ - ~:@(~{~<~% ~1:;~S~>~ - ~^, ~}~)." - (length unexpected-successes) - unexpected-successes) - (format t "~&No unexpected successes."))))) )) + (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)))))) diff --git a/ansi-tests/stream-element-type.lsp b/ansi-tests/stream-element-type.lsp new file mode 100644 index 0000000..71bfa86 --- /dev/null +++ b/ansi-tests/stream-element-type.lsp @@ -0,0 +1,102 @@ +;-*- 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) diff --git a/ansi-tests/stream-error-stream.lsp b/ansi-tests/stream-error-stream.lsp new file mode 100644 index 0000000..9a7f533 --- /dev/null +++ b/ansi-tests/stream-error-stream.lsp @@ -0,0 +1,34 @@ +;-*- 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) + + + diff --git a/ansi-tests/stream-external-format.lsp b/ansi-tests/stream-external-format.lsp new file mode 100644 index 0000000..528986c --- /dev/null +++ b/ansi-tests/stream-external-format.lsp @@ -0,0 +1,24 @@ +;-*- 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) diff --git a/ansi-tests/streamp.lsp b/ansi-tests/streamp.lsp new file mode 100644 index 0000000..5bc1b18 --- /dev/null +++ b/ansi-tests/streamp.lsp @@ -0,0 +1,44 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Jan 17 17:12:38 2004 +;;;; Contains: Tests for STREAMP + +(in-package :cl-test) + +(deftest streamp.1 + (loop for s in (list *debug-io* *error-output* *query-io* + *standard-input* *standard-output* + *trace-output* *terminal-io*) + unless (equal (multiple-value-list (notnot-mv (streamp s))) + '(t)) + collect s) + nil) + +(deftest streamp.2 + (check-type-predicate #'streamp 'stream) + 0) + +(deftest streamp.3 + (let ((s (open "foo.txt" :direction :output + :if-exists :supersede))) + (close s) + (notnot-mv (streamp s))) + t) + +(deftest streamp.4 + (let ((s (open "foo.txt" :direction :output + :if-exists :supersede))) + (unwind-protect + (notnot-mv (streamp s)) + (close s))) + t) + +;;; Error tests + +(deftest streamp.error.1 + (signals-error (streamp) program-error) + t) + +(deftest streamp.error.2 + (signals-error (streamp *standard-input* nil) program-error) + t) diff --git a/ansi-tests/synonym-stream-symbol.lsp b/ansi-tests/synonym-stream-symbol.lsp new file mode 100644 index 0000000..11eb6e6 --- /dev/null +++ b/ansi-tests/synonym-stream-symbol.lsp @@ -0,0 +1,23 @@ +;-*- 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) + + diff --git a/ansi-tests/terpri.lsp b/ansi-tests/terpri.lsp new file mode 100644 index 0000000..89a07f1 --- /dev/null +++ b/ansi-tests/terpri.lsp @@ -0,0 +1,62 @@ +;-*- 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) + diff --git a/ansi-tests/translate-logical-pathname.lsp b/ansi-tests/translate-logical-pathname.lsp new file mode 100644 index 0000000..e07edcc --- /dev/null +++ b/ansi-tests/translate-logical-pathname.lsp @@ -0,0 +1,48 @@ +;-*- 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) diff --git a/ansi-tests/translate-pathname.lsp b/ansi-tests/translate-pathname.lsp new file mode 100644 index 0000000..39726c4 --- /dev/null +++ b/ansi-tests/translate-pathname.lsp @@ -0,0 +1,50 @@ +;-*- 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") + + diff --git a/ansi-tests/truename.lsp b/ansi-tests/truename.lsp new file mode 100644 index 0000000..6bb8a2f --- /dev/null +++ b/ansi-tests/truename.lsp @@ -0,0 +1,108 @@ +;-*- 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) diff --git a/ansi-tests/two-way-stream-input-stream.lsp b/ansi-tests/two-way-stream-input-stream.lsp new file mode 100644 index 0000000..1d96e01 --- /dev/null +++ b/ansi-tests/two-way-stream-input-stream.lsp @@ -0,0 +1,26 @@ +;-*- 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) diff --git a/ansi-tests/two-way-stream-output-stream.lsp b/ansi-tests/two-way-stream-output-stream.lsp new file mode 100644 index 0000000..a8415e0 --- /dev/null +++ b/ansi-tests/two-way-stream-output-stream.lsp @@ -0,0 +1,26 @@ +;-*- 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) diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index d7383d1..de3cb5b 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -307,15 +307,50 @@ #-(or GCL CMU ECL) (make-hash-table :test #'equalp) )) -(defvar *pathnames* - (list - (make-pathname :name "foo") - (make-pathname :name "bar") - (make-pathname :name "foo" :type "txt") - (make-pathname :name "bar" :type "txt") - (make-pathname :name :wild) - (make-pathname :name :wild :type "txt") - )) +(defparameter *pathnames* + (locally + (declare (optimize safety)) + (loop for form in '((make-pathname :name "foo") + (make-pathname :name "FOO" :case :common) + (make-pathname :name "bar") + (make-pathname :name "foo" :type "txt") + (make-pathname :name "bar" :type "txt") + (make-pathname :name "XYZ" :type "TXT" :case :common) + (make-pathname :name nil) + (make-pathname :name :wild) + (make-pathname :name nil :type "txt") + (make-pathname :name :wild :type "txt") + (make-pathname :name :wild :type "TXT" :case :common) + (make-pathname :name :wild :type "abc" :case :common) + (make-pathname :directory :wild) + (make-pathname :type :wild) + (make-pathname :version :wild) + (make-pathname :version :newest)) + append (ignore-errors (eval `(list ,form)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (locally + (declare (optimize safety)) + (ignore-errors + (setf (logical-pathname-translations "CLTESTROOT") + `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors) + :name :wild :type :wild))))) + (ignore-errors + (setf (logical-pathname-translations "CLTEST") + `(("**;*.*.*" ,(make-pathname + :directory (append + (pathname-directory + (truename (make-pathname))) + '(:wild-inferiors)) + :name :wild :type :wild))))) + )) + +(defparameter *logical-pathnames* + (locally + (declare (optimize safety)) + (append + (ignore-errors (list (logical-pathname "CLTESTROOT:"))) + ))) (defvar *streams* (remove-duplicates diff --git a/ansi-tests/unread-char.lsp b/ansi-tests/unread-char.lsp new file mode 100644 index 0000000..a98b828 --- /dev/null +++ b/ansi-tests/unread-char.lsp @@ -0,0 +1,92 @@ +;-*- 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) + + diff --git a/ansi-tests/wild-pathname-p.lsp b/ansi-tests/wild-pathname-p.lsp new file mode 100644 index 0000000..d161c43 --- /dev/null +++ b/ansi-tests/wild-pathname-p.lsp @@ -0,0 +1,234 @@ +;-*- 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) diff --git a/ansi-tests/with-input-from-string.lsp b/ansi-tests/with-input-from-string.lsp new file mode 100644 index 0000000..a66f3fc --- /dev/null +++ b/ansi-tests/with-input-from-string.lsp @@ -0,0 +1,245 @@ +;-*- 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. + diff --git a/ansi-tests/with-open-file.lsp b/ansi-tests/with-open-file.lsp new file mode 100644 index 0000000..a138d82 --- /dev/null +++ b/ansi-tests/with-open-file.lsp @@ -0,0 +1,98 @@ +;-*- 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) diff --git a/ansi-tests/with-open-stream.lsp b/ansi-tests/with-open-stream.lsp new file mode 100644 index 0000000..1dcf73a --- /dev/null +++ b/ansi-tests/with-open-stream.lsp @@ -0,0 +1,77 @@ +;-*- 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) diff --git a/ansi-tests/with-output-to-string.lsp b/ansi-tests/with-output-to-string.lsp new file mode 100644 index 0000000..c7c59ef --- /dev/null +++ b/ansi-tests/with-output-to-string.lsp @@ -0,0 +1,129 @@ +;-*- 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) + diff --git a/ansi-tests/write-char.lsp b/ansi-tests/write-char.lsp new file mode 100644 index 0000000..8974e85 --- /dev/null +++ b/ansi-tests/write-char.lsp @@ -0,0 +1,51 @@ +;-*- 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 + + diff --git a/ansi-tests/write-line.lsp b/ansi-tests/write-line.lsp new file mode 100644 index 0000000..10abecf --- /dev/null +++ b/ansi-tests/write-line.lsp @@ -0,0 +1,165 @@ +;-*- 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) + diff --git a/ansi-tests/write-sequence.lsp b/ansi-tests/write-sequence.lsp new file mode 100644 index 0000000..c16ef8e --- /dev/null +++ b/ansi-tests/write-sequence.lsp @@ -0,0 +1,225 @@ +;-*- 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) + diff --git a/ansi-tests/write-string.lsp b/ansi-tests/write-string.lsp new file mode 100644 index 0000000..9d3bf82 --- /dev/null +++ b/ansi-tests/write-string.lsp @@ -0,0 +1,156 @@ +;-*- 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) diff --git a/cmpnew/gcl_cmpfun.lsp b/cmpnew/gcl_cmpfun.lsp index 11c6db4..3a91be0 100755 --- a/cmpnew/gcl_cmpfun.lsp +++ b/cmpnew/gcl_cmpfun.lsp @@ -556,6 +556,14 @@ ((null type) nil) ((setq f (assoc type *type-alist* :test 'equal)) (list (cdr f) x)) + ((setq f (when (symbolp type) (get type 'si::type-predicate))) + (list f x)) + ((and (consp type) (eq (car type) 'or)) + `(or ,@(mapcar (lambda (y) `(typep ,x ',y)) (cdr type)))) + ((and (consp type) (eq (car type) 'member)) + `(or ,@(mapcar (lambda (y) `(eql ,x ',y)) (cdr type)))) + ((and (consp type) (eq (car type) 'eql)) + `(eql ,x ',(cadr type))) ((and (consp type) (or (and (eq (car type) 'vector) (null (cddr type))) diff --git a/cmpnew/gcl_cmplabel.lsp b/cmpnew/gcl_cmplabel.lsp index d66adda..32efb82 100755 --- a/cmpnew/gcl_cmplabel.lsp +++ b/cmpnew/gcl_cmplabel.lsp @@ -44,7 +44,7 @@ `(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) ";"))) + `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")(wt-nl))) (defvar *restore-avma* nil) diff --git a/cmpnew/gcl_cmplam.lsp b/cmpnew/gcl_cmplam.lsp index 2b0b078..ad4ba75 100755 --- a/cmpnew/gcl_cmplam.lsp +++ b/cmpnew/gcl_cmplam.lsp @@ -407,6 +407,12 @@ (c2lambda-expr-without-key lambda-list body))) )) +(defun decl-body-safety (body) + (case (car body) + (decl-body (or (cadr (assoc 'safety (caddr body))) 0)) + ((let let*) (decl-body-safety (car (last body)))) + (otherwise 0))) + (defun c2lambda-expr-without-key (lambda-list body &aux (requireds (car lambda-list)) @@ -439,7 +445,7 @@ (when rest (do-decl rest)) ) ;;; check arguments - (when (or *safe-compile* *compiler-check-args*) + (when (or *safe-compile* *compiler-check-args* (plusp (decl-body-safety body)));FIXME (cond ((or rest optionals) (when requireds (wt-nl "if(vs_top-vs_base<" (length requireds) @@ -448,7 +454,7 @@ (wt-nl "if(vs_top-vs_base>" (+ (length requireds) (length optionals)) ") too_many_arguments();"))) - (t (wt-nl "check_arg(" (length requireds) ");")))) + (t (when requireds (wt-nl "check_arg(" (length requireds) ");"))))) ;;; Allocate the parameters. (dolist** (var requireds) (setf (var-ref var) (vs-push))) @@ -562,7 +568,7 @@ (when (cadddr kwd) (do-decl (cadddr kwd)))) ) ;;; Check arguments. - (when (and (or *safe-compile* *compiler-check-args*) requireds) + (when (and (or *safe-compile* *compiler-check-args* (plusp (decl-body-safety body))) requireds);FIXME (when requireds (wt-nl "if(vs_top-vs_base<" (length requireds) ") too_few_arguments();"))) diff --git a/cmpnew/gcl_cmpmain.lsp b/cmpnew/gcl_cmpmain.lsp index 87d6170..c897fa9 100755 --- a/cmpnew/gcl_cmpmain.lsp +++ b/cmpnew/gcl_cmpmain.lsp @@ -52,7 +52,7 @@ (defvar *cmpinclude-string* (si::file-to-string (namestring - (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :parent "h")) + (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :back "h")) :name "cmpinclude" :type "h")))) @@ -160,7 +160,7 @@ (defun compile-file1 (input-pathname - &key (output-file (truename input-pathname)) + &key (output-file (merge-pathnames ".o" (truename input-pathname))) (o-file t) (c-file *default-c-file*) (h-file *default-h-file*) @@ -175,7 +175,7 @@ (*c-debug* c-debug) (*compile-print* (or print *compile-print*)) (*package* *package*) - (*DEFAULT-PATHNAME-DEFAULTS* #"") + (*DEFAULT-PATHNAME-DEFAULTS* #p"") (*data* (list (make-array 50 :fill-pointer 0 :adjustable t) nil nil)) *init-name* (*fasd-data* *fasd-data*) @@ -186,25 +186,25 @@ (cond (*compiler-in-use* (format t "~&The compiler was called recursively.~%~ Cannot compile ~a.~%" - (namestring (merge-pathnames input-pathname #".lsp"))) + (namestring (merge-pathnames input-pathname #p".lsp"))) (setq *error-p* t) (return-from compile-file1 (values))) (t (setq *error-p* nil) (setq *compiler-in-use* t))) - (unless (probe-file (merge-pathnames input-pathname #".lsp")) + (unless (probe-file (merge-pathnames input-pathname #p".lsp")) (format t "~&The source file ~a is not found.~%" - (namestring (merge-pathnames input-pathname #".lsp"))) + (namestring (merge-pathnames input-pathname #p".lsp"))) (setq *error-p* t) (return-from compile-file1 (values))) (when *compile-verbose* - (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #".lsp")))) + (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #p".lsp")))) (and *record-call-info* (clear-call-table)) (with-open-file - (*compiler-input* (merge-pathnames input-pathname #".lsp")) + (*compiler-input* (merge-pathnames input-pathname #p".lsp")) (cond ((numberp *split-files*) @@ -232,8 +232,11 @@ Cannot compile ~a.~%" (device (or (and (not (null output-file)) (pathname-device output-file)) (pathname-device input-pathname))) + (typ (or (and (not (null output-file)) + (pathname-type output-file)) + "o")) - (o-pathname (get-output-pathname o-file "o" name dir device)) + (o-pathname (get-output-pathname o-file typ name dir device)) (c-pathname (get-output-pathname c-file "c" name dir device)) (h-pathname (get-output-pathname h-file "h" name dir device)) (data-pathname (get-output-pathname data-file "data" name dir device))) @@ -351,7 +354,7 @@ Cannot compile ~a.~%" (wt-data1 form) ;; this binds all the print stuff )) -(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #".")) +(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #p".")) (cond ((not(symbolp name)) (error "Must be a name")) ((and (consp def) @@ -797,7 +800,7 @@ Cannot compile ~a.~%" (with-open-file (st (namestring map) :direction :output)) (safe-system - (let* ((par (namestring (make-pathname :directory '(:parent)))) + (let* ((par (namestring (make-pathname :directory '(:back)))) (i (concatenate 'string " " par)) (j (concatenate 'string " " si::*system-directory* par))) (format nil "~a ~a ~a ~a -L~a ~a ~a ~a" diff --git a/cmpnew/gcl_cmpopt.lsp b/cmpnew/gcl_cmpopt.lsp index 4b24d00..abc5830 100755 --- a/cmpnew/gcl_cmpopt.lsp +++ b/cmpnew/gcl_cmpopt.lsp @@ -1170,6 +1170,14 @@ type_of(#0)==t_complex") (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)"pathnamep(#0)") + (get 'pathnamep 'inline-always)) + ;;STRINGP (push '((t) boolean #.(flags)"type_of(#0)==t_string") (get 'stringp 'inline-always)) diff --git a/cmpnew/gcl_cmptop.lsp b/cmpnew/gcl_cmptop.lsp index db27f85..7b96365 100755 --- a/cmpnew/gcl_cmptop.lsp +++ b/cmpnew/gcl_cmptop.lsp @@ -209,7 +209,7 @@ (cond ((not sp) "code") ((not (pathnamep p)) (init-name (pathname p) sp gp dc nt)) - (gp (init-name (truename (merge-pathnames p #".lsp")) sp nil dc nt)) + (gp (init-name (truename (merge-pathnames p #p".lsp")) sp nil dc nt)) ((pathname-type p) (init-name (make-pathname :host (pathname-host p) diff --git a/cmpnew/gcl_collectfn.lsp b/cmpnew/gcl_collectfn.lsp index e7c90a4..2df5159 100755 --- a/cmpnew/gcl_collectfn.lsp +++ b/cmpnew/gcl_collectfn.lsp @@ -240,22 +240,20 @@ (defvar *warn-on-multiple-fn-definitions* t) -(defun add-fn-data (lis &aux tem file) - (let ((file (and (setq file (si::fp-input-stream *standard-input*)) - (truename file)))) +(defun add-fn-data (lis &aux tem (file *load-truename*)) (dolist (v lis) - (cond ((eql (fn-name v) 'other-form) - (setf (fn-name v) (intern - (concatenate 'string "OTHER-FORM-" - (namestring file)))) - (setf (get (fn-name v) 'other-form) t))) - (setf (gethash (fn-name v) *call-table*) v) - (when *warn-on-multiple-fn-definitions* - (when (setq tem (gethash (fn-name v) *file-table*)) - (unless (equal tem file) - (warn 'simple-warning :format-control "~% ~a redefined in ~a. Originally in ~a." - :format-arguments (list (fn-name v) file tem))))) - (setf (gethash (fn-name v) *file-table*) file)))) + (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")) diff --git a/cmpnew/gcl_lfun_list.lsp b/cmpnew/gcl_lfun_list.lsp index b70ac3d..e2b1262 100755 --- a/cmpnew/gcl_lfun_list.lsp +++ b/cmpnew/gcl_lfun_list.lsp @@ -20,7 +20,6 @@ (DEFSYSFUN 'CHAR-NAME "Lchar_name" '(T) 'T NIL NIL) (DEFSYSFUN 'RASSOC-IF "Lrassoc_if" '(T T) 'T NIL NIL) (DEFSYSFUN 'MAKE-LIST "Lmake_list" '(T *) 'T NIL NIL) -(DEFSYSFUN 'HOST-NAMESTRING "Lhost_namestring" '(T) 'STRING NIL NIL) (DEFSYSFUN 'MAKE-ECHO-STREAM "Lmake_echo_stream" '(T T) 'T NIL NIL) ;(DEFSYSFUN 'NTH "Lnth" '(T T) 'T NIL NIL) (DEFSYSFUN 'SIN "Lsin" '(T) 'T NIL NIL) @@ -31,8 +30,6 @@ ;#-clcs (DEFSYSFUN 'OPEN "Lopen" '(T *) 'T NIL NIL) (DEFSYSFUN 'BOTH-CASE-P "Lboth_case_p" '(T) 'T NIL T) (DEFSYSFUN 'NULL "Lnull" '(T) 'T NIL T) -(DEFSYSFUN 'RENAME-FILE "Lrename_file" '(T T) 'T NIL NIL) -(DEFSYSFUN 'FILE-AUTHOR "Lfile_author" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-CAPITALIZE "Lstring_capitalize" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'MACROEXPAND "Lmacroexpand" '(T *) '(VALUES T T) NIL NIL) @@ -45,7 +42,6 @@ (DEFSYSFUN 'LENGTH "Llength" '(T) 'FIXNUM T NIL) (DEFSYSFUN 'RASSOC "Lrassoc" '(T T *) 'T NIL NIL) (DEFSYSFUN 'PPRINT "Lpprint" '(T *) 'T NIL NIL) -(DEFSYSFUN 'PATHNAME-HOST "Lpathname_host" '(T) 'T NIL NIL) (DEFSYSFUN 'NSUBST-IF-NOT "Lnsubst_if_not" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'FILE-POSITION "Lfile_position" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING< "Lstring_l" '(T T *) 'T NIL NIL) @@ -58,14 +54,11 @@ (DEFSYSFUN 'STRING>= "Lstring_ge" '(T T *) 'T NIL NIL) (DEFSYSFUN 'REALPART "Lrealpart" '(T) 'T NIL NIL) ;;broken on suns.. -;(DEFSYSFUN 'USER-HOMEDIR-PATHNAME "Luser_homedir_pathname" '(*) 'T NIL -; NIL) (DEFSYSFUN 'NBUTLAST "Lnbutlast" '(T *) 'T NIL NIL) (DEFSYSFUN 'ARRAY-DIMENSION "Larray_dimension" '(T T) 'FIXNUM NIL NIL) (DEFSYSFUN 'CDR "Lcdr" '(T) 'T NIL NIL) ;(DEFSYSFUN 'EQL "Leql" '(T T) 'T NIL T) (DEFSYSFUN 'LOG "Llog" '(T *) 'T NIL NIL) -(DEFSYSFUN 'DIRECTORY "Ldirectory" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-EQUAL "Lstring_not_equal" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SHADOWING-IMPORT "Lshadowing_import" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAPC "Lmapc" '(T T *) 'T NIL NIL) @@ -78,8 +71,6 @@ (DEFSYSFUN 'MAKE-SYMBOL "Lmake_symbol" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-RIGHT-TRIM "Lstring_right_trim" '(T T) 'STRING NIL NIL) -(DEFSYSFUN 'ENOUGH-NAMESTRING "Lenough_namestring" '(T *) 'STRING NIL - NIL) (DEFSYSFUN 'PRINT "Lprint" '(T *) 'T NIL NIL) (DEFSYSFUN 'CDDAAR "Lcddaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDADAR "Lcdadar" '(T) 'T NIL NIL) @@ -187,7 +178,6 @@ NIL) (DEFSYSFUN 'COPY-ALIST "Lcopy_alist" '(T) 'T NIL NIL) (DEFSYSFUN 'ATAN "Latan" '(T *) 'T NIL NIL) -(DEFSYSFUN 'DELETE-FILE "Ldelete_file" '(T) 'T NIL NIL) (DEFSYSFUN 'FLOAT-RADIX "Lfloat_radix" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'SYMBOL-NAME "Lsymbol_name" '(T) 'STRING NIL NIL) (DEFSYSFUN 'CLEAR-INPUT "Lclear_input" '(*) 'T NIL NIL) @@ -215,8 +205,6 @@ (DEFSYSFUN 'SXHASH "Lsxhash" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'LISTEN "Llisten" '(*) 'T NIL NIL) (DEFSYSFUN 'ARRAYP "Larrayp" '(T) 'T NIL T) -(DEFSYSFUN 'MAKE-PATHNAME "Lmake_pathname" '(*) 'T NIL NIL) -(DEFSYSFUN 'PATHNAME-TYPE "Lpathname_type" '(T) 'T NIL NIL) (DEFSYSFUN 'FUNCALL "Lfuncall" '(T *) 'T NIL NIL) (DEFSYSFUN 'CLRHASH "Lclrhash" '(T) 'T NIL NIL) (DEFSYSFUN 'GRAPHIC-CHAR-P "Lgraphic_char_p" '(T) 'T NIL T) @@ -227,14 +215,12 @@ (DEFSYSFUN 'SUBST-IF "Lsubst_if" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'COMPLEXP "Lcomplexp" '(T) 'T NIL T) (DEFSYSFUN 'READ-LINE "Lread_line" '(*) '(VALUES T T) NIL NIL) -(DEFSYSFUN 'PATHNAMEP "Lpathnamep" '(T) 'T NIL T) (DEFSYSFUN 'MAX "Lmax" '(T *) 'T NIL NIL) (DEFSYSFUN 'IN-PACKAGE "Lin_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'READTABLEP "Lreadtablep" '(T) 'T NIL T) (DEFSYSFUN 'FLOAT-SIGN "Lfloat_sign" '(T *) 'T NIL NIL) (DEFSYSFUN 'CHARACTERP "Lcharacterp" '(T) 'T NIL T) (DEFSYSFUN 'READ "Lread" '(*) 'T NIL NIL) -(DEFSYSFUN 'NAMESTRING "Lnamestring" '(T) 'T NIL NIL) (DEFSYSFUN 'UNREAD-CHAR "Lunread_char" '(T *) 'T NIL NIL) (DEFSYSFUN 'CDAAR "Lcdaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADAR "Lcadar" '(T) 'T NIL NIL) @@ -267,10 +253,8 @@ (DEFSYSFUN 'PACKAGEP "Lpackagep" '(T) 'T NIL T) (DEFSYSFUN 'INPUT-STREAM-P "Linput_stream_p" '(T) 'T NIL T) (DEFSYSFUN '>= "Lmonotonically_nonincreasing" '(T *) 'T NIL T) -(DEFSYSFUN 'PATHNAME "Lpathname" '(T) 'T NIL NIL) ;(DEFSYSFUN 'EQ "Leq" '(T T) 'T NIL T) (DEFSYSFUN 'MAKE-CHAR "Lmake_char" '(T *) 'CHARACTER NIL NIL) -(DEFSYSFUN 'FILE-NAMESTRING "Lfile_namestring" '(T) 'STRING NIL NIL) (DEFSYSFUN 'CHARACTER "Lcharacter" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'SYMBOL-FUNCTION "Lsymbol_function" '(T) 'T NIL NIL) (DEFSYSFUN 'CONSTANTP "Lconstantp" '(T) 'T NIL T) @@ -307,13 +291,9 @@ (DEFSYSFUN 'NUMBERP "Lnumberp" '(T) 'T NIL T) (DEFSYSFUN 'COPY-READTABLE "Lcopy_readtable" '(*) 'T NIL NIL) (DEFSYSFUN 'RANDOM-STATE-P "Lrandom_state_p" '(T) 'T NIL T) -(DEFSYSFUN 'DIRECTORY-NAMESTRING "Ldirectory_namestring" '(T) 'STRING - NIL NIL) (DEFSYSFUN 'STANDARD-CHAR-P "Lstandard_char_p" '(T) 'T NIL T) -(DEFSYSFUN 'TRUENAME "Ltruename" '(T) 'T NIL NIL) (DEFSYSFUN 'IDENTITY "Lidentity" '(T) 'T NIL NIL) (DEFSYSFUN 'NREVERSE "Lnreverse" '(T) 'T NIL NIL) -(DEFSYSFUN 'PATHNAME-DEVICE "Lpathname_device" '(T) 'T NIL NIL) (DEFSYSFUN 'UNINTERN "Lunintern" '(T *) 'T NIL NIL) (DEFSYSFUN 'UNEXPORT "Lunexport" '(T *) 'T NIL NIL) (DEFSYSFUN 'FLOAT-PRECISION "Lfloat_precision" '(T) 'FIXNUM NIL NIL) @@ -324,7 +304,7 @@ (DEFSYSFUN 'READ-CHAR-NO-HANG "Lread_char_no_hang" '(*) 'T NIL NIL) (DEFSYSFUN 'FRESH-LINE "Lfresh_line" '(*) 'T NIL NIL) (DEFSYSFUN 'WRITE-CHAR "Lwrite_char" '(T *) 'T NIL NIL) -(DEFSYSFUN 'PARSE-NAMESTRING "Lparse_namestring" '(T *) 'T NIL NIL) +;(DEFSYSFUN 'PARSE-NAMESTRING "Lparse_namestring" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-LESSP "Lstring_not_lessp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'CHAR "Lchar" '(T T) 'CHARACTER NIL NIL) (DEFSYSFUN 'AREF "Laref" '(T *) 'T NIL NIL) @@ -338,7 +318,6 @@ (DEFSYSFUN 'DIGIT-CHAR-P "Ldigit_char_p" '(T *) 'T NIL NIL) ;; #-clcs (DEFSYSFUN 'ERROR "Lerror" '(T *) 'T NIL NIL) (DEFSYSFUN 'CHAR/= "Lchar_neq" '(T *) 'T NIL T) -(DEFSYSFUN 'PATHNAME-DIRECTORY "Lpathname_directory" '(T) 'T NIL NIL) (DEFSYSFUN 'CDAAAR "Lcdaaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADAAR "Lcadaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CAADAR "Lcaadar" '(T) 'T NIL NIL) @@ -349,7 +328,6 @@ (DEFSYSFUN 'FORMAT "Lformat" '(T T *) 'T NIL NIL) (DEFSYSFUN 'COMPILED-FUNCTION-P "Lcompiled_function_p" '(T) 'T NIL T) (DEFSYSFUN 'SUBLIS "Lsublis" '(T T *) 'T NIL NIL) -(DEFSYSFUN 'PATHNAME-NAME "Lpathname_name" '(T) 'T NIL NIL) (DEFSYSFUN 'IMPORT "Limport" '(T *) 'T NIL NIL) (DEFSYSFUN 'LOGXOR "Llogxor" '(*) 'T NIL NIL) (DEFSYSFUN 'RASSOC-IF-NOT "Lrassoc_if_not" '(T T) 'T NIL NIL) @@ -366,9 +344,7 @@ (DEFSYSFUN 'GET-PROPERTIES "Lget_properties" '(T T) '* NIL NIL) (DEFSYSFUN 'STRING<= "Lstring_le" '(T T *) 'T NIL NIL) (DEFSYSFUN 'EVALHOOK "siLevalhook" '(T T T *) 'T NIL NIL) -(DEFSYSFUN 'FILE-WRITE-DATE "Lfile_write_date" '(T) 'T NIL NIL) (DEFSYSFUN 'LOGCOUNT "Llogcount" '(T) 'T NIL NIL) -(DEFSYSFUN 'MERGE-PATHNAMES "Lmerge_pathnames" '(T *) 'T NIL NIL) (DEFSYSFUN 'MEMBER-IF "Lmember_if" '(T T *) 'T NIL NIL) (DEFSYSFUN 'READ-BYTE "Lread_byte" '(T *) 'T NIL NIL) (DEFSYSFUN 'SIMPLE-VECTOR-P "Lsimple_vector_p" '(T) 'T NIL T) @@ -381,10 +357,8 @@ (DEFSYSFUN 'GET "Lget" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MOD "Lmod" '(T T) 'T NIL NIL) (DEFSYSFUN 'DIGIT-CHAR "Ldigit_char" '(T *) 'CHARACTER NIL NIL) -(DEFSYSFUN 'PROBE-FILE "Lprobe_file" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-LEFT-TRIM "Lstring_left_trim" '(T T) 'STRING NIL NIL) -(DEFSYSFUN 'PATHNAME-VERSION "Lpathname_version" '(T) 'T NIL NIL) (DEFSYSFUN 'WRITE-LINE "Lwrite_line" '(T *) 'T NIL NIL) (DEFSYSFUN 'EVAL "Leval" '(T) 'T NIL NIL) (DEFSYSFUN 'ATOM "Latom" '(T) 'T NIL T) diff --git a/configure b/configure index 7a1405b..11667c5 100755 --- a/configure +++ b/configure @@ -4183,7 +4183,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu #fi # subst GCC not only under 386-linux, but where available -- CM -TCFLAGS="-fsigned-char" +TCFLAGS="-fsigned-char -fno-builtin-malloc -fno-builtin-free" if test "$GCC" = "yes" ; then diff --git a/configure.in b/configure.in index 1e90217..713919f 100644 --- a/configure.in +++ b/configure.in @@ -483,7 +483,7 @@ AC_SUBST(CC) #fi # subst GCC not only under 386-linux, but where available -- CM -TCFLAGS="-fsigned-char" +TCFLAGS="-fsigned-char -fno-builtin-malloc -fno-builtin-free" if test "$GCC" = "yes" ; then diff --git a/h/att_ext.h b/h/att_ext.h index 8c8f393..f4081c6 100755 --- a/h/att_ext.h +++ b/h/att_ext.h @@ -116,25 +116,14 @@ float object_to_float(); double object_to_double(); /* error.c */ -EXTER object sKerror; -EXTER object sKwrong_type_argument; EXTER object sKcatch; EXTER object sKprotect; EXTER object sKcatchall; -EXTER object sKtoo_few_arguments; -EXTER object sKtoo_many_arguments; -EXTER object sKunexpected_keyword; -EXTER object sKinvalid_form; -EXTER object sKunbound_variable; -EXTER object sKinvalid_variable; -EXTER object sKundefined_function; -EXTER object sKinvalid_function; EXTER object sKdatum; EXTER object sKexpected_type; EXTER object sKpackage; EXTER object sKformat_control; EXTER object sKformat_arguments; -EXTER object sKpackage_error; object wrong_type_argument(); EXTER object sSuniversal_error_handler; @@ -394,10 +383,11 @@ EXTER object sKname; EXTER object sKtype; EXTER object sKversion; EXTER object sKdefaults; -EXTER object sKroot; -EXTER object sKcurrent; -EXTER object sKparent; -EXTER object sKper; + +EXTER object sKabsolute; +EXTER object sKrelative; +EXTER object sKup; + /* object parse_namestring(); */ object coerce_to_pathname(); /* object default_device(); */ diff --git a/h/compdefs.h b/h/compdefs.h index d8bcd61..84d9167 100644 --- a/h/compdefs.h +++ b/h/compdefs.h @@ -115,3 +115,5 @@ SIGNED_CHAR(x) FEerror(x,y...) FEwrong_type_argument(x,y) BIT_ENDIAN(x) +pathname_designatorp(x) +pathnamep(x) diff --git a/h/error.h b/h/error.h index 36f459b..4d951f2 100644 --- a/h/error.h +++ b/h/error.h @@ -22,6 +22,7 @@ PFN(numberp) PFN(characterp) PFN(symbolp) PFN(stringp) +PFN(pathnamep) PFN(string_symbolp) PFN(packagep) PFN(consp) @@ -52,6 +53,7 @@ PFN(functionp) #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) @@ -79,12 +81,6 @@ PFN(functionp) set_type_of((a_),t_fixnum);\ (a_)->FIX.FIXVAL=(b_);} -/*FIXME the stack stuff is dangerous It works for error handling, but - simple errors may evan pass the format tring up the stack as a slot - in ansi*/ -/* #define TYPE_ERROR(a_,b_) {stack_string(tp_err,"~S is not of type ~S.");\ */ -/* Icall_error_handler(sKwrong_type_argument,tp_err,2,(a_),(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_)) diff --git a/h/lu.h b/h/lu.h index cff9f3e..201da4f 100644 --- a/h/lu.h +++ b/h/lu.h @@ -301,7 +301,7 @@ struct pathname { object pn_name; object pn_type; object pn_version; - SPAD; + object pn_namestring; }; struct cfun { diff --git a/h/notcomp.h b/h/notcomp.h index ef2eec9..bbfa434 100755 --- a/h/notcomp.h +++ b/h/notcomp.h @@ -47,12 +47,6 @@ EXTER object user_package; else *__p++ = va_arg(ap,object);} \ va_end(ap) -/* #undef endp */ - -/* #define endp(obje) ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \ */ -/* FALSE : endp_temp == Cnil ? TRUE : \ */ -/* endp1(endp_temp)) */ - #ifndef NO_DEFUN #undef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname @@ -234,7 +228,7 @@ EXTER bool left_trim; EXTER bool right_trim; int (*casefun)(); -#define Q_SIZE 128 +#define Q_SIZE 256 #define IS_SIZE 256 struct printStruct { @@ -300,6 +294,8 @@ gcl_init_cmp_anon(void); #include "gmp_wrappers.h" +char FN1[PATH_MAX],FN2[PATH_MAX],FN3[PATH_MAX],FN4[PATH_MAX],FN5[PATH_MAX]; + #include #define massert(a_) ({errno=0;if (!(a_)||errno) assert_error(#a_,__LINE__,__FILE__,__FUNCTION__);}) diff --git a/h/object.h b/h/object.h index 3bdd24c..3daa012 100755 --- a/h/object.h +++ b/h/object.h @@ -163,24 +163,6 @@ enum aelttype { /* array element type */ #define STREF(type,x,i) (*((type *)(((char *)((x)->str.str_self))+(i)))) #define STSET(type,x,i,val) do{SGC_TOUCH(x);STREF(type,x,i) = (val);} while(0) - - -enum smmode { /* stream mode */ - smm_input, /* input */ - smm_output, /* output */ - smm_io, /* input-output */ - smm_probe, /* probe */ - smm_synonym, /* synonym */ - smm_broadcast, /* broadcast */ - smm_concatenated, /* concatenated */ - smm_two_way, /* two way */ - smm_echo, /* echo */ - smm_string_input, /* string input */ - smm_string_output, /* string output */ - smm_user_defined, /* for user defined */ - smm_socket /* Socket stream */ -}; - /* for any stream that takes writec_char, directly (not two_way or echo) ie. smm_output,smm_io, smm_string_output, smm_socket */ @@ -217,9 +199,9 @@ enum gcl_sm_flags { gcl_sm_tcp_async, gcl_sm_input, gcl_sm_output, + gcl_sm_closed, gcl_sm_had_error - }; enum chattrib { /* character attribute */ @@ -496,8 +478,11 @@ object make_si_sfun(); Used by the C function to set optionals */ #define VFUN_NARGS fcall.argd +#define RETURN4(x,y,z,w) do{/* object _x = (void *) x; */ \ + fcall.values[1]=y;fcall.values[2]=z;fcall.values[3]=w;fcall.nvalues=4; \ + return (x) ;} while(0) #define RETURN2(x,y) do{/* object _x = (void *) x; */\ - fcall.values[2]=y;fcall.nvalues=2; \ + fcall.values[1]=y;fcall.nvalues=2; \ return (x) ;} while(0) #define RETURN1(x) do{fcall.nvalues=1; return (x) ;} while(0) #define RETURN0 do{fcall.nvalues=0; return Cnil ;} while(0) diff --git a/h/protoize.h b/h/protoize.h index c523a7f..01263cb 100644 --- a/h/protoize.h +++ b/h/protoize.h @@ -88,7 +88,7 @@ /* 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); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */ +/* bind.c:610:OF */ extern object find_special (object body, struct bind_temp *start, struct bind_temp *end,object *s); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */ /* bind.c:670:OF */ extern object let_bind (object body, struct bind_temp *start, struct bind_temp *end); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */ /* bind.c:688:OF */ extern object letA_bind (object body, struct bind_temp *start, struct bind_temp *end); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */ /* bind.c:712:OF */ extern void parse_key (object *base, bool rest, bool allow_other_keys, register int n, ... ); diff --git a/h/type.h b/h/type.h index ba3072a..dd584bd 100644 --- a/h/type.h +++ b/h/type.h @@ -7,6 +7,7 @@ enum type { t_shortfloat, t_longfloat, t_complex, + t_stream, t_pathname, t_string, t_bitvector, @@ -17,7 +18,6 @@ enum type { t_character, t_symbol, t_package, - t_stream, t_random, t_readtable, t_cfun, @@ -36,6 +36,23 @@ enum type { }; +enum smmode { /* stream mode */ + smm_input, /* input */ + smm_output, /* output */ + smm_io, /* input-output */ + smm_probe, /* probe */ + smm_file_synonym, /* synonym stream 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 */ +}; + #define Zcdr(a_) (*(object *)(a_))/* ((a_)->c.c_cdr) */ /*FIXME*/ #ifndef WIDE_CONS @@ -82,7 +99,7 @@ enum type { #else #define TYPEWORD_TYPE_P(y_) (y_!=t_cons) #endif - + /*Note preserve sgc flag here VVV*/ #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->fw|=(fixnum)OBJNULL;}}) @@ -113,6 +130,7 @@ enum type { #define randomp(a_) SPP(a_,random) #define characterp(a_) SPP(a_,character) #define symbolp(a_) SPP(a_,symbol) +#define pathnamep(a_) SPP(a_,pathname) #define stringp(a_) SPP(a_,string) #define fixnump(a_) SPP(a_,fixnum) #define readtablep(a_) SPP(a_,readtable) @@ -133,3 +151,6 @@ enum type { || _tp == t_symbol;}) #define pathname_string_symbol_streamp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || _tp == t_string\ || _tp == t_symbol || _tp==t_stream;}) + +#define pathname_designatorp(a_) ({object _a=(a_);enum type _tp=type_of(a_);\ + _tp==t_pathname||_tp==t_string||(_tp==t_stream && _a->sm.sm_mode>=smm_input && _a->sm.sm_mode<=smm_file_synonym);}) diff --git a/lsp/gcl_autoload.lsp b/lsp/gcl_autoload.lsp index 7149ab2..402162c 100755 --- a/lsp/gcl_autoload.lsp +++ b/lsp/gcl_autoload.lsp @@ -410,10 +410,3 @@ Good luck! The GCL Development Team") (setf (get 'with-open-file 'si:pretty-print-format) 1) (setf (get 'with-open-stream 'si:pretty-print-format) 1) (setf (get 'with-output-to-string 'si:pretty-print-format) 1) - - -(in-package :si) - -(defvar *lib-directory* (namestring (truename "../"))) - -(import '(*lib-directory* *load-path* *system-directory*) :user) diff --git a/lsp/gcl_directory.lsp b/lsp/gcl_directory.lsp new file mode 100644 index 0000000..367f05f --- /dev/null +++ b/lsp/gcl_directory.lsp @@ -0,0 +1,67 @@ +(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 (l f zz &optional (yy (make-frame zz))) + (let* ((x (member-if 'wild-dir-element-p l)) + (s (namestring (make-pathname :directory (ldiff l x)))) + (z (vector-push-string zz s)) + (l (length yy)) + (y (link-expand (vector-push-string yy s) l)) + (y (if (eq y yy) y (make-frame y)))) + (when (or (eq (stat 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 (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 (concatenate 'string (getcwd) "/")))) + (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 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 pexp r)))) + (make-frame (if c "./" ""))) + r) diff --git a/lsp/gcl_fpe.lsp b/lsp/gcl_fpe.lsp index 0f1d277..cd7bdc3 100644 --- a/lsp/gcl_fpe.lsp +++ b/lsp/gcl_fpe.lsp @@ -60,7 +60,7 @@ (defun rf (addr w) - (ecase w (4 (*float addr)) (8 (*double addr)))) + (ecase w (4 (*float addr 0 nil nil)) (8 (*double addr 0 nil nil)))) (defun ref (addr p w &aux (i -1)) (if p @@ -71,7 +71,7 @@ (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)))) +(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)))) diff --git a/lsp/gcl_fpe_test.lsp b/lsp/gcl_fpe_test.lsp index c0f225e..1bb27c5 100644 --- a/lsp/gcl_fpe_test.lsp +++ b/lsp/gcl_fpe_test.lsp @@ -1,6 +1,6 @@ -#.`(defun test-fpe (f a r &optional chk &aux cc (o (mapcan (lambda (x) (list x t)) (si::break-on-floating-point-exceptions)))) +#.`(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 'si::break-on-floating-point-exceptions (append (unless x o) (list r x)))))) + (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))))))) diff --git a/lsp/gcl_info.lsp b/lsp/gcl_info.lsp index 4204b8b..32efef8 100755 --- a/lsp/gcl_info.lsp +++ b/lsp/gcl_info.lsp @@ -8,28 +8,6 @@ (,op (the fixnum ,x) (the fixnum ,y)))) (defmacro fcr (x) `(load-time-value (compile-regexp ,x)))) -(eval-when (compile eval load) -(defun sharp-u-reader (stream subchar arg) - subchar arg - (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)) - -(set-dispatch-macro-character #\# #\u 'sharp-u-reader) - -) - (defconstant +crlu+ (compile-regexp #u"")) (defconstant +crnp+ (compile-regexp #u"[ ]")) diff --git a/lsp/gcl_iolib.lsp b/lsp/gcl_iolib.lsp index 9f65bdf..62f9fd2 100755 --- a/lsp/gcl_iolib.lsp +++ b/lsp/gcl_iolib.lsp @@ -1,3 +1,4 @@ +;; -*-Lisp-*- ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL @@ -24,130 +25,229 @@ (in-package :si) -(proclaim '(optimize (safety 2) (space 3))) +(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) - (multiple-value-bind (ds b) - (find-declarations body) + (declare (optimize (safety 1))) + (multiple-value-bind (ds b) (find-declarations body) `(let ((,var ,stream)) ,@ds (unwind-protect - (progn ,@b) + (progn ,@b) (close ,var))))) - (defmacro with-input-from-string ((var string &key index start end) . body) - (let ((x (sgen "X"))) - (multiple-value-bind (ds b) - (find-declarations body) - `(let ((,var (make-string-input-stream ,string ,start ,end))) - ,@ds - (unwind-protect - ,(let ((f `(progn ,@b))) - (if index - `(let ((,x (multiple-value-list ,f))) (setf ,index (get-string-input-stream-index ,var)) (values-list ,x)) - f)) - (close ,var)))))) + (declare (optimize (safety 1))) + (multiple-value-bind (ds b) (find-declarations body) + `(let ((,var (make-string-input-stream ,string ,start ,end))) + ,@ds + (unwind-protect + (multiple-value-prog1 + (progn ,@b) + ,@(when index `((setf ,index (get-string-input-stream-index ,var))))) + (close ,var))))) (defmacro with-output-to-string ((var &optional string &key element-type) . body) - (let ((s (sgen "STRING"))(bl (sgen "BLOCK"))(e (sgen "ELEMENT-TYPE"))(x (sgen "X"))) - (multiple-value-bind (ds b) - (find-declarations body) - `(let* ((,s ,string)(,e ,element-type) - (,var (if ,s (make-string-output-stream-from-string ,s) (make-string-output-stream :element-type ,e)))) + (declare (optimize (safety 1))) + (let ((s (sgen "STRING"))) + (multiple-value-bind (ds b) (find-declarations body) + `(let* ((,s ,string) + (,var (if ,s (make-string-output-stream-from-string ,s) (make-string-output-stream :element-type ,element-type)))) ,@ds (unwind-protect - (let ((,x (multiple-value-list (progn ,@b)))) (if ,s (values-list ,x) (get-output-stream-string ,var))) + (block nil + (multiple-value-prog1 + (progn ,@b) + (unless ,s (return (get-output-stream-string ,var))))) (close ,var)))))) -(defun read-from-string (string - &optional (eof-error-p t) eof-value - &key (start 0) (end (length string)) - preserve-whitespace) - (let ((stream (make-string-input-stream string start end))) - (if preserve-whitespace - (values (read-preserving-whitespace stream eof-error-p eof-value) - (si:get-string-input-stream-index stream)) - (values (read stream eof-error-p eof-value) - (si:get-string-input-stream-index stream))))) - +(defun read-from-string (string &optional (eof-error-p t) eof-value + &key (start 0) end preserve-whitespace) + (declare (optimize (safety 1))) + (check-type string string) + (check-type start seqind) + (check-type end (or null seqind)) + (let ((stream (make-string-input-stream string start (or end (length string))))) + (values (if preserve-whitespace + (read-preserving-whitespace stream eof-error-p eof-value) + (read stream eof-error-p eof-value)) + (get-string-input-stream-index stream)))) + +;; (defun write (x &key stream +;; (array *print-array*) +;; (base *print-base*) +;; (case *print-case*) +;; (circle *print-circle*) +;; (escape *print-escape*) +;; (gensym *print-gensym*) +;; (length *print-length*) +;; (level *print-level*) +;; (lines *print-lines*) +;; (miser-width *print-miser-width*) +;; (pprint-dispatch *print-pprint-dispatch*) +;; (pretty *print-pretty*) +;; (radix *print-radix*) +;; (readably *print-readably*) +;; (right-margin *print-right-margin*)) +;; (write-int x stream array base case circle escape gensym +;; length level lines miser-width pprint-dispatch +;; pretty radix readably right-margin)) (defun write-to-string (object &rest rest - &key escape radix base - circle pretty level length - case gensym array - &aux (stream (make-string-output-stream))) - (declare (ignore escape radix base - circle pretty level length - case gensym array)) + &key (escape *print-escape*)(radix *print-radix*)(base *print-base*) + (circle *print-circle*)(pretty *print-pretty*)(level *print-level*) + (length *print-length*)(case *print-case*)(gensym *print-gensym*) + (array *print-array*)(lines *print-lines*)(miser-width *print-miser-width*) + (pprint-dispatch *print-pprint-dispatch*)(readably *print-readably*) + (right-margin *print-right-margin*) + &aux (stream (make-string-output-stream)) + (*print-escape* escape)(*print-radix* radix)(*print-base* base) + (*print-circle* circle)(*print-pretty* pretty)(*print-level* level) + (*print-length* length)(*print-case* case)(*print-gensym* gensym) + (*print-array* array)(*print-lines* lines)(*print-miser-width* miser-width) + (*print-pprint-dispatch* pprint-dispatch)(*print-readably* readably ) + (*print-right-margin* right-margin)) + (declare (optimize (safety 1))(dynamic-extent rest)) (apply #'write object :stream stream rest) (get-output-stream-string stream)) +(defun prin1-to-string (object &aux (stream (make-string-output-stream))) + (declare (optimize (safety 1))) + (prin1 object stream) + (get-output-stream-string stream)) -(defun prin1-to-string (object - &aux (stream (make-string-output-stream))) - (prin1 object stream) - (get-output-stream-string stream)) - - -(defun princ-to-string (object - &aux (stream (make-string-output-stream))) +(defun princ-to-string (object &aux (stream (make-string-output-stream))) + (declare (optimize (safety 1))) (princ object stream) (get-output-stream-string stream)) +;; (defun file-string-length (ostream object) +;; (declare (optimize (safety 2))) +;; (let ((ostream (if (typep ostream 'broadcast-stream) +;; (car (last (broadcast-stream-streams ostream))) +;; ostream))) +;; (cond ((not ostream) 1) +;; ((subtypep1 (stream-element-type ostream) 'character) +;; (length (let ((*print-escape* nil)) (write-to-string object))))))) + +;; (defmacro with-temp-file ((s pn) (tmp ext) &rest body) +;; (multiple-value-bind +;; (doc decls ctps body) +;; (parse-body-header body) +;; (declare (ignore doc)) +;; `(let* ((,s (temp-stream ,tmp ,ext)) +;; (,pn (stream-object1 ,s))) +;; ,@decls +;; ,@ctps +;; (unwind-protect (progn ,@body) (progn (close ,s) (delete-file ,s)))))) + (defmacro with-open-file ((stream . filespec) . body) - (multiple-value-bind (ds b) - (find-declarations body) + (declare (optimize (safety 1))) + (multiple-value-bind (ds b) (find-declarations body) `(let ((,stream (open ,@filespec))) ,@ds (unwind-protect - (progn ,@b) - (if ,stream (close ,stream)))))) + (progn ,@b) + (when ,stream (close ,stream)))))) + +;; (defun pprint-dispatch (obj &optional (table *print-pprint-dispatch*)) +;; (declare (optimize (safety 2))) +;; (let ((fun (si:get-pprint-dispatch obj table))) +;; (if fun (values fun t) (values 'si:default-pprint-object nil)))) + +;; (setq *print-pprint-dispatch* '(pprint-dispatch . nil)) + +;; (defun set-pprint-dispatch (type-spec function &optional +;; (priority 0) +;; (table *print-pprint-dispatch*)) +;; (declare (optimize (safety 2))) +;; (unless (typep priority 'real) +;; (error 'type-error :datum priority :expected-type 'real)) +;; (let ((a (assoc type-spec (cdr table) :test 'equal))) +;; (if a (setf (cdr a) (list function priority)) +;; (rplacd (last table) `((,type-spec ,function ,priority))))) +;; nil) + +;; (defun copy-pprint-dispatch (&optional table) +;; (declare (optimize (safety 2))) +;; (unless table +;; (setq table *print-pprint-dispatch*)) +;; (unless (and (eq (type-of table) 'cons) +;; (eq (car table) 'pprint-dispatch)) +;; (error 'type-error :datum table :expected-type 'pprint-dispatch)) +;; (copy-seq table )) (defun y-or-n-p (&optional string &rest args) - (do ((reply)) - (nil) - (when string (format *query-io* "~&~? (Y or N) " string args)) - (setq reply (read *query-io*)) - (cond ((string-equal (symbol-name reply) "Y") - (return-from y-or-n-p t)) - ((string-equal (symbol-name reply) "N") - (return-from y-or-n-p nil))))) - + (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) - (do ((reply)) - (nil) - (when string (format *query-io* "~&~? (Yes or No) " string args)) - (setq reply (read *query-io*)) - (cond ((string-equal (symbol-name reply) "YES") - (return-from yes-or-no-p t)) - ((string-equal (symbol-name reply) "NO") - (return-from yes-or-no-p nil))))) - + (declare (optimize (safety 1))) + (when string (format *query-io* "~&~? (Yes or No) " string args)) + (let ((reply (symbol-name (read *query-io*)))) + (cond ((string-equal reply "YES") t) + ((string-equal reply "NO") nil) + ((apply 'yes-or-no-p string args))))) (defun sharp-a-reader (stream subchar arg) (declare (ignore subchar)) (let ((initial-contents (read stream nil nil t))) - (if *read-suppress* - nil - (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)))))) + (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) @@ -155,6 +255,7 @@ (defvar *dribble-saved-terminal-io* nil) (defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede)) + (declare (optimize (safety 1))) (cond ((not psp) (when (null *dribble-stream*) (error "Not in dribble.")) (if (eq *dribble-io* *terminal-io*) @@ -183,73 +284,18 @@ (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)." namestring year month day hour min sec)))))) -(defconstant char-length 8) - -(defun get-byte-stream-nchars (s) - (check-type s stream) - (let* ((tp (stream-element-type s)) - (tp (if (consp tp) (cadr tp) char-length)) - (nc (ceiling tp char-length))) - nc)) - -(defun write-byte (j s) - (declare (optimize (safety 1))) - (let ((nc (get-byte-stream-nchars s)) - (ff (1- (expt 2 char-length)))) - (do ((k 0 (1+ k))(i j (ash i (- char-length)))) ((>= k nc) j) - (write-char (code-char (logand i ff)) s)))) - -(defun read-byte (s &optional (eof-error-p t) eof-value) - (declare (optimize (safety 1))) - (let ((nc (get-byte-stream-nchars s))) - (do ((j 0 (1+ j)) - (i 0 (logior i - (ash (char-code (let ((ch (read-char s eof-error-p eof-value))) - (if (and (not eof-error-p) (eq ch eof-value)) - (return-from read-byte ch) - ch))) (* j char-length))))) - ((>= j nc) i)))) - +;; (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 read-sequence (seq strm &key (start 0) end) +(defun stream-external-format (s) (declare (optimize (safety 1))) - (check-type seq sequence) - (check-type start (integer 0)) - (check-type end (or null (integer 0))) - (let* ((start (min start array-dimension-limit)) - (end (if end (min end array-dimension-limit) (length seq))) - (l (listp seq)) - (seq (if (and l (> start 0)) (nthcdr start seq) seq)) - (tp (subtypep (stream-element-type strm) 'character))) - (do ((i start (1+ i))(seq seq (if l (cdr seq) seq))) - ((or (>= i end) (when l (endp seq))) i) - (declare (fixnum i)) - (let ((el (if tp (read-char strm nil 'eof) (read-byte strm nil 'eof)))) - (when (eq el 'eof) (return i)) - (if l (setf (car seq) el) (setf (aref seq i) el)))))) - - -(defun write-sequence (seq strm &key (start 0) end) - (declare (optimize (safety 1))) - (check-type seq sequence) - (check-type start (integer 0)) - (check-type end (or null (integer 0))) - (let* ((start (min start array-dimension-limit)) - (end (if end (min end array-dimension-limit) (length seq))) - (l (listp seq)) - (tp (subtypep (stream-element-type strm) 'character))) - (do ((i start (1+ i)) - (seq (if (and l (> start 0)) (nthcdr start seq) seq) (if l (cdr seq) seq))) - ((or (>= i end) (when l (endp seq)))) - (declare (fixnum i)) - (let ((el (if l (car seq) (aref seq i)))) - (if tp (write-char el strm) (write-byte el strm)))) - seq)) - -(defmacro with-compilation-unit (opt &rest body) - (declare (optimize (safety 2))) - (declare (ignore opt)) - `(progn ,@body)) + (check-type s stream) + :default) (defvar *print-lines* nil) (defvar *print-miser-width* nil) @@ -257,7 +303,7 @@ (defvar *print-right-margin* nil) (defmacro with-standard-io-syntax (&body body) - (declare (optimize (safety 2))) + (declare (optimize (safety 1))) `(let* ((*package* (find-package :cl-user)) (*print-array* t) (*print-base* 10) @@ -269,7 +315,7 @@ (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) - (*print-pprint-dispatch* *print-pprint-dispatch*) + (*print-pprint-dispatch* *print-pprint-dispatch*);FIXME (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) @@ -278,37 +324,163 @@ (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) - (*readtable* (copy-readtable (si::standard-readtable))));FIXME copy? + (*readtable* (copy-readtable (standard-readtable)))) ,@body)) +;; (defmacro print-unreadable-object +;; ((object stream &key type identity) &body body) +;; (declare (optimize (safety 2))) +;; (let ((q `(princ " " ,stream))) +;; `(if *print-readably* +;; (error 'print-not-readable :object ,object) +;; (progn +;; (princ "#<" ,stream) +;; ,@(when type `((prin1 (type-of ,object) ,stream) ,q)) +;; ,@body +;; ,@(when identity +;; (let ((z `(princ (address ,object) ,stream))) +;; (if (and (not body) type) (list z) (list q z)))) +;; (princ ">" ,stream) +;; nil)))) + +;; (defmacro with-compile-file-syntax (&body body) +;; `(let ((*print-radix* nil) +;; (*print-base* 10) +;; (*print-circle* t) +;; (*print-pretty* nil) +;; (*print-level* nil) +;; (*print-length* nil) +;; (*print-case* :downcase) +;; (*print-gensym* t) +;; (*print-array* t) +;; (*print-package* t) +;; (*print-structure* t)) +;; ,@body)) + +(defmacro with-compilation-unit (opt &rest body) + (declare (optimize (safety 1))) + (declare (ignore opt)) + `(progn ,@body)) + +(defconstant char-length 8) + +(defun get-byte-stream-nchars (s) + (let* ((tp (stream-element-type s))) + (ceiling (if (consp tp) (cadr tp) char-length) char-length))) + +;; (defun parse-integer (s &key start end (radix 10) junk-allowed) +;; (declare (optimize (safety 1))) +;; (parse-integer-int s start end radix junk-allowed)) + +(defun write-byte (j s &aux (i j)) + (declare (optimize (safety 1))) + (check-type j integer) + (check-type s stream) + (dotimes (k (get-byte-stream-nchars s) j) + (write-char (code-char (logand i #.(1- (ash 1 char-length)))) s) + (setq i (ash i #.(- char-length))))) + + +(defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0)) + (declare (optimize (safety 1))) + (check-type s stream) + (dotimes (k (get-byte-stream-nchars s) i) + (setq i (logior i (ash (let ((ch (read-char s eof-error-p eof-value))) + (if (eq ch eof-value) (return ch) (char-code ch))) + (* k char-length)))))) + + +(defun read-sequence (seq strm &rest r &key (start 0) end + &aux (l (listp seq))(seqp (when l (nthcdr start seq))) + (cp (eq (stream-element-type strm) 'character))) + (declare (optimize (safety 1))(dynamic-extent r)) + (check-type seq sequence) + (check-type strm stream) + (check-type start (integer 0)) + (check-type end (or null (integer 0))) + (apply 'reduce (lambda (y x &aux (z (if cp (read-char strm nil 'eof) (read-byte strm nil 'eof)))) + (declare (seqind y)(ignorable x)) + (when (eq z 'eof) (return-from read-sequence y)) + (if l (setf (car seqp) z seqp (cdr seqp)) (setf (aref seq y) z)) + (1+ y)) seq :initial-value start r)) + + +(defun write-sequence (seq strm &rest r &key (start 0) end + &aux (l (listp seq))(cp (eq (stream-element-type strm) 'character))) + (declare (optimize (safety 1))(dynamic-extent r)) + (check-type seq sequence) + (check-type strm stream) + (check-type start (integer 0)) + (check-type end (or null (integer 0))) + (apply 'reduce (lambda (y x) + (declare (seqind y)) + (if cp (write-char x strm) (write-byte x strm)) + (1+ y)) seq :initial-value start r) + seq) + +(defun restrict-stream-element-type (tp) + (cond ((or (member tp '(character :default)) (subtypep tp 'character)) 'character) + ((subtypep tp 'integer) + (let* ((ntp (car (expand-ranges (normalize-type tp)))) + (min (or (cadr ntp) '*))(max (or (caddr ntp) '*)) + (s (if (or (eq min '*) (< min 0)) 'signed-byte 'unsigned-byte)) + (lim (unless (or (eq min '*) (eq max '*)) (max (integer-length min) (integer-length max)))) + (lim (if (and lim (eq s 'signed-byte)) (1+ lim) lim))) + (if lim `(,s ,lim) s))) + ((check-type tp (member character integer))))) + +(defun open (f &key (direction :input) + (element-type 'character) + (if-exists nil iesp) + (if-does-not-exist nil idnesp) + (external-format :default) &aux (pf (pathname f))) + (declare (optimize (safety 1))) + (check-type f pathname-designator) + (when (wild-pathname-p pf) + (error 'file-error :pathname pf :format-control "Pathname is wild.")) + (let* ((s (open-int (namestring (translate-logical-pathname pf)) direction + (restrict-stream-element-type element-type) + if-exists iesp if-does-not-exist idnesp external-format))) + (when (typep s 'stream) (c-set-stream-object1 s pf) s))) + +(defun load-pathname (p print if-does-not-exist external-format + &aux (pp (merge-pathnames p)) + (epp (reduce (lambda (y x) (or y (probe-file (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 #xfe #xff #x4c))) + (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 x y)) (p (make-pathname :directory z))) + (labels ((d (x y &aux (z (ldiff x y)) (n (namestring (make-pathname :directory z)))) (when (when z (stringp (car (last z)))) - (unless (eq :directory (car (stat p))) - (mkdir (namestring p)) + (unless (eq :directory (stat n)) + (mkdir n) (setq created t) - (when verbose (format *standard-output* "Creating directory ~s~%" p)))) + (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))) -#.(let ((g '(:host :device :directory :name :type :version))) - `(defun wild-pathname-p (pd &optional f &aux (p (pathname pd))) - (declare (optimize (safety 1))) - (check-type f (or null (member ,@g))) - (labels ((w-f (x) - (case x - ,@(mapcar (lambda (x &aux (f (intern (string-concatenate "PATHNAME-" (string-upcase x))))) - `(,x ,(if (eq x :directory) `(when (member :wild (,f p)) t) `(eq :wild (,f p))))) g)))) - (if f - (w-f f) - (reduce (lambda (z x) (or z (w-f x))) ',g :initial-value nil))))) - -(defun maybe-clear-input (&optional (x *standard-input*)) - (cond ((not (typep x 'stream)) nil) - ((typep x 'synonym-stream) (maybe-clear-input (symbol-value (synonym-stream-symbol x)))) - ((typep x 'two-way-stream) (maybe-clear-input (two-way-stream-input-stream x))) - ((terminal-input-stream-p x) (clear-input t)))) diff --git a/lsp/gcl_logical_pathname_translations.lsp b/lsp/gcl_logical_pathname_translations.lsp new file mode 100644 index 0000000..38ca8e1 --- /dev/null +++ b/lsp/gcl_logical_pathname_translations.lsp @@ -0,0 +1,28 @@ +(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))) diff --git a/lsp/gcl_make_pathname.lsp b/lsp/gcl_make_pathname.lsp new file mode 100644 index 0000000..97ce3e9 --- /dev/null +++ b/lsp/gcl_make_pathname.lsp @@ -0,0 +1,155 @@ +(in-package :si) + +;; (defun pathnamep (x) +;; (declare (optimize (safety 1))) +;; (when (typep x 'pathname) t)) + +(defun msub (a x) (if a (msub (cdr a) (substitute (caar a) (cdar a) x)) x)) + +(defvar *glob-to-regexp-alist* (list (cons #v"{[^}]*}" (lambda (x) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x))) + (cons #v"\\[[^\\]*\\]" (lambda (x) + (concatenate 'string "(" + (substitute #\^ #\! (subseq x 0 2)) + (subseq x 2) ")"))) + (cons #v"\\*" (lambda (x) "([^/.]*)")) + (cons #v"\\?" (lambda (x) "([^/.])")) + (cons #v"\\." (lambda (x) "\\.")))) + +(defun mglist (x &optional (b 0)) + (let* ((y (mapcan (lambda (z &aux (w (string-match (car z) x b))) + (unless (eql w -1) + (list (list w (match-end 0) z)))) + *glob-to-regexp-alist*)) + (z (when y (reduce (lambda (y x) (if (< (car x) (car y)) x y)) y)))) + (when z + (cons z (mglist x (cadr z)))))) + +(defun mgsub (x &optional (l (mglist x)) (b 0) &aux (w (pop l))) + (if w + (concatenate 'string + (subseq x b (car w)) + (funcall (cdaddr w) (subseq x (car w) (cadr w))) + (mgsub x l (cadr w))) + (subseq x b))) + + +(defun elsub (el x rp lp &aux (y x) (pref (pop y))(dflt (pop y))(post (pop y))) +; (destructuring-bind (pref dflt post &rest y) x + (etypecase el + (string (let ((x (list pref el post))) (unless (zerop (length dflt)) (if rp (mapcar 'mgsub x) x)))) + (integer (elsub (write-to-string el) x rp lp)) + ((eql :wild-inferiors) (if rp (list "(" dflt "*)") (elsub "**" x rp lp))) + ((eql :wild) (if rp (list dflt) (elsub "*" x rp lp))) + ((eql :newest) (elsub (if rp "(newest|NEWEST)" "NEWEST") x rp lp)) + ((member :up :back) (elsub ".." x rp lp)) + ((member nil :unspecific) (when rp (list dflt))) + (cons (cons + (if (eq (car el) :absolute) (if lp "" "/") (if lp ";" "")) + (mapcan (lambda (z) (elsub z y rp lp)) (cdr el))))) +; ) +) + +(defconstant +physical-pathname-defaults+ '(("" "" "") + ("" "" "") + ("" "(/?([^/]+/)*)" "" "" "([^/]+/)" "/") + ("" "([^/.]*)" "") + ("." "(\\.[^/]*)?" "") + ("" "" ""))) +(defconstant +logical-pathname-defaults+ '(("" "([-0-9A-Z]+:)?" ":") + ("" "" "") + ("" "(;?((\\*?([-0-9A-Z]+\\*?)+|\\*|\\*\\*);)*)" "" "" "((\\*?([-0-9A-Z]+\\*?)+|\\*);)" ";") + ("" "(\\*?([-0-9A-Z]+\\*?)+|\\*)?" "") + ("." "(\\.(\\*?([-0-9A-Z]+\\*?)+|\\*))?" "") + ("." "(\\.([1-9][0-9]*|newest|NEWEST|\\*))?" ""))) + +(defun to-regexp-or-namestring (x rp lp) + (apply 'concatenate 'string + (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 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) + (cond ((symbolp x) x) + ((listp x) (mapcar 'toggle-case x)) + ((find-if 'upper-case-p x) (if (find-if 'lower-case-p x) x (string-downcase x))) + ((find-if 'lower-case-p x) (string-upcase x)) + (x))) + +(defun logical-pathname (spec &aux (p (pathname spec))) + (declare (optimize (safety 1))) + (check-type spec pathname-designator) + (check-type p logical-pathname) + p) + +(eval-when (compile eval) + (defun strsym (p &rest r) + (declare (:dynamic-extent r)) + (intern (apply 'concatenate 'string (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 (member nil :unspecific)) + (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 (progn (setq defaulted t) (when def (,(strsym :si "C-PATHNAME-" k) def))))) + (nk (if (eq case :local) nk (progn (setq defaulted t) (toggle-case nk))))) + nk))) + `(let* ((h ,(def? 'host)) + (h (let ((h1 (when (logical-pathname-host-p h) h))) (unless (eq h h1) (setq defaulted t)) h1)) + (dev ,(def? 'device)) + (d ,(def? 'directory)) + (d (let ((d1 (canonicalize-pathname-directory d))) (unless (eq d d1) (setq defaulted t)) d1)) + (n ,(def? 'name)) + (typ ,(def? 'type)) + (v ,(def? 'version)) + (p (init-pathname h dev d n typ v + (or (unless defaulted namestring) (to-regexp-or-namestring (list h dev d n typ v) nil h))))) + (when h (c-set-t-tt p 1)) + (unless (eq d (directory-list-check d)) + (error 'file-error :pathname p :format-control "Bad directory list")) + p))) + +(macrolet ((pn-accessor (k &aux (f (strsym :si "PATHNAME-" k)) (c (strsym :si "C-PATHNAME-" k))) + `(defun ,f (p &key (case :local) &aux (pn (pathname p))) + (declare (optimize (safety 1))) + (check-type p pathname-designator) + (let ((x (,c pn))) (if (eq case :local) x (toggle-case x)))))) + (pn-accessor host) + (pn-accessor device) + (pn-accessor directory) + (pn-accessor name) + (pn-accessor type) + (pn-accessor version)) + +(defconstant +pathname-keys+ '(:host :device :directory :name :type :version)) + +#.`(defun mlp (p) + (list ,@(mapcar (lambda (x) `(,(strsym :si "C-PATHNAME-" x) p)) +pathname-keys+))) + +(defun pnl1 (x) (list* (pop x) (pop x) (append (pop x) x))) +(defun lnp (x) (list* (pop x) (pop x) (let ((q (last x 3))) (cons (ldiff x q) q)))) diff --git a/lsp/gcl_merge_pathnames.lsp b/lsp/gcl_merge_pathnames.lsp new file mode 100644 index 0000000..a64f945 --- /dev/null +++ b/lsp/gcl_merge_pathnames.lsp @@ -0,0 +1,18 @@ +(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))))) diff --git a/lsp/gcl_mislib.lsp b/lsp/gcl_mislib.lsp index aaa6996..7a0cd9d 100755 --- a/lsp/gcl_mislib.lsp +++ b/lsp/gcl_mislib.lsp @@ -114,13 +114,15 @@ (* (+ h tz) 3600) (* min 60) sec)) (defun compile-file-pathname (pathname) -(make-pathname :defaults pathname :type "o")) + (make-pathname :defaults pathname :type "o")) + (defun constantly (x) -#'(lambda (&rest args) + (lambda (&rest args) (declare (ignore args) (:dynamic-extent args)) -x)) + x)) + (defun complement (fn) -#'(lambda (&rest args) (not (apply fn args)))) + (lambda (&rest args) (not (apply fn args)))) (defun default-system-banner () (let (gpled-modules) diff --git a/lsp/gcl_module.lsp b/lsp/gcl_module.lsp index 5795916..2962344 100755 --- a/lsp/gcl_module.lsp +++ b/lsp/gcl_module.lsp @@ -40,13 +40,13 @@ (defun require (module-name &optional (pathname (string-downcase (string module-name)))) - (let ((*default-pathname-defaults* #"")) + (let ((*default-pathname-defaults* (make-pathname))) (unless (member (string module-name) *modules* :test #'string=) (if (atom pathname) (load pathname) - (do ((p pathname (cdr p))) + (do ((p pathname (cdr p))) ((endp p)) (load (car p))))))) diff --git a/lsp/gcl_namestring.lsp b/lsp/gcl_namestring.lsp new file mode 100644 index 0000000..704b4ac --- /dev/null +++ b/lsp/gcl_namestring.lsp @@ -0,0 +1,39 @@ +(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)) diff --git a/lsp/gcl_parse_namestring.lsp b/lsp/gcl_parse_namestring.lsp new file mode 100644 index 0000000..bf37cb8 --- /dev/null +++ b/lsp/gcl_parse_namestring.lsp @@ -0,0 +1,139 @@ +(in-package :si) + +(deftype seqind nil `fixnum) + +(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 mfr (x b i) (subseq x b i)); (make-array (- i b) :element-type 'character :displaced-to x :displaced-index-offset b) + +(defvar *sym-sub-alist* '((:host . nil) + (:device . nil) + (:directory . (("." . nil)(".." . :up)("*" . :wild)("**" . :wild-inferiors))) + (:name . (("*" . :wild))) + (:type . (("*" . :wild))) + (:version . (("*" . :wild)("NEWEST" . :newest))))) + +(defun element (x b i key) + (let* ((z (when (> i b) (mfr x b i))) + (w (assoc z (cdr (assoc key *sym-sub-alist*)) :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 (search sep x :start2 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 (version-parse (parse-integer x))) +; (integer (locally (check-type x (integer 1)) x)) + (otherwise x))) + +(defconstant +generic-logical-pathname-regexp+ (compile-regexp (to-regexp-or-namestring (make-list (length +logical-pathname-defaults+)) t t))) + +(defun expand-home-dir (dir) + (cond ((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 logical-pathname-parse (x &optional host def (b 0) (e (length 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 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 (standard-readtable)) +(set-dispatch-macro-character #\# #\P 'sharp-p-reader) +(set-dispatch-macro-character #\# #\P 'sharp-p-reader (standard-readtable)) +(set-dispatch-macro-character #\# #\" 'sharp-dq-reader) +(set-dispatch-macro-character #\# #\" 'sharp-dq-reader (standard-readtable)) + diff --git a/lsp/gcl_pathname_match_p.lsp b/lsp/gcl_pathname_match_p.lsp new file mode 100644 index 0000000..242cdef --- /dev/null +++ b/lsp/gcl_pathname_match_p.lsp @@ -0,0 +1,14 @@ +(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)))) + diff --git a/lsp/gcl_predlib.lsp b/lsp/gcl_predlib.lsp index 0da83b1..df0dbbf 100755 --- a/lsp/gcl_predlib.lsp +++ b/lsp/gcl_predlib.lsp @@ -110,6 +110,7 @@ (not (array-has-fill-pointer-p x)) (not (si:displaced-array-p x)))) +(defun logical-pathnamep (x) (when (pathnamep x) (eql (c-t-tt x) 1))) (do ((l '((null . null) (symbol . symbolp) @@ -124,7 +125,15 @@ (character . characterp) (package . packagep) (stream . streamp) + (file-stream . file-stream-p) + (synonym-stream . synonym-stream-p) + (broadcast-stream . broadcast-stream-p) + (concatenated-stream . concatenated-stream-p) + (two-way-stream . two-way-stream-p) + (echo-stream . echo-stream-p) (pathname . pathnamep) + (pathname-designator . pathname-designatorp) + (logical-pathname . logical-pathnamep) (readtable . readtablep) (hash-table . hash-table-p) (random-state . random-state-p) @@ -196,6 +205,8 @@ ((null l) t) (unless (typep object (car l)) (return nil)))) (satisfies (funcall (car i) object)) + (eql (eql (car i) object)) + (member (member object i)) ((t) t) ((nil) nil) (boolean (or (eq object 't) (eq object 'nil))) @@ -280,6 +291,40 @@ (typep object (apply tem i))))))) + +(defun minmax (i1 i2 low-p e &aux (fn (if low-p (if e '< '>) (if e '> '<)))) + (cond ((eq i1 '*) (if e i1 i2)) + ((eq i2 '*) (if e i2 i1)) + ((funcall fn i1 i2) i1) + (i2))) + +(defun expand-range (low high bottom top) + (let ((low (minmax low bottom t t))(high (minmax high top nil t))) + (when (or (eq low '*) (eq high '*) (<= low high)) (list low high)))) + +(defun nc (tp) + (when (consp tp) + (case (car tp) + ;; (immfix (let ((m (cadr tp))(x (caddr tp)) + ;; (list (list 'integer (if (eq m '*) most-negative-immfix m) (if (eq x '*) most-positive-immfix x))))) + ;; (bfix (let* ((m (cadr tp))(x (caddr tp))(m (if (eq m '*) most-negative-fixnum m))(x (if (eq x '*) most-positive-fixnum x))) + ;; (if (< (* m x) 0) + ;; `((integer ,m ,(1- most-negative-immfix))(integer ,(1+ most-positive-immfix) ,x)) + ;; `((integer ,m ,x))))) + ;; (bignum (let* ((m (cadr tp))(x (caddr tp))(sm (or (eq m '*) (< m 0)))(sx (or (eq x '*) (>= x 0)))) + ;; (if (and sm sx) + ;; `((integer ,m ,(1- most-negative-fixnum))(integer ,(1+ most-positive-fixnum) ,x)) + ;; `((integer ,m ,x))))) + ((integer ratio short-float long-float) (list tp)) + (otherwise (append (nc (car tp)) (nc (cdr tp))))))) + + +(defun expand-ranges (type) + (reduce (lambda (y x &aux (z (assoc (car x) y))) + (if z (subst (cons (car z) (apply 'expand-range (cadr x) (caddr x) (cdr z))) z y) + (cons x y))) (nc type) :initial-value nil)) + + ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. ;;; The result is always a list. (defun normalize-type (type &aux tp i ) diff --git a/lsp/gcl_rename_file.lsp b/lsp/gcl_rename_file.lsp new file mode 100644 index 0000000..9f08fe5 --- /dev/null +++ b/lsp/gcl_rename_file.lsp @@ -0,0 +1,47 @@ +(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))) + (+ 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))) + (uid-to-name uid))) + diff --git a/lsp/gcl_sharp.lsp b/lsp/gcl_sharp.lsp index 7d9b077..a6a2115 100644 --- a/lsp/gcl_sharp.lsp +++ b/lsp/gcl_sharp.lsp @@ -61,4 +61,6 @@ (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)) diff --git a/lsp/gcl_sharp_uv.lsp b/lsp/gcl_sharp_uv.lsp new file mode 100644 index 0000000..f054bc8 --- /dev/null +++ b/lsp/gcl_sharp_uv.lsp @@ -0,0 +1,29 @@ +(in-package :si) + +(defun regexp-conv (stream) + + (let ((tem (make-array 10 :element-type 'character :fill-pointer 0))) + (or (eql (read-char stream) #\") + (error "sharp-u-reader reader needs a \" right after it")) + (loop + (let ((ch (read-char stream))) + (cond ((eql ch #\") (return tem)) + ((eql ch #\\) + (setq ch (read-char stream)) + (setq ch (or (cdr (assoc ch '((#\n . #\newline) + (#\t . #\tab) + (#\r . #\return)))) + ch)))) + (vector-push-extend ch tem))) + tem)) + +(defun sharp-u-reader (stream subchar arg) + (declare (ignore subchar arg)) + (regexp-conv stream)) + +(defun sharp-v-reader (stream subchar arg) + (declare (ignore subchar arg)) + `(load-time-value (compile-regexp ,(regexp-conv stream)))) + +(set-dispatch-macro-character #\# #\u 'sharp-u-reader) +(set-dispatch-macro-character #\# #\v 'sharp-v-reader) diff --git a/lsp/gcl_top.lsp b/lsp/gcl_top.lsp index 0df721c..2628a14 100755 --- a/lsp/gcl_top.lsp +++ b/lsp/gcl_top.lsp @@ -83,7 +83,7 @@ (progn (cond (*multiply-stacks* (setq *multiply-stacks* nil)) - ((probe-file "init.lsp") (load "init.lsp")))) + ((when (fboundp 'probe-file) (probe-file "init.lsp")) (load "init.lsp")))) (when (if (symbolp *top-level-hook*) (fboundp *top-level-hook*) (functionp *top-level-hook*)) (funcall *top-level-hook*))) @@ -122,6 +122,8 @@ (defvar *error-p* nil) +(defvar *lib-directory* nil) + (defun process-some-args (args &optional compile &aux *load-verbose*) (when args (let ((x (pop args))) @@ -148,7 +150,7 @@ (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 file)) compile)) ++ (compile (cons (cons :output-file (or o (merge-pathnames ".o" file))) compile)) (result (system:error-set `(apply 'compile-file ,file ',(mapcan (lambda (x) (list (car x) (cdr x))) compile))))) (bye (if (or *error-p* (equal result '(nil))) 1 0))))) @@ -520,15 +522,12 @@ add a new one, add a 'si::break-command property:") ;;make sure '/' terminated -(defun coerce-slash-terminated (v ) - (declare (string v)) - (or (stringp v) (error "not a string ~a" v)) +(defun coerce-slash-terminated (v) (let ((n (length v))) - (declare (fixnum n)) - (unless (and (> n 0) (eql - (the character(aref v (the fixnum (- n 1)))) #\/)) - (setf v (format nil "~a/" v)))) - 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)) ) @@ -587,19 +586,17 @@ First directory is checked for first name and all extensions etc." (when (and s (symbol-value s)) (list *system-directory*)))) - -(defun get-temp-dir nil - (dolist (x `(,@(wine-tmp-redirect) ,@(mapcar 'getenv '("TMPDIR" "TMP" "TEMP")) "/tmp" "")) - (when (or (stringp x) (pathnamep x)) - (let* ((x (truename (pathname x))) - (y (namestring (make-pathname :name (pathname-name x) :type (pathname-type x) :version (pathname-version x)))) - (y (unless (zerop (length y)) (list y)))) - (when (eq :directory (car (stat x))) - (return-from get-temp-dir - (namestring - (make-pathname - :device (pathname-device x) - :directory (append (pathname-directory x) y))))))))) +(defun ensure-dir-string (str) + (if (eq (stat str) :directory) + (coerce-slash-terminated str) + str)) + +(defun get-temp-dir () + (dolist (x `(,@(wine-tmp-redirect) ,@(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 get-path (s &aux (m (string-match "([^/ ]*)( |$)" s))(b (match-beginning 1))(e (match-end 1)) (r (with-open-file (s (concatenate 'string "|which " (subseq s b e))) (read s nil 'eof)))) diff --git a/lsp/gcl_translate_pathname.lsp b/lsp/gcl_translate_pathname.lsp new file mode 100644 index 0000000..ace0ce2 --- /dev/null +++ b/lsp/gcl_translate_pathname.lsp @@ -0,0 +1,90 @@ +(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 (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))) + diff --git a/lsp/gcl_truename.lsp b/lsp/gcl_truename.lsp new file mode 100644 index 0000000..d628e66 --- /dev/null +++ b/lsp/gcl_truename.lsp @@ -0,0 +1,43 @@ +(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 (stat 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))))) + +;(defvar *current-dir* (pathname (concatenate 'string (getcwd) "/"))) FIXME sync with chdir + +(defun truename (pd &aux (ppd (translate-logical-pathname pd))(ns (namestring ppd))) + (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)))) + (unless (or (zerop (length ns)) (stat 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 (concatenate 'string (getcwd) "/") 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 (stat (namestring pn)) :file) + (truename pn))) diff --git a/lsp/gcl_wild_pathname_p.lsp b/lsp/gcl_wild_pathname_p.lsp new file mode 100644 index 0000000..f119eec --- /dev/null +++ b/lsp/gcl_wild_pathname_p.lsp @@ -0,0 +1,28 @@ +(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))))) + diff --git a/lsp/makefile b/lsp/makefile index 2e94ae1..de872b9 100644 --- a/lsp/makefile +++ b/lsp/makefile @@ -13,9 +13,12 @@ OBJS = gcl_sharp.o gcl_arraylib.o gcl_assert.o gcl_defmacro.o gcl_defstruct.o \ gcl_describe.o gcl_evalmacros.o gcl_fpe.o \ gcl_iolib.o gcl_listlib.o gcl_mislib.o gcl_module.o gcl_numlib.o \ gcl_packlib.o gcl_predlib.o \ + gcl_parse_namestring.o gcl_make_pathname.o gcl_namestring.o gcl_translate_pathname.o\ + gcl_logical_pathname_translations.o gcl_directory.o gcl_merge_pathnames.o gcl_truename.o gcl_sharp_uv.o\ gcl_seq.o gcl_seqlib.o gcl_setf.o gcl_top.o gcl_trace.o gcl_sloop.o \ gcl_debug.o gcl_info.o gcl_serror.o gcl_restart.o \ - gcl_destructuring_bind.o gcl_defpackage.o gcl_make_defpackage.o gcl_loop.o $(EXTRA_LOBJS) + gcl_rename_file.o gcl_pathname_match_p.o gcl_wild_pathname_p.o \ + gcl_destructuring_bind.o gcl_defpackage.o gcl_make_defpackage.o gcl_loop.o $(EXTRA_LOBJS) # export.o autoload.o auto_new.o LISP=$(PORTDIR)/saved_pre_gcl$(EXE) diff --git a/lsp/sys-proclaim.lisp b/lsp/sys-proclaim.lisp index 3c0931a..70040f4 100755 --- a/lsp/sys-proclaim.lisp +++ b/lsp/sys-proclaim.lisp @@ -2,361 +2,223 @@ (COMMON-LISP::IN-PACKAGE "SYSTEM") (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T) - ANSI-LOOP::LOOP-EMIT-FINAL-VALUE SYSTEM::INSPECT-CHARACTER - SYSTEM::INSPECT-STRUCTURE SYSTEM::PRINT-IHS SYSTEM::DBL-RPL-LOOP - SYSTEM::RESTART-FUNCTION COMMON-LISP::TANH COMMON-LISP::FIFTH - SLOOP::PARSE-LOOP-INITIALLY SYSTEM::NEXT-STACK-FRAME - SYSTEM::IDESCRIBE SYSTEM::PROCESS-ARGS SYSTEM::LEAP-YEAR-P - SLOOP::AVERAGING-SLOOP-MACRO SYSTEM::FIX-LOAD-PATH - SLOOP::SUBSTITUTE-SLOOP-BODY SYSTEM::RESTART-REPORT-FUNCTION - COMMON-LISP::NINTH SLOOP::SLOOP-SLOOP-MACRO - SYSTEM::S-DATA-CONSTRUCTORS SYSTEM::FREEZE-DEFSTRUCT - COMMON-LISP::EIGHTH SYSTEM::FIND-DOCUMENTATION - ANSI-LOOP::LOOP-PSEUDO-BODY COMMON-LISP::RATIONAL - ANSI-LOOP::LOOP-EMIT-BODY COMMON-LISP::ASIN - COMMON-LISP::COMPILE-FILE-PATHNAME SYSTEM::S-DATA-P - SYSTEM::BKPT-FUNCTION SYSTEM::TRACE-ONE-PREPROCESS - COMMON-LISP::LOGNOT SYSTEM::SIMPLE-ARRAY-P SYSTEM::BKPT-FILE - SYSTEM::S-DATA-STATICP COMMON-LISP::ISQRT SYSTEM::INSTREAM-P - COMMON-LISP::SEVENTH SYSTEM::S-DATA-NAMED - ANSI-LOOP::LOOP-PATH-PREPOSITION-GROUPS SYSTEM::INSPECT-NUMBER - COMMON-LISP::ATANH SYSTEM::RESTART-TEST-FUNCTION - SYSTEM::S-DATA-INCLUDES SYSTEM::S-DATA-HAS-HOLES - SYSTEM::CONTEXT-VEC FPE::XMM-LOOKUP SYSTEM::S-DATA-RAW - ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS - SYSTEM::RESTART-INTERACTIVE-FUNCTION - ANSI-LOOP::LOOP-UNIVERSE-ITERATION-KEYWORDS - ANSI-LOOP::LOOP-COLLECTOR-NAME ANSI-LOOP::LOOP-PATH-NAMES - ANSI-LOOP::LOOP-MINIMAX-ANSWER-VARIABLE - SYSTEM::S-DATA-INCLUDED SYSTEM::S-DATA-SLOT-DESCRIPTIONS - SYSTEM::S-DATA-OFFSET SLOOP::REPEAT-SLOOP-MACRO - SYSTEM::S-DATA-PRINT-FUNCTION ANSI-LOOP::LOOP-PATH-USER-DATA - COMMON-LISP::FIND-ALL-SYMBOLS COMMON-LISP::FIRST - SYSTEM::GET-BYTE-STREAM-NCHARS SYSTEM::BKPT-FORM - SYSTEM::NODES-FROM-INDEX SYSTEM::INSPECT-SYMBOL - SYSTEM::KNOWN-TYPE-P ANSI-LOOP::LOOP-MINIMAX-TEMP-VARIABLE - SYSTEM::MAKE-DEFPACKAGE-FORM COMMON-LISP::ARRAY-DIMENSIONS - SYSTEM::INSERT-BREAK-POINT SLOOP::PARSE-LOOP - ANSI-LOOP::LOOP-PATH-INCLUSIVE-PERMITTED - ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS SYSTEM::SHORT-NAME - SYSTEM::CHECK-TRACE-SPEC ANSI-LOOP::DESTRUCTURING-SIZE - SYSTEM::BEST-ARRAY-ELEMENT-TYPE SYSTEM::CONTEXT-HASH - COMMON-LISP::SIXTH SYSTEM::IHS-VISIBLE SYSTEM::INSPECT-ARRAY - COMMON-LISP::BYTE-SIZE ANSI-LOOP::LOOP-COLLECTOR-CLASS - ANSI-LOOP::LOOP-HACK-ITERATION - ANSI-LOOP::LOOP-CONSTRUCT-RETURN SYSTEM::S-DATA-SLOT-POSITION - ANSI-LOOP::LOOP-MINIMAX-FLAG-VARIABLE SYSTEM::INSPECT-STRING - COMMON-LISP::PROVIDE COMMON-LISP::CIS - ANSI-LOOP::LOOP-MINIMAX-OPERATIONS - SYSTEM::BREAK-BACKWARD-SEARCH-STACK - ANSI-LOOP::LOOP-COLLECTOR-DTYPE - SYSTEM::IHS-NOT-INTERPRETED-ENV SYSTEM::SEARCH-STACK - COMMON-LISP::TENTH ANSI-LOOP::LOOP-DO-THEREIS - ANSI-LOOP::LOOP-MAXMIN-COLLECTION - ANSI-LOOP::LOOP-MINIMAX-INFINITY-DATA - ANSI-LOOP::LOOP-MAKE-PSETQ SYSTEM::ADD-TO-HOTLIST - SYSTEM::INSPECT-CONS ANSI-LOOP::LOOP-UNIVERSE-TYPE-SYMBOLS - SYSTEM::INSPECT-VECTOR COMMON-LISP::CONSTANTLY - SYSTEM::REWRITE-RESTART-CASE-CLAUSE SYSTEM::DM-BAD-KEY - SYSTEM::PRINT-SYMBOL-APROPOS SYSTEM::FRS-KIND FPE::ST-LOOKUP - COMMON-LISP::FOURTH SYSTEM::TERMINAL-INTERRUPT - SYSTEM::DM-KEY-NOT-ALLOWED SYSTEM::UNIQUE-ID - SYSTEM::S-DATA-FROZEN SLOOP::POINTER-FOR-COLLECT - SYSTEM::INSPECT-PACKAGE SYSTEM::DBL-EVAL - ANSI-LOOP::LOOP-MINIMAX-TYPE ANSI-LOOP::LOOP-UNIVERSE-ANSI - ANSI-LOOP::LOOP-UNIVERSE-TYPE-KEYWORDS SYSTEM::DWIM - SYSTEM::INSTREAM-STREAM-NAME SLOOP::RETURN-SLOOP-MACRO - SYSTEM::PATCH-SHARP SYSTEM::CONTEXT-P SYSTEM::INFO-GET-FILE - SYSTEM::RESTART-P COMMON-LISP::COSH COMMON-LISP::SINH - SYSTEM::GET-NEXT-VISIBLE-FUN SYSTEM::CHECK-DECLARATIONS - SYSTEM::GET-INSTREAM - ANSI-LOOP::LOOP-CODE-DUPLICATION-THRESHOLD SYSTEM::S-DATA-NAME - ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS - SYSTEM::S-DATA-DOCUMENTATION SYSTEM::SHOW-BREAK-POINT - COMMON-LISP::ACOS COMMON-LISP::INVOKE-DEBUGGER - SYSTEM::BKPT-FILE-LINE ANSI-LOOP::LOOP-COLLECTOR-DATA - COMMON-LISP::THIRD SYSTEM::S-DATA-CONC-NAME - COMMON-LISP::SIGNUM - ANSI-LOOP::LOOP-UNIVERSE-IMPLICIT-FOR-REQUIRED - SYSTEM::NORMALIZE-TYPE ANSI-LOOP::LOOP-TYPED-INIT - ANSI-LOOP::LOOP-PATH-FUNCTION SYSTEM::INFO-NODE-FROM-POSITION - COMMON-LISP::ASINH SYSTEM::RE-QUOTE-STRING - SLOOP::LOOP-COLLECT-KEYWORD-P SYSTEM::PRINT-FRS - SYSTEM::EVAL-FEATURE ANSI-LOOP::LOOP-COLLECTOR-P - ANSI-LOOP::LOOP-COLLECTOR-HISTORY - ANSI-LOOP::LOOP-LIST-COLLECTION - SYSTEM::BREAK-FORWARD-SEARCH-STACK COMMON-LISP::RESTART-NAME - SLOOP::PARSE-NO-BODY ANSI-LOOP::LOOP-UNIVERSE-P - SYSTEM::NUMBER-OF-DAYS-FROM-1900 SYSTEM::NODE-OFFSET - ANSI-LOOP::LOOP-MINIMAX-P SYSTEM::IHS-FNAME FPE::LOOKUP - SLOOP::LOOP-LET-BINDINGS FPE::GREF COMMON-LISP::PHASE - COMMON-LISP::BYTE-POSITION SYSTEM::INSTREAM-STREAM - ANSI-LOOP::LOOP-PATH-P SYSTEM::SEQTYPE COMMON-LISP::ACOSH - COMMON-LISP::ABS COMMON-LISP::COMPLEMENT - ANSI-LOOP::LOOP-CONSTANTP SYSTEM::WALK-THROUGH - SYSTEM::SETUP-INFO SYSTEM::COMPUTING-ARGS-P - SYSTEM::CONTEXT-SPICE SYSTEM::MAKE-KCL-TOP-RESTART - COMMON-LISP::COMPILER-MACRO-FUNCTION - ANSI-LOOP::LOOP-MAKE-DESETQ SYSTEM::SHOW-ENVIRONMENT - SLOOP::TRANSLATE-NAME SYSTEM::INFO-GET-TAGS - COMMON-LISP::SECOND SYSTEM::RESET-TRACE-DECLARATIONS - SYSTEM::S-DATA-TYPE SYSTEM::FIND-KCL-TOP-RESTART - ANSI-LOOP::MAKE-ANSI-LOOP-UNIVERSE SYSTEM::DO-F - ANSI-LOOP::LOOP-COLLECTOR-TEMPVARS COMMON-LISP::VECTOR-POP)) + (COMMON-LISP::FUNCTION + ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER + COMMON-LISP::*) + (COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807)) + COMMON-LISP::FIXNUM) + SYSTEM::ATOI)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*) - SYSTEM::IHS-BACKTRACE SYSTEM::BREAK-NEXT SYSTEM::BREAK-QUIT - SYSTEM::SHOW-BREAK-VARIABLES SYSTEM::BREAK-BDS - COMMON-LISP::MUFFLE-WARNING SYSTEM::BREAK-PREVIOUS - SYSTEM::INFO-ERROR ANSI-LOOP::LOOP-OPTIONAL-TYPE - SYSTEM::DBL-BACKTRACE SYSTEM::BREAK-LOCAL SYSTEM::BREAK-VS - COMMON-LISP::CONTINUE)) + (COMMON-LISP::FUNCTION (COMMON-LISP::T) + (COMMON-LISP::OR COMMON-LISP::NULL + COMMON-LISP::HASH-TABLE)) + SYSTEM::CONTEXT-HASH)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM) - COMMON-LISP::FIXNUM) - SYSTEM::DBL-WHAT-FRAME FPE::FE-ENABLE)) + (COMMON-LISP::FUNCTION + (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T + COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) + COMMON-LISP::*) + SYSTEM::PARSE-DEFMACRO-LAMBDA-LIST SYSTEM::PARSE-DEFMACRO)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) - COMMON-LISP::SUBTYPEP COMMON-LISP::REDUCE SYSTEM::PARSE-BODY - COMMON-LISP::STABLE-SORT COMMON-LISP::SORT - SLOOP::FIND-IN-ORDERED-LIST)) + COMMON-LISP::SUBTYPEP COMMON-LISP::REDUCE + SLOOP::FIND-IN-ORDERED-LIST SYSTEM::PARSE-BODY + COMMON-LISP::STABLE-SORT COMMON-LISP::SORT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) - SYSTEM::VERIFY-KEYWORDS SYSTEM::RESTART-PRINT - ANSI-LOOP::LOOP-GET-COLLECTION-INFO SYSTEM::LIST-MERGE-SORT - SYSTEM::READ-INSPECT-COMMAND SYSTEM::SHARP---READER - SYSTEM::SHARP-+-READER SYSTEM::SHARP-S-READER)) + SYSTEM::SHARP-+-READER SYSTEM::SHARP---READER + SYSTEM::SHARP-S-READER ANSI-LOOP::LOOP-GET-COLLECTION-INFO + SYSTEM::VERIFY-KEYWORDS SYSTEM::LIST-MERGE-SORT + SYSTEM::RESTART-PRINT SYSTEM::READ-INSPECT-COMMAND)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T COMMON-LISP::T) + COMMON-LISP::T) COMMON-LISP::*) - SYSTEM::PUSH-OPTIONAL-BINDING)) + SYSTEM::TRACE-CALL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) + COMMON-LISP::*) COMMON-LISP::*) - SYSTEM::PARSE-DEFMACRO-LAMBDA-LIST SYSTEM::PARSE-DEFMACRO)) + SYSTEM::EXPAND-WILD-DIRECTORY SYSTEM::MASET)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) - SYSTEM::TRACE-CALL)) + SYSTEM::MME3)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::*) - COMMON-LISP::*) - SYSTEM::MASET)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FIXNUM) - FPE::REG-LOOKUP SYSTEM::INSTREAM-LINE SYSTEM::THE-START - SYSTEM::S-DATA-LENGTH SYSTEM::S-DATA-SIZE)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM) COMMON-LISP::T) - SYSTEM::PUSH-CONTEXT SYSTEM::GET-CONTEXT)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::*) - SYSTEM::BREAK-CURRENT SYSTEM::GCL-TOP-LEVEL - SYSTEM::BREAK-MESSAGE SYSTEM::BREAK-RESUME - ANSI-LOOP::LOOP-DO-FOR SYSTEM::SIMPLE-BACKTRACE - SYSTEM::BREAK-HELP)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::STRING) COMMON-LISP::T) - SYSTEM::COERCE-SLASH-TERMINATED SYSTEM::RESET-SYS-PATHS)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) - COMMON-LISP::T) - COMMON-LISP::BIT COMMON-LISP::READ-BYTE - COMMON-LISP::CONCATENATE SYSTEM::INFO-SEARCH - COMMON-LISP::ARRAY-IN-BOUNDS-P ANSI-LOOP::LOOP-ERROR - ANSI-LOOP::LOOP-WARN COMMON-LISP::REMOVE-DUPLICATES - SYSTEM::BAD-SEQ-LIMIT SYSTEM::PROCESS-SOME-ARGS - ANSI-LOOP::LOOP-COLLECT-PREPOSITIONAL-PHRASES - SLOOP::LOOP-ADD-TEMPS COMMON-LISP::BIT-NOT COMMON-LISP::SIGNAL - SYSTEM::NTH-STACK-FRAME COMMON-LISP::ARRAY-ROW-MAJOR-INDEX - COMMON-LISP::MAKE-ARRAY SYSTEM::FILE-SEARCH - SYSTEM::LIST-MATCHES COMMON-LISP::FIND-RESTART - SYSTEM::BREAK-LEVEL COMMON-LISP::DELETE-DUPLICATES - SLOOP::ADD-FROM-DATA COMMON-LISP::ERROR COMMON-LISP::WARN - SYSTEM::FILE-TO-STRING - COMMON-LISP::UPGRADED-ARRAY-ELEMENT-TYPE COMMON-LISP::SBIT)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) + COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T + COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) - SYSTEM::FIND-DOC SYSTEM::RESTART-REPORT - ANSI-LOOP::ESTIMATE-CODE-SIZE-1 SYSTEM::NEWLINE - ANSI-LOOP::ESTIMATE-CODE-SIZE SYSTEM::NEW-SEMI-COLON-READER)) + SYSTEM::PUSH-OPTIONAL-BINDING)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::VALUES COMMON-LISP::T COMMON-LISP::T)) SYSTEM::MAKE-KEYWORD)) -(COMMON-LISP::MAPC - (COMMON-LISP::LAMBDA (COMPILER::X) - (COMMON-LISP::SETF - (COMMON-LISP::GET COMPILER::X 'SYSTEM::PROCLAIMED-CLOSURE) - COMMON-LISP::T)) - '(SYSTEM::SI-CLASS-PRECEDENCE-LIST SYSTEM::SI-CLASSP - SYSTEM::SIMPLE-CONDITION-CLASS-P SYSTEM::UNTRACE-ONE - SYSTEM::CONDITIONP SYSTEM::CONDITION-CLASS-P - SYSTEM::MAKE-ACCESS-FUNCTION SYSTEM::SI-CLASS-NAME - SYSTEM::AUTOLOAD-MACRO SYSTEM::AUTOLOAD SYSTEM::SI-CLASS-OF - SYSTEM::WARNINGP SYSTEM::DEFINE-STRUCTURE - FPE::BREAK-ON-FLOATING-POINT-EXCEPTIONS SYSTEM::SI-FIND-CLASS - SYSTEM::TRACE-ONE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION - (COMMON-LISP::T COMMON-LISP::FIXNUM COMMON-LISP::FIXNUM + (COMMON-LISP::T + (COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807) + (COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807) COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::QUICK-SORT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION - (COMMON-LISP::T COMMON-LISP::FIXNUM COMMON-LISP::T - COMMON-LISP::T) + (COMMON-LISP::T + (COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807) + COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::BIGNTHCDR)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION + (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) + COMMON-LISP::T) + COMMON-LISP::EVERY COMMON-LISP::SET-DIFFERENCE + SYSTEM::VECTOR-PUSH-STRING SYSTEM::PROCESS-ERROR + COMMON-LISP::POSITION-IF-NOT COMMON-LISP::FIND-IF + SLOOP::LOOP-ADD-BINDING COMMON-LISP::BIT-ORC1 + COMMON-LISP::READ-SEQUENCE SYSTEM::INTERNAL-COUNT-IF + COMMON-LISP::COUNT COMMON-LISP::MISMATCH + COMMON-LISP::ADJUST-ARRAY COMMON-LISP::INTERSECTION + COMMON-LISP::UNION COMMON-LISP::DELETE-IF-NOT + COMMON-LISP::NINTERSECTION COMMON-LISP::BIT-ANDC1 + COMMON-LISP::REMOVE-IF-NOT COMMON-LISP::TYPEP + COMMON-LISP::NUNION COMMON-LISP::WRITE-SEQUENCE + COMMON-LISP::VECTOR-PUSH-EXTEND COMMON-LISP::REMOVE + COMMON-LISP::BIT-IOR SLOOP::PARSE-LOOP-MACRO + COMMON-LISP::SEARCH COMMON-LISP::SUBSETP + COMMON-LISP::SET-EXCLUSIVE-OR SYSTEM::WREADDIR + COMMON-LISP::POSITION-IF COMMON-LISP::DELETE + COMMON-LISP::BIT-EQV COMMON-LISP::BIT-ANDC2 + COMMON-LISP::BIT-AND COMMON-LISP::NSET-EXCLUSIVE-OR + SLOOP::IN-ARRAY-SLOOP-FOR ANSI-LOOP::LOOP-CHECK-DATA-TYPE + COMMON-LISP::POSITION COMMON-LISP::MAKE-SEQUENCE + COMMON-LISP::NOTEVERY COMMON-LISP::MAP-INTO + COMMON-LISP::REPLACE COMMON-LISP::NSET-DIFFERENCE + COMMON-LISP::FIND-IF-NOT COMMON-LISP::BIT-ORC2 + COMMON-LISP::DELETE-IF COMMON-LISP::CERROR + COMMON-LISP::BIT-XOR COMMON-LISP::FIND COMMON-LISP::FILL + SYSTEM::INTERNAL-COUNT-IF-NOT COMMON-LISP::REMOVE-IF + COMMON-LISP::BIT-NAND COMMON-LISP::BIT-NOR COMMON-LISP::SOME + COMMON-LISP::COUNT-IF SYSTEM::BREAK-CALL + COMMON-LISP::COUNT-IF-NOT SYSTEM::FIND-IHS COMMON-LISP::NOTANY + SYSTEM::INTERNAL-COUNT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) - ANSI-LOOP::LOOP-MAKE-ITERATION-VARIABLE ANSI-LOOP::LOOP-FOR-IN - SYSTEM::DEFMACRO* SYSTEM::APPLY-DISPLAY-FUN - SYSTEM::WARN-VERSION ANSI-LOOP::HIDE-VARIABLE-REFERENCE - SYSTEM::SHARP-U-READER ANSI-LOOP::LOOP-FOR-ACROSS - SYSTEM::DM-VL SYSTEM::GET-SLOT-POS + SYSTEM::PATHNAME-PARSE ANSI-LOOP::LOOP-TRANSLATE + SYSTEM::CHECK-S-DATA SYSTEM::MFR FPE::REF + ANSI-LOOP::LOOP-STANDARD-EXPANSION ANSI-LOOP::LOOP-FOR-ON + ANSI-LOOP::LOOP-SUM-COLLECTION SYSTEM::SHARP-DQ-READER + COMMON-LISP::DPB SYSTEM::CHECK-TRACE-ARGS + SLOOP::LOOP-PARSE-ADDITIONAL-COLLECTIONS SYSTEM::RECURSE-DIR + SYSTEM::SHARP-U-READER SYSTEM::FLOATING-POINT-ERROR + ANSI-LOOP::LOOP-FOR-IN ANSI-LOOP::HIDE-VARIABLE-REFERENCE + SYSTEM::GET-SLOT-POS SYSTEM::APPLY-DISPLAY-FUN SYSTEM::RESTART-CASE-EXPRESSION-CONDITION - SYSTEM::CHECK-TRACE-ARGS ANSI-LOOP::LOOP-FOR-ON FPE::REF - ANSI-LOOP::PRINT-LOOP-UNIVERSE ANSI-LOOP::LOOP-ANSI-FOR-EQUALS - SYSTEM::SETF-EXPAND-1 ANSI-LOOP::LOOP-SUM-COLLECTION - ANSI-LOOP::LOOP-STANDARD-EXPANSION SYSTEM::MAKE-T-TYPE - COMMON-LISP::DEPOSIT-FIELD SYSTEM::MAKE-BREAK-POINT - ANSI-LOOP::LOOP-FOR-BEING ANSI-LOOP::LOOP-TRANSLATE - SYSTEM::SHARP-A-READER COMMON-LISP::DPB - SYSTEM::FLOATING-POINT-ERROR SYSTEM::CHECK-S-DATA - SLOOP::LOOP-PARSE-ADDITIONAL-COLLECTIONS)) + SYSTEM::MAKE-BREAK-POINT SYSTEM::TO-REGEXP-OR-NAMESTRING + COMMON-LISP::DEPOSIT-FIELD SYSTEM::SHARP-V-READER + SYSTEM::MAKE-T-TYPE ANSI-LOOP::LOOP-FOR-ACROSS + ANSI-LOOP::LOOP-ANSI-FOR-EQUALS ANSI-LOOP::PRINT-LOOP-UNIVERSE + ANSI-LOOP::LOOP-FOR-BEING SYSTEM::SHARP-P-READER SYSTEM::DM-VL + SYSTEM::SHARP-A-READER ANSI-LOOP::LOOP-MAKE-ITERATION-VARIABLE + SYSTEM::DEFMACRO* SYSTEM::SETF-EXPAND-1 SYSTEM::WARN-VERSION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T) + COMMON-LISP::*) COMMON-LISP::T) - SLOOP::FIRST-USE-SLOOP-FOR SYSTEM::COERCE-TO-CONDITION SYSTEM::DO-BREAK-LEVEL - SLOOP::FIRST-SLOOP-FOR ANSI-LOOP::LOOP-FOR-ARITHMETIC - SYSTEM::MAYBE-BREAK SYSTEM::SETF-STRUCTURE-ACCESS - SYSTEM::CALL-TEST SYSTEM::FIND-LINE-IN-FUN)) + SYSTEM::MME2 COMMON-LISP::NSUBSTITUTE SYSTEM::MATCH-COMPONENT + SYSTEM::COMPLETE-PROP SYSTEM::WALK-DIR + COMMON-LISP::TRANSLATE-PATHNAME ANSI-LOOP::ADD-LOOP-PATH + SYSTEM::DIR-PARSE ANSI-LOOP::LOOP-MAKE-VARIABLE + COMMON-LISP::SUBSTITUTE-IF COMMON-LISP::NSUBSTITUTE-IF + SYSTEM::PUSH-LET-BINDING COMMON-LISP::SUBSTITUTE + ANSI-LOOP::LOOP-HASH-TABLE-ITERATION-PATH COMMON-LISP::MAP + COMMON-LISP::SUBSTITUTE-IF-NOT COMMON-LISP::NSUBSTITUTE-IF-NOT + ANSI-LOOP::LOOP-PACKAGE-SYMBOLS-ITERATION-PATH + SLOOP::LOOP-DECLARE-BINDING + ANSI-LOOP::LOOP-SEQUENCE-ELEMENTS-PATH + SYSTEM::CHECK-TYPE-SYMBOL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION - (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) + (COMMON-LISP::T COMMON-LISP::T + (COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807)) COMMON-LISP::T) - COMMON-LISP::COUNT-IF COMMON-LISP::BIT-ANDC2 - COMMON-LISP::REMOVE SYSTEM::INTERNAL-COUNT-IF - SLOOP::LOOP-ADD-BINDING COMMON-LISP::MAP-INTO - COMMON-LISP::FIND-IF COMMON-LISP::NSET-DIFFERENCE - COMMON-LISP::UNION COMMON-LISP::NUNION - COMMON-LISP::MAKE-SEQUENCE COMMON-LISP::NOTANY - COMMON-LISP::POSITION COMMON-LISP::DELETE-IF - COMMON-LISP::BIT-ORC2 COMMON-LISP::REPLACE COMMON-LISP::DELETE - SYSTEM::BREAK-CALL COMMON-LISP::NINTERSECTION - COMMON-LISP::POSITION-IF SYSTEM::FIND-IHS COMMON-LISP::BIT-AND - COMMON-LISP::DELETE-IF-NOT ANSI-LOOP::LOOP-CHECK-DATA-TYPE - COMMON-LISP::REMOVE-IF COMMON-LISP::READ-SEQUENCE - SLOOP::PARSE-LOOP-MACRO COMMON-LISP::BIT-NAND - SYSTEM::INTERNAL-COUNT-IF-NOT COMMON-LISP::SUBSETP - COMMON-LISP::VECTOR-PUSH-EXTEND COMMON-LISP::EVERY - COMMON-LISP::SOME COMMON-LISP::WRITE-SEQUENCE - COMMON-LISP::MISMATCH COMMON-LISP::SET-EXCLUSIVE-OR - COMMON-LISP::REMOVE-IF-NOT COMMON-LISP::BIT-NOR - COMMON-LISP::BIT-XOR COMMON-LISP::BIT-EQV COMMON-LISP::SEARCH - COMMON-LISP::SET-DIFFERENCE COMMON-LISP::FILL - COMMON-LISP::CERROR COMMON-LISP::ADJUST-ARRAY - COMMON-LISP::BIT-ORC1 SYSTEM::INTERNAL-COUNT - COMMON-LISP::TYPEP SYSTEM::PROCESS-ERROR - COMMON-LISP::COUNT-IF-NOT COMMON-LISP::INTERSECTION - SLOOP::IN-ARRAY-SLOOP-FOR COMMON-LISP::FIND-IF-NOT - COMMON-LISP::BIT-ANDC1 COMMON-LISP::POSITION-IF-NOT - COMMON-LISP::NOTEVERY COMMON-LISP::NSET-EXCLUSIVE-OR - COMMON-LISP::FIND COMMON-LISP::COUNT COMMON-LISP::BIT-IOR)) + SYSTEM::SHARP-EQ-READER SYSTEM::SHARP-SHARP-READER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) + COMMON-LISP::T) COMMON-LISP::T) - SYSTEM::PUSH-SUB-LIST-BINDING SYSTEM::DO-ARG-COUNT-ERROR)) + SYSTEM::ELSUB SLOOP::FIRST-USE-SLOOP-FOR + SLOOP::FIRST-SLOOP-FOR SYSTEM::SETF-STRUCTURE-ACCESS + SYSTEM::FIND-LINE-IN-FUN SYSTEM::COERCE-TO-CONDITION + ANSI-LOOP::LOOP-FOR-ARITHMETIC SYSTEM::MAYBE-BREAK + SYSTEM::ELEMENT SYSTEM::DO-BREAK-LEVEL SYSTEM::CALL-TEST)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::*) + COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T + COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T + COMMON-LISP::T) COMMON-LISP::T) - ANSI-LOOP::ADD-LOOP-PATH COMMON-LISP::MAP - ANSI-LOOP::LOOP-HASH-TABLE-ITERATION-PATH - ANSI-LOOP::LOOP-PACKAGE-SYMBOLS-ITERATION-PATH - COMMON-LISP::SUBSTITUTE COMMON-LISP::NSUBSTITUTE - COMMON-LISP::NSUBSTITUTE-IF-NOT ANSI-LOOP::LOOP-MAKE-VARIABLE - COMMON-LISP::SUBSTITUTE-IF-NOT - ANSI-LOOP::LOOP-SEQUENCE-ELEMENTS-PATH - SYSTEM::PUSH-LET-BINDING COMMON-LISP::SUBSTITUTE-IF - SYSTEM::CHECK-TYPE-SYMBOL SLOOP::LOOP-DECLARE-BINDING - SYSTEM::COMPLETE-PROP COMMON-LISP::NSUBSTITUTE-IF)) + ANSI-LOOP::LOOP-SEQUENCER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) - SYSTEM::MAKE-PREDICATE - SYSTEM::MAKE-CONSTRUCTOR)) + SYSTEM::MAKE-CONSTRUCTOR SYSTEM::MAKE-PREDICATE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) - COMMON-LISP::T) - SYSTEM::UNIVERSAL-ERROR-HANDLER)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION - (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::FIXNUM) + COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) - SYSTEM::SHARP-SHARP-READER SYSTEM::SHARP-EQ-READER)) + SYSTEM::PUSH-SUB-LIST-BINDING SYSTEM::DO-ARG-COUNT-ERROR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) - SLOOP::DEF-LOOP-INTERNAL SYSTEM::PRINT-STACK-FRAME - COMMON-LISP::MERGE)) + SLOOP::DEF-LOOP-INTERNAL COMMON-LISP::MERGE + SYSTEM::PRINT-STACK-FRAME)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION @@ -369,154 +231,389 @@ '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T - COMMON-LISP::T) + COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) - ANSI-LOOP::LOOP-SEQUENCER)) + SYSTEM::UNIVERSAL-ERROR-HANDLER)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) + COMMON-LISP::T) + COMMON-LISP::MERGE-PATHNAMES + COMMON-LISP::TRANSLATE-LOGICAL-PATHNAME ANSI-LOOP::LOOP-ERROR + COMMON-LISP::WILD-PATHNAME-P SLOOP::LOOP-ADD-TEMPS + SYSTEM::FILE-SEARCH SYSTEM::INFO-SEARCH + COMMON-LISP::PATHNAME-VERSION COMMON-LISP::WARN SYSTEM::MGSUB + COMMON-LISP::ARRAY-ROW-MAJOR-INDEX + COMMON-LISP::REMOVE-DUPLICATES COMMON-LISP::PATHNAME-NAME + COMMON-LISP::BIT COMMON-LISP::FIND-RESTART SYSTEM::TO-REGEXP + SYSTEM::PROCESS-SOME-ARGS COMMON-LISP::ERROR + COMMON-LISP::REQUIRE COMMON-LISP::OPEN + COMMON-LISP::UPGRADED-ARRAY-ELEMENT-TYPE SLOOP::ADD-FROM-DATA + SYSTEM::BREAK-LEVEL SYSTEM::LIST-MATCHES + COMMON-LISP::DELETE-DUPLICATES ANSI-LOOP::LOOP-WARN + COMMON-LISP::PATHNAME-DEVICE COMMON-LISP::LOAD + COMMON-LISP::PATHNAME-HOST COMMON-LISP::SBIT SYSTEM::NLOAD + COMMON-LISP::BIT-NOT COMMON-LISP::ENOUGH-NAMESTRING + COMMON-LISP::SIGNAL COMMON-LISP::ARRAY-IN-BOUNDS-P + COMMON-LISP::PATHNAME-TYPE SYSTEM::FILE-TO-STRING + SYSTEM::LOGICAL-PATHNAME-PARSE SYSTEM::NTH-STACK-FRAME + ANSI-LOOP::LOOP-COLLECT-PREPOSITIONAL-PHRASES SYSTEM::MGLIST + COMMON-LISP::DIRECTORY SYSTEM::BAD-SEQ-LIMIT + COMMON-LISP::PATHNAME-DIRECTORY COMMON-LISP::READ-BYTE + SYSTEM::LINK-EXPAND COMMON-LISP::CONCATENATE + COMMON-LISP::MAKE-ARRAY)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) + COMMON-LISP::*) + SYSTEM::NEWLINE SYSTEM::LIST-TOGGLE-CASE + COMMON-LISP::RENAME-FILE ANSI-LOOP::ESTIMATE-CODE-SIZE + SYSTEM::SOURCE-PORTION SYSTEM::RESTART-REPORT SYSTEM::DO-REPL + SYSTEM::FIND-DOC ANSI-LOOP::ESTIMATE-CODE-SIZE-1 + SYSTEM::NEW-SEMI-COLON-READER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION - (COMMON-LISP::STRING COMMON-LISP::FIXNUM) + ((COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807)) COMMON-LISP::FIXNUM) - SYSTEM::ATOI)) + FPE::FE-ENABLE SYSTEM::DBL-WHAT-FRAME)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) + COMMON-LISP::*) + SYSTEM::INFO SYSTEM::GET-SETF-METHOD-MULTIPLE-VALUE + COMMON-LISP::FTRUNCATE COMMON-LISP::USE-VALUE + COMMON-LISP::INVOKE-RESTART COMMON-LISP::WRITE-TO-STRING + COMMON-LISP::FCEILING COMMON-LISP::FROUND + COMMON-LISP::READ-FROM-STRING COMMON-LISP::FFLOOR + SYSTEM::PARSE-BODY-HEADER SYSTEM::BREAK-FUNCTION + SYSTEM::APROPOS-DOC COMMON-LISP::APROPOS + COMMON-LISP::APROPOS-LIST + ANSI-LOOP::LOOP-CONSTANT-FOLD-IF-POSSIBLE + COMMON-LISP::GET-SETF-EXPANSION SYSTEM::PRINT-DOC + COMMON-LISP::PARSE-NAMESTRING + COMMON-LISP::ENSURE-DIRECTORIES-EXIST + COMMON-LISP::DECODE-UNIVERSAL-TIME SYSTEM::SHOW-INFO + COMMON-LISP::STORE-VALUE SYSTEM::STEPPER)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) + COMMON-LISP::T) + COMMON-LISP::VECTOR-PUSH SYSTEM::DM-NTH COMMON-LISP::LOGORC1 + SLOOP::L-EQUAL SLOOP::NEVER-SLOOP-COLLECT + COMMON-LISP::LDB-TEST COMMON-LISP::LDB COMMON-LISP::LOGORC2 + SLOOP::COUNT-SLOOP-COLLECT SLOOP::MAXIMIZE-SLOOP-COLLECT + SYSTEM::ALL-MATCHES ANSI-LOOP::LOOP-TMEMBER SLOOP::THE-TYPE + SYSTEM::?PUSH SYSTEM::INCREMENT-CURSOR SYSTEM::SET-DIR + SYSTEM::DM-NTH-CDR SYSTEM::IN-INTERVAL-P SLOOP::MAKE-VALUE + SYSTEM::DBL-UP COMMON-LISP::COERCE SYSTEM::MATCH-DIMENSIONS + COMMON-LISP::LOGNAND SLOOP::=-SLOOP-FOR + SYSTEM::KEYWORD-SUPPLIED-P SYSTEM::OVERWRITE-SLOT-DESCRIPTIONS + SYSTEM::LEFT-PARENTHESIS-READER + ANSI-LOOP::LOOP-MAYBE-BIND-FORM SYSTEM::COERCE-TO-STRING + SYSTEM::ADD-FILE SLOOP::PARSE-LOOP-MAP COMMON-LISP::LOGNOR + SYSTEM::MSUB SYSTEM::SET-BACK SYSTEM::SUPER-GO + SYSTEM::SUBSTRINGP ANSI-LOOP::LOOP-TEQUAL + ANSI-LOOP::LOOP-DO-WHILE SYSTEM::GET-LINE-OF-FORM + FPE::READ-INSTRUCTION SYSTEM::SUB-INTERVAL-P + SYSTEM::CHECK-SEQ-START-END SYSTEM::*BREAK-POINTS* + ANSI-LOOP::MAKE-LOOP-MINIMAX SLOOP::IN-PACKAGE-SLOOP-MAP + SYSTEM::DM-V SYSTEM::INFO-AUX + ANSI-LOOP::HIDE-VARIABLE-REFERENCES + SLOOP::COLLATE-SLOOP-COLLECT COMMON-LISP::PATHNAME-MATCH-P + SYSTEM::SET-PATH-STREAM-NAME SLOOP::SUM-SLOOP-COLLECT + ANSI-LOOP::LOOP-LOOKUP-KEYWORD + ANSI-LOOP::LOOP-DECLARE-VARIABLE SYSTEM::BREAK-STEP-NEXT + FPE::RF SLOOP::IN-TABLE-SLOOP-MAP SYSTEM::OBJLT + FPE::READ-OPERANDS SYSTEM::BREAK-STEP-INTO COMMON-LISP::BYTE + SYSTEM::SEQUENCE-CURSOR SYSTEM::LIST-DELQ + SYSTEM::SETF-LOGICAL-PATHNAME-TRANSLATIONS + SYSTEM::CONDITION-PASS SYSTEM::SETF-HELPER FPE::0-READER + SYSTEM::DISPLAY-COMPILED-ENV COMMON-LISP::NTH + COMPILER::COMPILER-DEF-HOOK SYSTEM::DOT-DIR-P + COMMON-LISP::LOGTEST SYSTEM::QUOTATION-READER + SYSTEM::ITERATE-OVER-BKPTS COMMON-LISP::LOGANDC1 + SLOOP::ALWAYS-SLOOP-COLLECT SLOOP::DESETQ1 + SYSTEM::GET-INFO-CHOICES COMMON-LISP::WRITE-BYTE + ANSI-LOOP::LOOP-DO-IF ANSI-LOOP::LOOP-NOTE-MINIMAX-OPERATION + ANSI-LOOP::LOOP-TASSOC SLOOP::IN-CAREFULLY-SLOOP-FOR + COMMON-LISP::DOCUMENTATION FPE::PAREN-READER SYSTEM::GET-NODES + SYSTEM::PARSE-SLOT-DESCRIPTION SLOOP::IN-FRINGE-SLOOP-MAP + SYSTEM::SAFE-EVAL SYSTEM::DISPLAY-ENV FPE::%-READER + SLOOP::THEREIS-SLOOP-COLLECT SYSTEM::LOOKUP-KEYWORD + COMMON-LISP::LOGANDC2 COMMON-LISP::NTHCDR + SLOOP::MINIMIZE-SLOOP-COLLECT SYSTEM::GET-MATCH + SYSTEM::SETF-EXPAND SLOOP::LOGXOR-SLOOP-COLLECT + ANSI-LOOP::LOOP-DO-ALWAYS)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION + ((COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807) + (COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807)) + COMMON-LISP::FIXNUM) + SYSTEM::ROUND-UP)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::T) - SYSTEM::DESCRIBE-ENVIRONMENT SYSTEM::STEP-NEXT - COMMON-LISP::BREAK COMMON-LISP::ABORT SYSTEM::MAKE-S-DATA - ANSI-LOOP::MAKE-LOOP-COLLECTOR SLOOP::PARSE-LOOP-DECLARE - ANSI-LOOP::LOOP-GENTEMP SYSTEM::MAKE-INSTREAM - SYSTEM::MAYBE-CLEAR-INPUT - ANSI-LOOP::MAKE-LOOP-MINIMAX-INTERNAL COMMON-LISP::Y-OR-N-P - SYSTEM::CURRENT-STEP-FUN ANSI-LOOP::LOOP-DISALLOW-CONDITIONAL - COMMON-LISP::DRIBBLE SYSTEM::MAKE-RESTART - SLOOP::PARSE-LOOP-WITH SYSTEM::LOC COMMON-LISP::YES-OR-NO-P - SYSTEM::TRANSFORM-KEYWORDS SYSTEM::MAKE-CONTEXT - COMMON-LISP::COMPUTE-RESTARTS SYSTEM::DBL-READ - SYSTEM::STEP-INTO ANSI-LOOP::MAKE-LOOP-UNIVERSE - SYSTEM::BREAK-LOCALS ANSI-LOOP::MAKE-STANDARD-LOOP-UNIVERSE - COMMON-LISP::VECTOR ANSI-LOOP::MAKE-LOOP-PATH)) + COMMON-LISP::Y-OR-N-P COMMON-LISP::YES-OR-NO-P + COMMON-LISP::DRIBBLE COMMON-LISP::VECTOR SYSTEM::NEXT-MATCH + SYSTEM::MAKE-S-DATA SYSTEM::LOC SYSTEM::BREAK-LOCALS + SLOOP::PARSE-LOOP-WITH COMMON-LISP::USER-HOMEDIR-PATHNAME + SYSTEM::STEP-INTO SYSTEM::MAYBE-CLEAR-INPUT + ANSI-LOOP::MAKE-LOOP-PATH SYSTEM::STEP-NEXT + ANSI-LOOP::LOOP-GENTEMP COMMON-LISP::COMPUTE-RESTARTS + SYSTEM::CURRENT-STEP-FUN SYSTEM::MAKE-INSTREAM + ANSI-LOOP::MAKE-LOOP-COLLECTOR SYSTEM::MAKE-RESTART + SYSTEM::DESCRIBE-ENVIRONMENT SYSTEM::TRANSFORM-KEYWORDS + COMMON-LISP::ABORT ANSI-LOOP::MAKE-STANDARD-LOOP-UNIVERSE + ANSI-LOOP::MAKE-LOOP-UNIVERSE SLOOP::PARSE-LOOP-DECLARE + COMMON-LISP::BREAK ANSI-LOOP::LOOP-DISALLOW-CONDITIONAL + SYSTEM::MAKE-CONTEXT SYSTEM::DBL-READ + COMMON-LISP::MAKE-PATHNAME + ANSI-LOOP::MAKE-LOOP-MINIMAX-INTERNAL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::*) - ANSI-LOOP::LOOP-LIST-STEP SYSTEM::INSPECT-OBJECT - COMMON-LISP::DESCRIBE ANSI-LOOP::LOOP-OPTIMIZATION-QUANTITIES - SYSTEM::BREAK-GO SYSTEM::GET-&ENVIRONMENT - COMMON-LISP::PRINC-TO-STRING SYSTEM::WAITING - SYSTEM::INSTREAM-NAME ANSI-LOOP::NAMED-VARIABLE - COMMON-LISP::PRIN1-TO-STRING SYSTEM::INFO-SUBFILE - COMMON-LISP::INSPECT SYSTEM::END-WAITING - SYSTEM::FIND-DECLARATIONS - COMMON-LISP::INVOKE-RESTART-INTERACTIVELY - SYSTEM::BREAK-LEVEL-INVOKE-RESTART SYSTEM::ALOAD)) + ANSI-LOOP::LOOP-OPTIMIZATION-QUANTITIES SYSTEM::BREAK-GO + COMMON-LISP::FILE-AUTHOR SYSTEM::ENSURE-DIR-STRING + SYSTEM::INFO-SUBFILE COMMON-LISP::DESCRIBE SYSTEM::END-WAITING + COMMON-LISP::PRIN1-TO-STRING SYSTEM::FIND-DECLARATIONS + COMMON-LISP::INSPECT ANSI-LOOP::NAMED-VARIABLE + SYSTEM::GET-&ENVIRONMENT SYSTEM::INSPECT-OBJECT + COMMON-LISP::PRINC-TO-STRING ANSI-LOOP::LOOP-LIST-STEP + SYSTEM::INSTREAM-NAME SYSTEM::BREAK-LEVEL-INVOKE-RESTART + SYSTEM::WAITING COMMON-LISP::INVOKE-RESTART-INTERACTIVELY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) - COMMON-LISP::T) - ANSI-LOOP::MAKE-LOOP-MINIMAX COMMON-LISP::LDB - SYSTEM::LIST-DELQ FPE::RF SLOOP::L-EQUAL - ANSI-LOOP::LOOP-DECLARE-VARIABLE SYSTEM::DISPLAY-COMPILED-ENV - SYSTEM::SET-BACK ANSI-LOOP::HIDE-VARIABLE-REFERENCES - SYSTEM::GET-LINE-OF-FORM SYSTEM::BREAK-STEP-INTO - SLOOP::THE-TYPE SLOOP::COUNT-SLOOP-COLLECT - SYSTEM::KEYWORD-SUPPLIED-P COMMON-LISP::LOGANDC2 - ANSI-LOOP::LOOP-MAYBE-BIND-FORM SYSTEM::SET-DIR - SYSTEM::COERCE-TO-STRING COMMON-LISP::VECTOR-PUSH - SYSTEM::DM-NTH-CDR SLOOP::IN-FRINGE-SLOOP-MAP - SLOOP::MAXIMIZE-SLOOP-COLLECT SYSTEM::ADD-FILE - SYSTEM::ALL-MATCHES SYSTEM::DM-NTH - SLOOP::IN-CAREFULLY-SLOOP-FOR SYSTEM::PARSE-SLOT-DESCRIPTION - ANSI-LOOP::LOOP-LOOKUP-KEYWORD FPE::0-READER - ANSI-LOOP::LOOP-TMEMBER COMPILER::COMPILER-DEF-HOOK - SYSTEM::INFO-AUX COMMON-LISP::NTH SYSTEM::QUOTATION-READER - SYSTEM::CHECK-SEQ-START-END COMMON-LISP::LOGNAND - SYSTEM::SUBSTRINGP COMMON-LISP::LOGORC2 - ANSI-LOOP::LOOP-NOTE-MINIMAX-OPERATION SYSTEM::SAFE-EVAL - ANSI-LOOP::LOOP-DO-IF SLOOP::THEREIS-SLOOP-COLLECT - SYSTEM::MATCH-DIMENSIONS SYSTEM::GET-MATCH - SYSTEM::SUB-INTERVAL-P FPE::PAREN-READER - SLOOP::IN-TABLE-SLOOP-MAP COMMON-LISP::LOGTEST - SLOOP::LOGXOR-SLOOP-COLLECT SYSTEM::DM-V - SYSTEM::GET-INFO-CHOICES SLOOP::COLLATE-SLOOP-COLLECT - SYSTEM::BREAK-STEP-NEXT ANSI-LOOP::LOOP-TEQUAL - COMMON-LISP::WRITE-BYTE COMMON-LISP::NTHCDR - SYSTEM::SETF-HELPER SLOOP::NEVER-SLOOP-COLLECT SLOOP::DESETQ1 - ANSI-LOOP::LOOP-DO-WHILE COMMON-LISP::DOCUMENTATION - FPE::%-READER SYSTEM::IN-INTERVAL-P SLOOP::SUM-SLOOP-COLLECT - SYSTEM::OBJLT COMMON-LISP::LDB-TEST SLOOP::PARSE-LOOP-MAP - SYSTEM::GET-NODES SLOOP::MAKE-VALUE SYSTEM::CONDITION-PASS - SLOOP::IN-PACKAGE-SLOOP-MAP SYSTEM::INCREMENT-CURSOR - ANSI-LOOP::LOOP-DO-ALWAYS SYSTEM::DISPLAY-ENV SYSTEM::SUPER-GO - SLOOP::MINIMIZE-SLOOP-COLLECT COMMON-LISP::LOGNOR - COMMON-LISP::LOGANDC1 COMMON-LISP::BYTE SYSTEM::DBL-UP - SYSTEM::ITERATE-OVER-BKPTS COMMON-LISP::LOGORC1 - FPE::READ-OPERANDS SLOOP::ALWAYS-SLOOP-COLLECT - SYSTEM::SETF-EXPAND SYSTEM::OVERWRITE-SLOT-DESCRIPTIONS - SYSTEM::*BREAK-POINTS* SYSTEM::LOOKUP-KEYWORD - ANSI-LOOP::LOOP-TASSOC SYSTEM::LEFT-PARENTHESIS-READER - SLOOP::=-SLOOP-FOR FPE::READ-INSTRUCTION COMMON-LISP::COERCE - SYSTEM::SEQUENCE-CURSOR)) + (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T) + SYSTEM::IHS-NOT-INTERPRETED-ENV COMMON-LISP::NINTH + SYSTEM::FIND-KCL-TOP-RESTART COMMON-LISP::TRUENAME + SYSTEM::DIRECTORY-LIST-CHECK SYSTEM::REAL-ASINH + SYSTEM::SHOW-ENVIRONMENT SYSTEM::PRINT-FRS + SYSTEM::REWRITE-RESTART-CASE-CLAUSE + COMMON-LISP::TWO-WAY-STREAM-OUTPUT-STREAM + ANSI-LOOP::LOOP-COLLECTOR-DATA SLOOP::POINTER-FOR-COLLECT + SYSTEM::MLP SYSTEM::WILD-PATH-ELEMENT-P SYSTEM::LNP + ANSI-LOOP::LOOP-MINIMAX-OPERATIONS SYSTEM::FRS-KIND + SYSTEM::BKPT-FILE COMMON-LISP::FIFTH + ANSI-LOOP::LOOP-COLLECTOR-P ANSI-LOOP::LOOP-UNIVERSE-ANSI + ANSI-LOOP::LOOP-PATH-PREPOSITION-GROUPS SYSTEM::IDESCRIBE + ANSI-LOOP::LOOP-CONSTANTP + ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS COMMON-LISP::PROBE-FILE + ANSI-LOOP::LOOP-UNIVERSE-P COMMON-LISP::SINH SYSTEM::RESTART-P + SYSTEM::S-DATA-DOCUMENTATION + COMMON-LISP::ECHO-STREAM-OUTPUT-STREAM + SYSTEM::FIND-DOCUMENTATION SYSTEM::INFO-GET-FILE + SLOOP::PARSE-NO-BODY COMMON-LISP::FILE-NAMESTRING + COMMON-LISP::COMPILER-MACRO-FUNCTION SYSTEM::PROCESS-ARGS + ANSI-LOOP::LOOP-COLLECTOR-DTYPE COMMON-LISP::PHASE + SYSTEM::MAKE-FRAME SYSTEM::INSTREAM-STREAM + ANSI-LOOP::LOOP-COLLECTOR-HISTORY SYSTEM::FIX-LOAD-PATH + SYSTEM::COMPUTING-ARGS-P + ANSI-LOOP::LOOP-MINIMAX-ANSWER-VARIABLE COMMON-LISP::TENTH + ANSI-LOOP::MAKE-ANSI-LOOP-UNIVERSE SYSTEM::WILD-NAMESTRING-P + SYSTEM::BEST-ARRAY-ELEMENT-TYPE SYSTEM::DM-BAD-KEY + SYSTEM::TERMINAL-INTERRUPT SYSTEM::REGEXP-CONV + COMMON-LISP::FILE-WRITE-DATE SLOOP::PARSE-LOOP + ANSI-LOOP::LOOP-CONSTRUCT-RETURN SYSTEM::DWIM + ANSI-LOOP::LOOP-UNIVERSE-TYPE-KEYWORDS + SLOOP::RETURN-SLOOP-MACRO SLOOP::AVERAGING-SLOOP-MACRO + SYSTEM::S-DATA-NAME SYSTEM::CHECK-TRACE-SPEC + SYSTEM::RESTRICT-STREAM-ELEMENT-TYPE SLOOP::TRANSLATE-NAME + SYSTEM::ADD-TO-HOTLIST SYSTEM::S-DATA-CONC-NAME + ANSI-LOOP::LOOP-MINIMAX-TYPE SYSTEM::PRINT-IHS + SYSTEM::DBL-RPL-LOOP SYSTEM::CANONICALIZE-PATHNAME-DIRECTORY + SYSTEM::INSPECT-CONS SYSTEM::INSTREAM-STREAM-NAME + SYSTEM::S-DATA-P SYSTEM::EVAL-FEATURE + COMMON-LISP::ARRAY-DIMENSIONS SYSTEM::IHS-VISIBLE + ANSI-LOOP::LOOP-MINIMAX-FLAG-VARIABLE + SYSTEM::CHECK-DECLARATIONS COMMON-LISP::TANH + ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS + COMMON-LISP::COMPILE-FILE-PATHNAME SYSTEM::INSPECT-PACKAGE + SLOOP::LOOP-LET-BINDINGS COMMON-LISP::CIS SYSTEM::SETUP-INFO + SYSTEM::NORMALIZE-TYPE ANSI-LOOP::LOOP-PSEUDO-BODY + SYSTEM::PATH-STREAM-NAME SYSTEM::INFO-GET-TAGS FPE::ST-LOOKUP + SYSTEM::BREAK-BACKWARD-SEARCH-STACK + ANSI-LOOP::LOOP-MINIMAX-TEMP-VARIABLE SYSTEM::SIMPLE-ARRAY-P + SYSTEM::S-DATA-TYPE COMMON-LISP::CONCATENATED-STREAM-STREAMS + SYSTEM::INSPECT-CHARACTER ANSI-LOOP::DESTRUCTURING-SIZE + SYSTEM::GET-BYTE-STREAM-NCHARS ANSI-LOOP::LOOP-PATH-P + COMMON-LISP::FIRST COMMON-LISP::SECOND + COMMON-LISP::TWO-WAY-STREAM-INPUT-STREAM + SYSTEM::MAKE-DEFPACKAGE-FORM SYSTEM::INSPECT-SYMBOL + SYSTEM::INSPECT-VECTOR + COMMON-LISP::LOAD-LOGICAL-PATHNAME-TRANSLATIONS + SYSTEM::RESTART-INTERACTIVE-FUNCTION SYSTEM::INSPECT-STRING + SYSTEM::DIR-P ANSI-LOOP::LOOP-COLLECTOR-CLASS + SYSTEM::S-DATA-CONSTRUCTORS SYSTEM::NODES-FROM-INDEX + SYSTEM::VERSION-PARSE SYSTEM::BKPT-FILE-LINE COMMON-LISP::ABS + SYSTEM::IHS-FNAME ANSI-LOOP::LOOP-MAKE-PSETQ + SYSTEM::LEAP-YEAR-P ANSI-LOOP::LOOP-EMIT-FINAL-VALUE + SYSTEM::GET-PATH SYSTEM::ALOAD SYSTEM::DM-KEY-NOT-ALLOWED + SYSTEM::MAKE-KCL-TOP-RESTART SYSTEM::S-DATA-SLOT-DESCRIPTIONS + COMMON-LISP::VECTOR-POP ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS + ANSI-LOOP::LOOP-PATH-USER-DATA SYSTEM::S-DATA-SLOT-POSITION + COMMON-LISP::BROADCAST-STREAM-STREAMS + SYSTEM::LOGICAL-PATHNAMEP SYSTEM::BREAK-FORWARD-SEARCH-STACK + SLOOP::SLOOP-SLOOP-MACRO COMMON-LISP::SIGNUM + SYSTEM::RESET-TRACE-DECLARATIONS SYSTEM::CONTEXT-P + SYSTEM::S-DATA-FROZEN SYSTEM::NUMBER-OF-DAYS-FROM-1900 + SYSTEM::S-DATA-STATICP ANSI-LOOP::LOOP-PATH-FUNCTION + SYSTEM::KNOWN-TYPE-P COMMON-LISP::PROVIDE SYSTEM::PNL1 + ANSI-LOOP::LOOP-CODE-DUPLICATION-THRESHOLD + SYSTEM::COERCE-SLASH-TERMINATED COMMON-LISP::LOGICAL-PATHNAME + SYSTEM::DIR-CONJ SYSTEM::BKPT-FORM + SYSTEM::LOGICAL-PATHNAME-HOST-P SYSTEM::INSPECT-STRUCTURE + ANSI-LOOP::LOOP-UNIVERSE-IMPLICIT-FOR-REQUIRED + COMMON-LISP::FIND-ALL-SYMBOLS + ANSI-LOOP::LOOP-UNIVERSE-ITERATION-KEYWORDS + ANSI-LOOP::LOOP-PATH-INCLUSIVE-PERMITTED + COMMON-LISP::LOGICAL-PATHNAME-TRANSLATIONS + SYSTEM::TRACE-ONE-PREPROCESS COMMON-LISP::CONSTANTLY + COMMON-LISP::ACOS SYSTEM::S-DATA-OFFSET COMMON-LISP::ASINH + SYSTEM::SHORT-NAME SYSTEM::S-DATA-INCLUDED SYSTEM::DBL-EVAL + SYSTEM::BKPT-FUNCTION SYSTEM::INSPECT-NUMBER + SYSTEM::GET-INSTREAM SYSTEM::SHOW-BREAK-POINT FPE::LOOKUP + SYSTEM::NEXT-STACK-FRAME SYSTEM::INSPECT-ARRAY + SYSTEM::S-DATA-RAW ANSI-LOOP::LOOP-MINIMAX-INFINITY-DATA + SYSTEM::RESTART-REPORT-FUNCTION SYSTEM::TOGGLE-CASE + SYSTEM::NODE-OFFSET SYSTEM::INSTREAM-P + ANSI-LOOP::LOOP-PATH-NAMES SYSTEM::FREEZE-DEFSTRUCT + COMMON-LISP::SEVENTH SYSTEM::SEARCH-STACK COMMON-LISP::SIXTH + ANSI-LOOP::LOOP-UNIVERSE-TYPE-SYMBOLS FPE::GREF + FPE::XMM-LOOKUP COMMON-LISP::HOST-NAMESTRING + ANSI-LOOP::LOOP-TYPED-INIT + SYSTEM::LOGICAL-PATHNAME-DESIGNATOR-P + ANSI-LOOP::LOOP-DO-THEREIS COMMON-LISP::EIGHTH + SYSTEM::UNIQUE-ID COMMON-LISP::THIRD + COMMON-LISP::BYTE-POSITION COMMON-LISP::SYNONYM-STREAM-SYMBOL + SYSTEM::PATCH-SHARP SYSTEM::PRINT-SYMBOL-APROPOS + COMMON-LISP::LOGNOT SLOOP::REPEAT-SLOOP-MACRO + COMMON-LISP::FOURTH SLOOP::SUBSTITUTE-SLOOP-BODY + COMMON-LISP::ATANH SLOOP::LOOP-COLLECT-KEYWORD-P + SYSTEM::SEQTYPE SYSTEM::RE-QUOTE-STRING COMMON-LISP::ISQRT + SYSTEM::DO-F SYSTEM::S-DATA-HAS-HOLES + ANSI-LOOP::LOOP-HACK-ITERATION ANSI-LOOP::LOOP-COLLECTOR-NAME + COMMON-LISP::RESTART-NAME COMMON-LISP::DIRECTORY-NAMESTRING + ANSI-LOOP::LOOP-EMIT-BODY COMMON-LISP::ACOSH + SYSTEM::RESTART-FUNCTION SYSTEM::INFO-NODE-FROM-POSITION + COMMON-LISP::ASIN ANSI-LOOP::LOOP-LIST-COLLECTION + SYSTEM::S-DATA-INCLUDES SYSTEM::GET-NEXT-VISIBLE-FUN + COMMON-LISP::BYTE-SIZE COMMON-LISP::PATHNAME + ANSI-LOOP::LOOP-MINIMAX-P SLOOP::PARSE-LOOP-INITIALLY + COMMON-LISP::COSH SYSTEM::EXPAND-HOME-DIR + COMMON-LISP::ECHO-STREAM-INPUT-STREAM + SYSTEM::INSERT-BREAK-POINT SYSTEM::RESTART-TEST-FUNCTION + SYSTEM::S-DATA-PRINT-FUNCTION SYSTEM::WILD-DIR-ELEMENT-P + SYSTEM::S-DATA-NAMED COMMON-LISP::INVOKE-DEBUGGER + COMMON-LISP::NAMESTRING ANSI-LOOP::LOOP-MAKE-DESETQ + COMMON-LISP::COMPLEMENT SYSTEM::WALK-THROUGH + COMMON-LISP::RATIONAL ANSI-LOOP::LOOP-MAXMIN-COLLECTION + COMMON-LISP::DELETE-FILE ANSI-LOOP::LOOP-COLLECTOR-TEMPVARS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) - COMMON-LISP::*) - COMMON-LISP::FFLOOR SYSTEM::BREAK-FUNCTION - COMMON-LISP::APROPOS-LIST COMMON-LISP::DECODE-UNIVERSAL-TIME - SYSTEM::STEPPER COMMON-LISP::REQUIRE SYSTEM::APROPOS-DOC - SYSTEM::PRINT-DOC SYSTEM::INFO COMMON-LISP::USE-VALUE - COMMON-LISP::WRITE-TO-STRING COMMON-LISP::FCEILING - SYSTEM::GET-SETF-METHOD - ANSI-LOOP::LOOP-CONSTANT-FOLD-IF-POSSIBLE SYSTEM::NLOAD - COMMON-LISP::ENSURE-DIRECTORIES-EXIST - COMMON-LISP::WILD-PATHNAME-P COMMON-LISP::FTRUNCATE - COMMON-LISP::FROUND SYSTEM::PARSE-BODY-HEADER - COMMON-LISP::INVOKE-RESTART SYSTEM::SHOW-INFO - COMMON-LISP::READ-FROM-STRING - SYSTEM::GET-SETF-METHOD-MULTIPLE-VALUE COMMON-LISP::APROPOS - COMMON-LISP::STORE-VALUE)) + (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*) + SYSTEM::BREAK-QUIT SYSTEM::BREAK-BDS SYSTEM::DBL-BACKTRACE + SYSTEM::BREAK-LOCAL SYSTEM::INFO-ERROR + SYSTEM::SHOW-BREAK-VARIABLES SYSTEM::BREAK-VS + COMMON-LISP::CONTINUE COMMON-LISP::MUFFLE-WARNING + SYSTEM::IHS-BACKTRACE ANSI-LOOP::LOOP-OPTIONAL-TYPE + SYSTEM::BREAK-PREVIOUS SYSTEM::BREAK-NEXT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T) - ANSI-LOOP::LOOP-DO-WITH SYSTEM::WINE-TMP-REDIRECT - SLOOP::PARSE-ONE-WHEN-CLAUSE COMMON-LISP::TYPE-ERROR - SYSTEM::INSPECT-INDENT SYSTEM::SET-CURRENT SYSTEM::TEST-ERROR - SLOOP::LOOP-POP ANSI-LOOP::LOOP-DO-REPEAT - ANSI-LOOP::LOOP-GET-PROGN SYSTEM::DM-TOO-FEW-ARGUMENTS - ANSI-LOOP::LOOP-CONTEXT SYSTEM::READ-EVALUATED-FORM - SYSTEM::ALL-TRACE-DECLARATIONS - COMMON-LISP::LISP-IMPLEMENTATION-VERSION - SYSTEM::DEFAULT-SYSTEM-BANNER ANSI-LOOP::LOOP-DO-RETURN - SYSTEM::INSPECT-INDENT-1 SYSTEM::STEP-READ-LINE - SYSTEM::SET-ENV SYSTEM::DM-TOO-MANY-ARGUMENTS - ANSI-LOOP::LOOP-BIND-BLOCK SLOOP::PARSE-LOOP1 - ANSI-LOOP::LOOP-DO-NAMED SLOOP::PARSE-LOOP-COLLECT - SYSTEM::KCL-TOP-RESTARTS SYSTEM::INSPECT-READ-LINE - SYSTEM::SET-UP-TOP-LEVEL SYSTEM::SHOW-RESTARTS SYSTEM::DBL - SLOOP::PARSE-LOOP-FOR ANSI-LOOP::LOOP-ITERATION-DRIVER - ANSI-LOOP::LOOP-WHEN-IT-VARIABLE ANSI-LOOP::LOOP-DO-DO - SYSTEM::DEFAULT-INFO-HOTLIST SYSTEM::GET-TEMP-DIR - ANSI-LOOP::LOOP-POP-SOURCE SLOOP::LOOP-UN-POP - SYSTEM::TOP-LEVEL ANSI-LOOP::LOOP-DO-FINALLY - ANSI-LOOP::LOOP-DO-INITIALLY SYSTEM::GET-INDEX-NODE - SYSTEM::SETUP-LINEINFO SLOOP::PARSE-LOOP-WHEN SYSTEM::CLEANUP - ANSI-LOOP::LOOP-GET-FORM SLOOP::PARSE-LOOP-DO - SYSTEM::INIT-BREAK-POINTS SLOOP::LOOP-PEEK - SYSTEM::GET-SIG-FN-NAME SYSTEM::ILLEGAL-BOA)) -(COMMON-LISP::PROCLAIM - '(COMMON-LISP::FTYPE - (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM COMMON-LISP::T) + (COMMON-LISP::FUNCTION + ((COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807) + COMMON-LISP::T) COMMON-LISP::T) SYSTEM::SMALLNTHCDR)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::T) + COMMON-LISP::HASH-TABLE) + SYSTEM::CONTEXT-SPICE)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FIXNUM) + SYSTEM::S-DATA-SIZE FPE::REG-LOOKUP SYSTEM::INSTREAM-LINE + SYSTEM::S-DATA-LENGTH SYSTEM::THE-START)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM) COMMON-LISP::T) + SYSTEM::MATCH-BEGINNING SYSTEM::MATCH-END)) +(COMMON-LISP::MAPC + (COMMON-LISP::LAMBDA (COMPILER::X) + (COMMON-LISP::SETF + (COMMON-LISP::GET COMPILER::X 'COMPILER::PROCLAIMED-CLOSURE) + COMMON-LISP::T)) + '(SYSTEM::CONDITION-CLASS-P SYSTEM::WARNINGP SYSTEM::SI-CLASS-OF + SYSTEM::SI-FIND-CLASS SYSTEM::DEFINE-STRUCTURE + FPE::BREAK-ON-FLOATING-POINT-EXCEPTIONS + SYSTEM::SIMPLE-CONDITION-CLASS-P SYSTEM::AUTOLOAD + SYSTEM::SI-CLASS-PRECEDENCE-LIST SYSTEM::SI-CLASS-NAME + SYSTEM::TRACE-ONE SYSTEM::MAKE-ACCESS-FUNCTION + SYSTEM::UNTRACE-ONE SYSTEM::SI-CLASSP SYSTEM::CONDITIONP + SYSTEM::AUTOLOAD-MACRO)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION + ((COMMON-LISP::INTEGER -9223372036854775808 + 9223372036854775807)) + COMMON-LISP::T) + SYSTEM::GET-CONTEXT SYSTEM::PUSH-CONTEXT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::FIXNUM) - SYSTEM::THE-END ANSI-LOOP::DUPLICATABLE-CODE-P - SYSTEM::RELATIVE-LINE SYSTEM::GET-NODE-INDEX)) + SYSTEM::RELATIVE-LINE SYSTEM::LENEL SYSTEM::THE-END + ANSI-LOOP::DUPLICATABLE-CODE-P SYSTEM::FASLINK + SYSTEM::GET-NODE-INDEX)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T) + SLOOP::PARSE-ONE-WHEN-CLAUSE ANSI-LOOP::LOOP-DO-FINALLY + SLOOP::LOOP-PEEK ANSI-LOOP::LOOP-DO-INITIALLY SLOOP::LOOP-POP + ANSI-LOOP::LOOP-GET-PROGN SYSTEM::KCL-TOP-RESTARTS + SYSTEM::INSPECT-READ-LINE SLOOP::PARSE-LOOP-WHEN + ANSI-LOOP::LOOP-GET-FORM SYSTEM::DEFAULT-SYSTEM-BANNER + SYSTEM::SET-UP-TOP-LEVEL SYSTEM::GET-INDEX-NODE + ANSI-LOOP::LOOP-DO-DO ANSI-LOOP::LOOP-WHEN-IT-VARIABLE + SYSTEM::SETUP-LINEINFO COMMON-LISP::TYPE-ERROR + SYSTEM::READ-EVALUATED-FORM SYSTEM::INSPECT-INDENT-1 + SLOOP::LOOP-UN-POP SLOOP::PARSE-LOOP-DO + ANSI-LOOP::LOOP-DO-WITH SYSTEM::INSPECT-INDENT + SYSTEM::GET-TEMP-DIR ANSI-LOOP::LOOP-ITERATION-DRIVER + SYSTEM::WINE-TMP-REDIRECT SLOOP::PARSE-LOOP-COLLECT + SYSTEM::DEFAULT-INFO-HOTLIST SLOOP::PARSE-LOOP1 + SYSTEM::CLEANUP ANSI-LOOP::LOOP-DO-NAMED SYSTEM::DBL + SYSTEM::ALL-TRACE-DECLARATIONS SYSTEM::TEST-ERROR + ANSI-LOOP::LOOP-BIND-BLOCK ANSI-LOOP::LOOP-DO-REPEAT + SYSTEM::ILLEGAL-BOA SYSTEM::SET-ENV SYSTEM::SET-CURRENT + SYSTEM::INIT-BREAK-POINTS SYSTEM::GET-SIG-FN-NAME + ANSI-LOOP::LOOP-DO-RETURN ANSI-LOOP::LOOP-CONTEXT + SYSTEM::SHOW-RESTARTS SYSTEM::STEP-READ-LINE + SLOOP::PARSE-LOOP-FOR SYSTEM::DM-TOO-MANY-ARGUMENTS + COMMON-LISP::LISP-IMPLEMENTATION-VERSION SYSTEM::TOP-LEVEL + ANSI-LOOP::LOOP-POP-SOURCE SYSTEM::DM-TOO-FEW-ARGUMENTS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION - (COMMON-LISP::FIXNUM COMMON-LISP::FIXNUM) - COMMON-LISP::FIXNUM) - SYSTEM::ROUND-UP)) + ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER + COMMON-LISP::*)) + COMMON-LISP::T) + SYSTEM::RESET-SYS-PATHS)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION (COMMON-LISP::T) + (COMMON-LISP::VECTOR COMMON-LISP::T)) + SYSTEM::CONTEXT-VEC)) +(COMMON-LISP::PROCLAIM + '(COMMON-LISP::FTYPE + (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::*) + SYSTEM::BREAK-HELP SYSTEM::BREAK-MESSAGE + SYSTEM::SIMPLE-BACKTRACE ANSI-LOOP::LOOP-DO-FOR + SYSTEM::BREAK-CURRENT SYSTEM::GCL-TOP-LEVEL + SYSTEM::BREAK-RESUME)) \ No newline at end of file diff --git a/o/alloc.c b/o/alloc.c index 5f21529..5d3737c 100644 --- a/o/alloc.c +++ b/o/alloc.c @@ -447,7 +447,6 @@ 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; - if (r && 2*n+page(rb_start)>real_maxpage) return 0; available_pages-=z; tm->tm_adjgbccnt*=((double)j+1)/(n+1); tm->tm_maxpage=n; @@ -909,7 +908,7 @@ alloc_after_reclaiming_pages(struct typemanager *tm,fixnum n) { fixnum m=tpage(tm,n),reloc_min; - if (tm->tm_type>=t_end) return NULL; + if (tm->tm_type>t_end) return NULL; reloc_min=npage(rb_pointer-rb_start); @@ -925,6 +924,8 @@ alloc_after_reclaiming_pages(struct typemanager *tm,fixnum 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); @@ -1093,8 +1094,7 @@ DEFUNM_NEW("ALLOCATED",object,fSallocated,SI,1,1,NONE,OO,OO,OO,OO,(object typ)," 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)) - )); + RV(make_fixnum(tm->tm_npage*tm->tm_nppage-tm->tm_nfree)))); } #ifdef SGC_CONT_DEBUG @@ -1658,7 +1658,7 @@ DEFUN_NEW("GPROF-QUIT",object,fSgprof_quit,SI massert(getcwd(b,sizeof(b))); massert(!chdir(P_tmpdir)); _mcleanup(); - massert(snprintf(b1,sizeof(b1),"gprof %s",kcl_self)>0); + massert(snprintf(b1,sizeof(b1),"gprof '%s'",kcl_self)>0); massert((pp=popen(b1,"r"))); while ((n=fread(b1,1,sizeof(b1),pp))) massert(fwrite(b1,1,n,stdout)); diff --git a/o/array.c b/o/array.c index 6c4d5d7..6ef9947 100755 --- a/o/array.c +++ b/o/array.c @@ -1139,9 +1139,9 @@ Icheck_displaced(object displaced_list, object ar, int dim) /* } */ /* } */ -DEFUNO_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, - OO,OO,OO,OO,void,siLreplace_array,(object old,object new),"") -{ struct dummy fw ; +DEFUN_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,OO,OO,OO,OO,(object old,object new),"") { + + struct dummy fw; fw = old->d; old = IisArray(old); diff --git a/o/bind.c b/o/bind.c index fd5f2b0..748c2e3 100755 --- a/o/bind.c +++ b/o/bind.c @@ -24,7 +24,6 @@ Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "include.h" -#include static void illegal_lambda(void); @@ -95,17 +94,19 @@ lambda_bind(object *arg_top) struct aux *aux=NULL; int naux; bool special_processed; + object s[1],ss; vs_mark; bds_check; lambda = vs_head; - if (type_of(lambda) != t_cons) + 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; @@ -152,7 +153,7 @@ OPTIONAL: goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; - if (type_of(x) == t_cons) { + if (consp(x)) { check_symbol(x->c.c_car); check_var(x->c.c_car); vs_push(x->c.c_car); @@ -226,9 +227,9 @@ KEYWORD: goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; - if (type_of(x) == t_cons) { - if (type_of(x->c.c_car) == t_cons) { - if (!keywordp(x->c.c_car->c.c_car)) + 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); @@ -296,7 +297,7 @@ AUX_L: goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; - if (type_of(x) == t_cons) { + if (consp(x)) { check_symbol(x->c.c_car); check_var(x->c.c_car); vs_push(x->c.c_car); @@ -336,10 +337,10 @@ SEARCH_DECLARE: break; continue; } - if (type_of(form)!=t_cons || !isdeclare(form->c.c_car)) + if (!consp(form) || !isdeclare(form->c.c_car)) break; for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { - if (type_of(ds->c.c_car) != t_cons) + 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; @@ -381,8 +382,7 @@ SEARCH_DECLARE: } if (special_processed) continue; - /* lex_special_bind(v); */ - lex_env[0] = MMcons(MMcons(v, Cnil), lex_env[0]); + s[0] = MMcons(MMcons(v, Cnil), s[0]); /**/ } @@ -437,17 +437,20 @@ SEARCH_DECLARE: bind_var(rest->rest_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 (!keywordp(base[i])) + if (type_of(base[i])!=t_symbol) FEunexpected_keyword(base[i]); - if (base[i] == sKallow_other_keys && - base[i+1] != Cnil) + 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 @@ -460,7 +463,8 @@ SEARCH_DECLARE: goto NEXT_ARG; } } - other_keys_appeared = TRUE; + if (base[i] != sKallow_other_keys) + other_keys_appeared = TRUE; NEXT_ARG: continue; @@ -492,7 +496,7 @@ SEARCH_DECLARE: eval_assign(temporary, aux[i].aux_init); bind_var(aux[i].aux_var, temporary, aux[i].aux_spp); } - if (type_of(body) != t_cons || body->c.c_car == form) { + if (!consp(body) || body->c.c_car == form) { vs_reset; vs_head = body; } else { @@ -500,6 +504,13 @@ SEARCH_DECLARE: 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: @@ -515,10 +526,10 @@ REQUIRED_ONLY: break; continue; } - if (type_of(form)!=t_cons || !isdeclare(form->c.c_car)) + if (!consp(form) || !isdeclare(form->c.c_car)) break; for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { - if (type_of(ds->c.c_car) != t_cons) + 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; @@ -537,7 +548,7 @@ REQUIRED_ONLY: continue; /* lex_special_bind(v); */ temporary = MMcons(v, Cnil); - lex_env[0] = MMcons(temporary, lex_env[0]); + s[0] = MMcons(temporary, s[0]); /**/ } @@ -555,7 +566,7 @@ REQUIRED_ONLY: bind_var(required[i].req_var, base[i], required[i].req_spp); - if (type_of(body) != t_cons || body->c.c_car == form) { + if (!consp(body) || body->c.c_car == form) { vs_reset; vs_head = body; } else { @@ -563,6 +574,13 @@ REQUIRED_ONLY: 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 @@ -612,7 +630,7 @@ struct bind_temp { */ object -find_special(object body, struct bind_temp *start, struct bind_temp *end) +find_special(object body, struct bind_temp *start, struct bind_temp *end,object *s) { object temporary; object form=Cnil; @@ -622,6 +640,7 @@ find_special(object body, struct bind_temp *start, struct bind_temp *end) vs_mark; vs_push(Cnil); + s=s ? s : lex_env; for (; !endp(body); body = body->c.c_cdr) { form = body->c.c_car; @@ -634,10 +653,10 @@ find_special(object body, struct bind_temp *start, struct bind_temp *end) break; continue; } - if (type_of(form)!=t_cons || !isdeclare(form->c.c_car)) + if (!consp(form) || !isdeclare(form->c.c_car)) break; for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { - if (type_of(ds->c.c_car) != t_cons) + 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; @@ -655,14 +674,14 @@ find_special(object body, struct bind_temp *start, struct bind_temp *end) continue; /* lex_special_bind(v); */ temporary = MMcons(v, Cnil); - lex_env[0] = MMcons(temporary, lex_env[0]); + s[0] = MMcons(temporary, s[0]); /**/ } } } } - if (body != Cnil && body->c.c_car != form) + 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); @@ -674,10 +693,10 @@ let_bind(object body, struct bind_temp *start, struct bind_temp *end) struct bind_temp *bt; bds_check; - vs_push(find_special(body, start, end)); 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); } @@ -688,13 +707,20 @@ object letA_bind(object body, struct bind_temp *start, struct bind_temp *end) { struct bind_temp *bt; - + object s[1],ss; + bds_check; - vs_push(find_special(body, start, end)); + 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); } @@ -703,12 +729,12 @@ letA_bind(object body, struct bind_temp *start, struct bind_temp *end) #endif -#define NOT_YET 10 -#define FOUND 11 +#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, ...) +parse_key(object *base, bool rest, bool allow_other_keys, int n, ...) { object temporary; va_list ap; @@ -735,7 +761,7 @@ parse_key(object *base, bool rest, bool allow_other_keys,int n, ...) FEunexpected_keyword(Cnil); if (narg == 2) { k = base[0]; - if (!keywordp(k)) + if (type_of(k)!=t_symbol) FEunexpected_keyword(k); if (k == sKallow_other_keys && ! allow_other_keys_found) { allow_other_keys_found=1; @@ -777,7 +803,7 @@ parse_key(object *base, bool rest, bool allow_other_keys,int n, ...) va_end(ap); for (v = base; v < vs_top; v += 2) { k = v[0]; - if (!keywordp(k)) { + if (type_of(k)!=t_symbol) { error_flag = NOT_KEYWORD; other_key = k; continue; @@ -827,16 +853,19 @@ check_other_key(object l, int n, ...) 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 (!keywordp(k)) + 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 && l->c.c_cdr->c.c_car != Cnil) { - allow_other_keys = TRUE; + 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); @@ -1110,7 +1139,7 @@ gcl_init_bind(void) make_cons(make_ordinary("&BODY"), Cnil))))))))); make_constant("LAMBDA-PARAMETERS-LIMIT", - make_fixnum(64)); + make_fixnum(MAX_ARGS+1)); diff --git a/o/error.c b/o/error.c index 3d20c12..c9f855c 100755 --- a/o/error.c +++ b/o/error.c @@ -490,49 +490,78 @@ vfun_wrong_number_of_args(object x) void -check_arg_range(int n, int m) -{ - object x,x1; +check_arg_range(int n, int m) { - x=make_fixnum(n); - x1=make_fixnum(VFUN_NARGS); if (VFUN_NARGS < n) - Icall_error_handler( - sKtoo_few_arguments, - make_simple_string("Needed at least ~D args, but received ~d"), - 2,x,x1); - else if (VFUN_NARGS > m) - Icall_error_handler( - sKtoo_many_arguments, - make_simple_string("Needed no more than ~D args, but received ~d"), - 2,x,x1); - } + FEtoo_few_arguments(0,VFUN_NARGS); + if (VFUN_NARGS > m) + FEtoo_many_arguments(0,VFUN_NARGS); + +} DEF_ORDINARY("TERMINAL-INTERRUPT",sSterminal_interrupt,SI,""); -DEF_ORDINARY("WRONG-TYPE-ARGUMENT",sKwrong_type_argument,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("DATUM",sKdatum,KEYWORD,""); -DEF_ORDINARY("EXPECTED-TYPE",sKexpected_type,KEYWORD,""); -DEF_ORDINARY("PACKAGE",sKpackage,KEYWORD,""); -DEF_ORDINARY("FORMAT-CONTROL",sKformat_control,KEYWORD,""); -DEF_ORDINARY("FORMAT-ARGUMENTS",sKformat_arguments,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_init_error(void) { + null_string = make_simple_string(""); + enter_mark_origin(&null_string); } diff --git a/o/fasdump.c b/o/fasdump.c index c03be3d..b9d0e8f 100755 --- a/o/fasdump.c +++ b/o/fasdump.c @@ -1501,14 +1501,12 @@ read_fasl_vector(object in) object d; int tem; if (((tem=getc(((FILE *)in->sm.sm_fp))) == EOF) && feof(((FILE *)in->sm.sm_fp))) - { d = coerce_to_pathname(in); - d = make_pathname(d->pn.pn_host, - d->pn.pn_device, - d->pn.pn_directory, - d->pn.pn_name, - make_simple_string("data"), - d->pn.pn_version); - d = coerce_to_namestring(d); + { char *pf; + coerce_to_filename(in,FN1); + for (pf=FN1+strlen(FN1);pf>FN1 && pf[-1]!='.';pf--); + if (pf==FN1) {pf=FN1+strlen(FN1);*pf++='.';} + snprintf(pf,sizeof(FN1)-(pf-FN1),"data"); + d=make_simple_string(FN1); in = open_stream(d,smm_input,Cnil,Cnil); if (in == Cnil) FEerror("Can't open file ~s",1,d); diff --git a/o/file.d b/o/file.d index 1c67e15..9b9269c 100755 --- a/o/file.d +++ b/o/file.d @@ -138,7 +138,7 @@ void end_of_stream(strm) object strm; { - FEerror("Unexpected end of ~S.", 1, strm); + END_OF_FILE(strm); } /* @@ -167,6 +167,7 @@ BEGIN: 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) @@ -223,6 +224,7 @@ BEGIN: 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) @@ -270,6 +272,7 @@ BEGIN: 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) @@ -341,220 +344,208 @@ cannot_create(object); Fn is a namestring. */ object -open_stream(fn, smm, if_exists, if_does_not_exist) -object fn; -enum smmode smm; -object if_exists, if_does_not_exist; -{ - object x; - FILE *fp=NULL; - char fname[PATH_MAX]; - object unzipped = 0; - vs_mark; +open_stream(object fn,enum smmode smm, object if_exists, object if_does_not_exist) { -/* - if (type_of(fn) != t_string) - FEwrong_type_argument(sLstring, fn); -*/ - /* if (fn->st.st_fillp > BUFSIZ - 1) */ - /* too_long_file_name(fn); */ - /* for (i = 0; i < fn->st.st_fillp; i++) */ - /* fname[i] = fn->st.st_self[i]; */ - - /* fname[i] = '\0'; */ - coerce_to_filename(fn,fname); - if (smm == smm_input || smm == smm_probe) { - if(fname[0]=='|') - fp = popen(fname+1,"r"); - else - fp = fopen_not_dir(fname, "r"); - - AGAIN: - if (fp == NULL) { - if (sSAallow_gzipped_fileA->s.s_dbind != sLnil) - { - static struct string st; - char buf[256]; - if (snprintf(buf,sizeof(buf),"%s.gz",fname)<=0) - FEerror("Cannot write .gz filename",0); - st.st_self=buf; - st.st_dim=st.st_fillp=strlen(buf); - set_type_of(&st,t_string); - if (file_exists((object)&st)) { - FILE *pp; - int n; - if (!(fp=tmpfile())) - FEerror("Cannot create temporary file",0); - if (snprintf(buf,sizeof(buf),"zcat %s.gz",fname)<=0) - FEerror("Cannot write zcat pipe name",0); - if (!(pp=popen(buf,"r"))) - FEerror("Cannot open zcat pipe",0); - while((n=fread(buf,1,sizeof(buf),pp))) - if (!fwrite(buf,1,n,fp)) - FEerror("Cannot write pipe output to temporary file",0); - if (pclose(pp)<0) - FEerror("Cannot close zcat pipe",0); - if (fseek(fp,0,SEEK_SET)) - FEerror("Cannot rewind temporary file\n",0); - goto AGAIN; - } - } - -/* fp = fopen_not_dir(buf,"r"); */ -/* if (fp) */ -/* { */ -/* #ifdef NO_MKSTEMP */ -/* char *tmp; */ -/* #else */ -/* char tmp[200]; */ -/* #endif */ -/* char command [500]; */ -/* fclose(fp); */ -/* #ifdef NO_MKSTEMP */ -/* tmp = tmpnam(0); */ -/* #else */ -/* snprintf(tmp,sizeof(tmp),"uzipXXXXXX"); */ - /* mkstemp(tmp); */ /* fixme: catch errors */ -/* #endif */ -/* unzipped = make_simple_string(tmp); */ -/* sprintf(command,"gzip -dc %s > %s",buf,tmp); */ -/* fp = 0; */ -/* if (0 == system(command)) */ -/* { */ -/* fp = fopen_not_dir(tmp,"r"); */ -/* if (fp) */ -/* goto AGAIN; */ -/* /\* should not get here *\/ */ -/* else { unlink(tmp);}} */ -/* }} */ - if (if_does_not_exist == sKerror) - cannot_open(fn); - else if (if_does_not_exist == sKcreate) { - fp = fopen_not_dir(fname, "w"); - if (fp == NULL) - cannot_create(fn); - fclose(fp); - fp = fopen_not_dir(fname, "r"); - if (fp == NULL) - 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); - } - } else if (smm == smm_output || smm == smm_io) { - if (if_exists == sKnew_version && if_does_not_exist == sKcreate) - goto CREATE; - fp = fopen_not_dir(fname, "r"); - if (fp != NULL) { - fclose(fp); - if (if_exists == sKerror) - FEerror("The file ~A already exists.", 1, fn); - else if (if_exists == sKrename) { - if (smm == smm_output) - fp = backup_fopen(fname, "w"); - else - fp = backup_fopen(fname, "w+"); - if (fp == NULL) - cannot_create(fn); - } else if (if_exists == sKrename_and_delete || - if_exists == sKnew_version || - if_exists == sKsupersede) { - if (smm == smm_output) - fp = fopen_not_dir(fname, "w"); - else - fp = fopen_not_dir(fname, "w+"); - if (fp == NULL) - cannot_create(fn); - } else if (if_exists == sKoverwrite) { - fp = fopen_not_dir(fname, "r+"); - if (fp == NULL) - cannot_open(fn); - } else if (if_exists == sKappend) { - if (smm == smm_output) - fp = fopen_not_dir(fname, "a"); - else - fp = fopen_not_dir(fname, "a+"); - if (fp == NULL) - 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) - FEerror("The file ~A does not exist.", 1, fn); - else if (if_does_not_exist == sKcreate) { - CREATE: - if (smm == smm_output) - { - if(fname[0]=='|') - fp = popen(fname+1,"w"); - else - fp = fopen_not_dir(fname, "w"); - } - else - fp = fopen_not_dir(fname, "w+"); - if (fp == NULL) - 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); - } + object x; + FILE *fp=NULL; + vs_mark; + + coerce_to_filename(fn,FN1); + if (smm == smm_input || smm == smm_probe) { + if(FN1[0]=='|') + fp = popen(FN1+1,"r"); + else + fp = fopen_not_dir(FN1, "r"); + + if ((fp == NULL) && + (sSAallow_gzipped_fileA->s.s_dbind != sLnil)) { + union lispunion st; + char buf[256]; + if (snprintf(buf,sizeof(buf),"%s.gz",FN1)<=0) + FEerror("Cannot write .gz filename",0); + st.st.st_self=buf; + st.st.st_dim=st.st.st_fillp=strlen(buf); + set_type_of(&st,t_string); + if (fSstat((object)&st)!=Cnil) { + FILE *pp; + int n; + if (!(fp=tmpfile())) + FEerror("Cannot create temporary file",0); + if (snprintf(buf,sizeof(buf),"zcat %s.gz",FN1)<=0) + FEerror("Cannot write zcat pipe name",0); + if (!(pp=popen(buf,"r"))) + FEerror("Cannot open zcat pipe",0); + while((n=fread(buf,1,sizeof(buf),pp))) + if (!fwrite(buf,1,n,fp)) + FEerror("Cannot write pipe output to temporary file",0); + if (pclose(pp)<0) + FEerror("Cannot close zcat pipe",0); + if (fseek(fp,0,SEEK_SET)) + FEerror("Cannot rewind temporary file\n",0); + } + } + if (fp == NULL) { + if (if_does_not_exist == sKerror) + cannot_open(fn); + else if (if_does_not_exist == sKcreate) { + fp = fopen_not_dir(FN1, "w"); + if (fp == NULL) + cannot_create(fn); + fclose(fp); + fp = fopen_not_dir(FN1, "r"); + if (fp == NULL) + 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); + } + } else if (smm == smm_output || smm == smm_io) { + if (FN1[0] == '|') + fp = NULL; + else + fp = fopen_not_dir(FN1, "r"); + if (fp != NULL) { + fclose(fp); + if (if_exists == sKerror) + FILE_ERROR(fn,"File exists"); + else if (if_exists == sKrename) { + massert(snprintf(FN2,sizeof(FN2),"%s.BAK",FN1)>=0); + massert(!rename(FN1,FN2)); + if (smm == smm_output) + fp = fopen(FN1, "w"); + else + fp = fopen(FN1, "w+"); + if (fp == NULL) + cannot_create(fn); + } else if (if_exists == sKrename_and_delete || + if_exists == sKnew_version || + if_exists == sKsupersede) { + if (smm == smm_output) + fp = fopen_not_dir(FN1, "w"); + else + fp = fopen_not_dir(FN1, "w+"); + if (fp == NULL) + cannot_create(fn); + } else if (if_exists == sKoverwrite) { + fp = fopen_not_dir(FN1, "r+"); + if (fp == NULL) + cannot_open(fn); + } else if (if_exists == sKappend) { + if (smm == smm_output) + fp = fopen_not_dir(FN1, "a"); + else + fp = fopen_not_dir(FN1, "a+"); + if (fp == NULL) + 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 (smm == smm_output) { + if(FN1[0]=='|') + fp = popen(FN1+1,"w"); + else + fp = fopen_not_dir(FN1, "w"); } else - error("illegal stream mode"); - x = alloc_object(t_stream); - x->sm.sm_mode = (short)smm; - x->sm.sm_fp = fp; + fp = fopen_not_dir(FN1, "w+"); + if (fp == NULL) + 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); + } + } else + FEerror("Illegal open mode for ~S.",1,fn); + + vs_push(make_simple_string(FN1)); + x = alloc_object(t_stream); + x->sm.sm_mode = (short)smm; + x->sm.sm_fp = fp; + x->sm.sm_buffer = 0; + x->sm.sm_object0 = sLcharacter; + x->sm.sm_object1 = vs_head; + x->sm.sm_int0 = x->sm.sm_int1 = 0; + x->sm.sm_flags=0; + vs_push(x); + + setup_stream_buffer(x); + vs_reset; + + if (smm==smm_probe) + close_stream(x); + + return(x); - x->sm.sm_buffer = 0; - x->sm.sm_object0 = (unzipped ? make_cons(sSAallow_gzipped_fileA,unzipped) : sLcharacter); - x->sm.sm_object1 = fn; - x->sm.sm_int0 = x->sm.sm_int1 = 0; - vs_push(x); - setup_stream_buffer(x); - vs_reset; - return(x); } static void gclFlushSocket(object); +DEFUN_NEW("OPEN-INT",object,fSopen_int,SI,8,8,NONE,OO,OO,OO,OO, + (object fn,object direction,object element_type,object if_exists, + object iesp,object if_does_not_exist,object idnesp, + object external_format),"") { + + enum smmode smm=0; + vs_mark; + object strm,filename; + + filename=fn; + if (direction == sKinput) { + smm = smm_input; + if (idnesp==Cnil) + if_does_not_exist = sKerror; + } else if (direction == sKoutput) { + smm = smm_output; + if (iesp==Cnil) + if_exists = sKnew_version; + if (idnesp==Cnil) { + if (if_exists == sKoverwrite || + if_exists == sKappend) + if_does_not_exist = sKerror; + else + if_does_not_exist = sKcreate; + } + } else if (direction == sKio) { + smm = smm_io; + if (iesp==Cnil) + if_exists = sKnew_version; + if (idnesp==Cnil) { + if (if_exists == sKoverwrite || + if_exists == sKappend) + if_does_not_exist = sKerror; + else + if_does_not_exist = sKcreate; + } + } else if (direction == sKprobe) { + smm = smm_probe; + if (idnesp==Cnil) + if_does_not_exist = Cnil; + } else + FEerror("~S is an illegal DIRECTION for OPEN.", 1, direction); + strm = open_stream(filename, smm, if_exists, if_does_not_exist); + if (type_of(strm) == t_stream) { + strm->sm.sm_object0 = element_type; + strm->sm.sm_object1 = fn; + } + vs_reset; + RETURN1(strm); +} DEFUN_NEW("OPEN-STREAM-P",object,fLopen_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_stream(&x); - switch(x->sm.sm_mode) { - case smm_output: - case smm_input: - case smm_io: - case smm_probe: - case smm_socket: - case smm_string_input: - case smm_string_output: - return x->d.tt==1 ? Cnil : Ct; - case smm_synonym: - return FFN(fLopen_stream_p)(symbol_value(x->sm.sm_object0)); - case smm_broadcast: - case smm_concatenated: - for (x=x->sm.sm_object0;!endp(x);x=x->c.c_cdr) - if (!FFN(fLopen_stream_p)(x)) - return Cnil; - return Ct; - case smm_two_way: - case smm_echo: - if (FFN(fLopen_stream_p)(STREAM_INPUT_STREAM(x))==Cnil) - return Cnil; - return FFN(fLopen_stream_p)(STREAM_OUTPUT_STREAM(x)); - default: - error("illegal stream mode"); - return Cnil; - } + return GET_STREAM_FLAG(x,gcl_sm_closed) ? Cnil : Ct; } /* @@ -562,94 +553,132 @@ DEFUN_NEW("OPEN-STREAM-P",object,fLopen_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(obje The abort_flag is not used now. */ void -close_stream(strm) -object strm; -/*bool abort_flag; */ /* Not used now! */ -{ - object x; +close_stream(object strm) { -BEGIN: - strm->d.tt=1; + object x; - switch (strm->sm.sm_mode) { - case smm_output: - if (strm->sm.sm_fp == stdout) - FEerror("Cannot close the standard output.", 0); - if (strm->sm.sm_fp == NULL) break; - fflush(strm->sm.sm_fp); - deallocate_stream_buffer(strm); - fclose(strm->sm.sm_fp); - strm->sm.sm_fp = NULL; - break; + if (FFN(fLopen_stream_p)(strm)==Cnil) + return; + switch (strm->sm.sm_mode) { + case smm_output: + if (strm->sm.sm_fp == stdout) + FEerror("Cannot close the standard output.", 0); + fflush(strm->sm.sm_fp); + deallocate_stream_buffer(strm); + 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 { + 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)); - } + 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; - } + 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; - deallocate_stream_buffer(strm); - if (strm->sm.sm_object1 && - type_of(strm->sm.sm_object1)==t_string && - strm->sm.sm_object1->st.st_self[0] =='|') - pclose(strm->sm.sm_fp); - else - fclose(strm->sm.sm_fp); - strm->sm.sm_fp = NULL; - if (strm->sm.sm_object0 && - type_of(strm->sm.sm_object0 ) == t_cons && - Mcar(strm->sm.sm_object0 ) == sSAallow_gzipped_fileA) - fLdelete_file(Mcdr(strm->sm.sm_object0)); - break; + case smm_input: + if (strm->sm.sm_fp == stdin) + FEerror("Cannot close the standard input.", 0); - 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_io: + case smm_probe: + deallocate_stream_buffer(strm); + if (strm->sm.sm_object1 && + type_of(strm->sm.sm_object1)==t_string && + strm->sm.sm_object1->st.st_self[0] =='|') + pclose(strm->sm.sm_fp); + else + fclose(strm->sm.sm_fp); + strm->sm.sm_fp = NULL; + strm->sm.sm_fd = -1; + if (strm->sm.sm_object0 && + type_of(strm->sm.sm_object0 )==t_cons && + Mcar(strm->sm.sm_object0)==sSAallow_gzipped_fileA) + ifuncall1(sLdelete_file,Mcdr(strm->sm.sm_object0)); + break; + + case smm_file_synonym: + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + TYPE_ERROR(strm,sLstream); + close_stream(strm); + break; - case smm_broadcast: - for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) - close_stream(x->c.c_car); - break; + case smm_broadcast: + case smm_concatenated: + for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) + close_stream(x->c.c_car); + break; - case smm_concatenated: - for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) - close_stream(x->c.c_car); - break; + case smm_two_way: + case smm_echo: + close_stream(STREAM_INPUT_STREAM(strm)); + close_stream(STREAM_OUTPUT_STREAM(strm)); + break; - case smm_two_way: - case smm_echo: - close_stream(STREAM_INPUT_STREAM(strm)); - close_stream(STREAM_OUTPUT_STREAM(strm)); - break; + case smm_string_input: + case smm_string_output: + break; - case smm_string_input: - break; /* There is nothing to do. */ + default: + error("Illegal stream mode"); + } - case smm_string_output: - break; /* There is nothing to do. */ + SET_STREAM_FLAG(strm,gcl_sm_closed,1); + +} + +DEFUN_NEW("INTERACTIVE-STREAM-P",object,fLinteractive_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(object strm),"") { + + check_type_stream(&strm); + + switch (strm->sm.sm_mode) { + case smm_output: + case smm_input: + case smm_io: + case smm_probe: + if ((strm->sm.sm_fp == stdin) || + (strm->sm.sm_fp == stdout) || + (strm->sm.sm_fp == stderr)) + return Ct; + return Cnil; + break; + case smm_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; - default: - error("illegal stream mode"); - } } object @@ -665,6 +694,7 @@ object istrm, ostrm; STREAM_INPUT_STREAM(strm) = istrm; STREAM_OUTPUT_STREAM(strm) = ostrm; strm->sm.sm_int0 = strm->sm.sm_int1 = 0; + strm->sm.sm_flags=0; return(strm); } @@ -694,6 +724,7 @@ int istart, iend; strm->sm.sm_object1 = OBJNULL; STRING_INPUT_STREAM_NEXT(strm)= istart; STRING_INPUT_STREAM_END(strm)= iend; + strm->sm.sm_flags=0; return(strm); } @@ -729,6 +760,7 @@ int line_length; STRING_STREAM_STRING(strm) = strng; strm->sm.sm_object1 = OBJNULL; strm->sm.sm_int0 = STREAM_FILE_COLUMN(strm) = 0; + strm->sm.sm_flags=0; vs_reset; return(strm); } @@ -782,6 +814,7 @@ BEGIN: /* 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) @@ -884,6 +917,7 @@ BEGIN: /* --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) @@ -985,6 +1019,7 @@ BEGIN: break; + case smm_file_synonym: case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) @@ -1095,6 +1130,7 @@ BEGIN: #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) @@ -1183,6 +1219,7 @@ BEGIN: case smm_probe: return(FALSE); + case smm_file_synonym: case smm_synonym: strm = symbol_value(strm->sm.sm_object0); check_stream(strm); @@ -1308,6 +1345,7 @@ BEGIN: #endif return TRUE; + case smm_file_synonym: case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) @@ -1363,6 +1401,7 @@ BEGIN: 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) @@ -1412,6 +1451,7 @@ BEGIN: } return(0); + case smm_file_synonym: case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) @@ -1448,6 +1488,7 @@ BEGIN: + case smm_file_synonym: case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) @@ -1487,6 +1528,7 @@ BEGIN: 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) @@ -1553,6 +1595,22 @@ load(const char *s) { +static int +file_synonym_stream_p(object x) { + 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; + } +} + LFD(Lmake_synonym_stream)() { object x; @@ -1560,12 +1618,13 @@ LFD(Lmake_synonym_stream)() check_arg(1); check_type_sym(&vs_base[0]); x = alloc_object(t_stream); - x->sm.sm_mode = (short)smm_synonym; + x->sm.sm_mode = file_synonym_stream_p(vs_base[0]) ? (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_int0 = x->sm.sm_int1 = 0; + x->sm.sm_flags=0; vs_base[0] = x; } @@ -1589,6 +1648,7 @@ LFD(Lmake_broadcast_stream)() x->sm.sm_object0 = vs_base[0]; x->sm.sm_object1 = OBJNULL; x->sm.sm_int0 = x->sm.sm_int1 = 0; + x->sm.sm_flags=0; vs_base[0] = x; } @@ -1612,6 +1672,7 @@ LFD(Lmake_concatenated_stream)() x->sm.sm_object0 = vs_base[0]; x->sm.sm_object1 = OBJNULL; x->sm.sm_int0 = x->sm.sm_int1 = 0; + x->sm.sm_flags=0; vs_base[0] = x; } @@ -1700,6 +1761,38 @@ LFD(siLoutput_stream_string)() vs_base[0] = vs_base[0]->sm.sm_object0; } +DEFUN_NEW("FILE-STREAM-P",object,fSfile_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_mode==smm_output || x->sm.sm_mode==smm_io || x->sm.sm_mode==smm_probe) + ? Ct : Cnil); +} + +DEFUN_NEW("SYNONYM-STREAM-P",object,fSsynonym_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_stream && (x->sm.sm_mode==smm_file_synonym || x->sm.sm_mode==smm_synonym) ? Ct : Cnil); +} + +DEFUN_NEW("TERMINAL-INPUT-STREAM-P",object,fSterminal_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_input && x->sm.sm_fp && isatty(fileno((FILE *)x->sm.sm_fp)) ? Ct : Cnil); +} + +DEFUN_NEW("BROADCAST-STREAM-P",object,fSbroadcast_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_broadcast ? Ct : Cnil); +} + +DEFUN_NEW("ECHO-STREAM-P",object,fSecho_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_echo ? Ct : Cnil); +} + +DEFUN_NEW("TWO-WAY-STREAM-P",object,fStwo_way_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_two_way ? Ct : Cnil); +} + +DEFUN_NEW("CONCATENATED-STREAM-P",object,fSconcatenated_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_concatenated ? Ct : Cnil); +} + + + LFD(Lstreamp)() { check_arg(1); @@ -1747,54 +1840,6 @@ LFD(Lstream_element_type)() @(return Ct) @) -@(static defun open (filename - &key (direction sKinput) - (element_type sLcharacter) - (if_exists Cnil iesp) - (if_does_not_exist Cnil idnesp) - &aux strm) - enum smmode smm=0; -@ - check_type_or_pathname_string_symbol_stream(&filename); - filename = coerce_to_namestring(filename); - if (direction == sKinput) { - smm = smm_input; - if (!idnesp) - if_does_not_exist = sKerror; - } else if (direction == sKoutput) { - smm = smm_output; - if (!iesp) - if_exists = sKnew_version; - if (!idnesp) { - 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) - if_exists = sKnew_version; - if (!idnesp) { - 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) - 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; - @(return strm) -@) @(defun file_position (file_stream &o position) int i=0; @@ -1838,175 +1883,72 @@ object sLAload_pathnameA; DEFVAR("*COLLECT-BINARY-MODULES*",sSAcollect_binary_modulesA,SI,sLnil,""); DEFVAR("*BINARY-MODULES*",sSAbinary_modulesA,SI,Cnil,""); -@(static defun load (pathname - &key (verbose `symbol_value(sLAload_verboseA)`) - print - (if_does_not_exist sKerror) - &aux pntype fasl_filename lsp_filename filename - defaults strm stdoutput x - package) - bds_ptr old_bds_top; - int i; - object strm1; -@ - check_type_or_pathname_string_symbol_stream(&pathname); - pathname = coerce_to_pathname(pathname); - defaults = symbol_value(Vdefault_pathname_defaults); - defaults = coerce_to_pathname(defaults); - pathname = merge_pathnames(pathname, defaults, sKnewest); - pntype = pathname->pn.pn_type; - filename = coerce_to_namestring(pathname); - if (user_match(filename->st.st_self,filename->st.st_fillp)) - @(return Cnil) - old_bds_top=bds_top; - if (pntype == Cnil || pntype == sKwild || - (type_of(pntype) == t_string && -#ifdef UNIX - string_eq(pntype, FASL_string))) { -#endif -#ifdef AOSVS +DEFUN_NEW("LOAD-STREAM",object,fSload_stream,SI,2,2,NONE,OO,OO,OO,OO,(object strm,object print),"") { -#endif - pathname->pn.pn_type = FASL_string; - fasl_filename = coerce_to_namestring(pathname); - } - if (pntype == Cnil || pntype == sKwild || - (type_of(pntype) == t_string && -#ifdef UNIX - string_eq(pntype, LSP_string))) { -#endif -#ifdef AOSVS + object x; -#endif - pathname->pn.pn_type = LSP_string; - lsp_filename = coerce_to_namestring(pathname); - } - if (fasl_filename != Cnil && file_exists(fasl_filename)) { - if (verbose != Cnil) { - SETUP_PRINT_DEFAULT(fasl_filename); - if (file_column(PRINTstream) != 0) - write_str("\n"); - write_str("Loading "); - PRINTescape = FALSE; - write_object(fasl_filename, 0); - write_str("\n"); - CLEANUP_PRINT_DEFAULT; - flush_stream(PRINTstream); - } - package = symbol_value(sLApackageA); - bds_bind(sLApackageA, package); - bds_bind(sLAload_pathnameA,fasl_filename); - if (sSAcollect_binary_modulesA->s.s_dbind==Ct) { - object _x=sSAbinary_modulesA->s.s_dbind; - object _y=Cnil; - while (_x!=Cnil) { - _y=_x; - _x=_x->c.c_cdr; - } - if (_y==Cnil) - sSAbinary_modulesA->s.s_dbind=make_cons(fasl_filename,Cnil); - else - _y->c.c_cdr=make_cons(fasl_filename,Cnil); - } - i = fasload(fasl_filename); - if (print != Cnil) { - SETUP_PRINT_DEFAULT(Cnil); - vs_top = PRINTvs_top; - if (file_column(PRINTstream) != 0) - write_str("\n"); - write_str("Fasload successfully ended."); - write_str("\n"); - CLEANUP_PRINT_DEFAULT; - flush_stream(PRINTstream); - } - bds_unwind(old_bds_top); - if (verbose != Cnil) { - SETUP_PRINT_DEFAULT(fasl_filename); - if (file_column(PRINTstream) != 0) - write_str("\n"); - write_str("Finished loading "); - PRINTescape = FALSE; - write_object(fasl_filename, 0); - write_str("\n"); - CLEANUP_PRINT_DEFAULT; - flush_stream(PRINTstream); - } - @(return `make_fixnum(i)`) - } - if (lsp_filename != Cnil && file_exists(lsp_filename)) { - filename = lsp_filename; - } - if (if_does_not_exist != Cnil) - if_does_not_exist = sKerror; - strm1 = strm - = open_stream(filename, smm_input, Cnil, if_does_not_exist); - if (strm == Cnil) - @(return Cnil) - if (verbose != Cnil) { - SETUP_PRINT_DEFAULT(filename); - if (file_column(PRINTstream) != 0) - write_str("\n"); - write_str("Loading "); - PRINTescape = FALSE; - write_object(filename, 0); - write_str("\n"); - CLEANUP_PRINT_DEFAULT; - flush_stream(PRINTstream); - } - package = symbol_value(sLApackageA); - bds_bind(sLAload_pathnameA,pathname); - bds_bind(sLApackageA, package); - bds_bind(sLAstandard_inputA, strm); - frs_push(FRS_PROTECT, Cnil); - if (nlj_active) { - close_stream(strm1); - nlj_active = FALSE; - frs_pop(); - bds_unwind(old_bds_top); - unwind(nlj_fr, nlj_tag); - } - for (;;) { - preserving_whitespace_flag = FALSE; - detect_eos_flag = TRUE; - x = read_object_non_recursive(strm); - if (x == OBJNULL) - break; - { - object *base = vs_base, *top = vs_top, *lex = lex_env; - object xx; - - lex_new(); - eval(x); - xx = vs_base[0]; - lex_env = lex; - vs_top = top; - vs_base = base; - x = xx; - } - if (print != Cnil) { - SETUP_PRINT_DEFAULT(x); - write_object(x, 0); - write_str("\n"); - CLEANUP_PRINT_DEFAULT; - flush_stream(PRINTstream); - } - } - close_stream(strm); - frs_pop(); - bds_unwind(old_bds_top); - if (verbose != Cnil) { - SETUP_PRINT_DEFAULT(filename); - if (file_column(PRINTstream) != 0) - write_str("\n"); - write_str("Finished loading "); - PRINTescape = FALSE; - write_object(filename, 0); - write_str("\n"); - CLEANUP_PRINT_DEFAULT; - flush_stream(PRINTstream); - } - @(return Ct) -@) + for (;;) { + preserving_whitespace_flag = FALSE; + detect_eos_flag = TRUE; + x = read_object_non_recursive(strm); + if (x == OBJNULL) + break; + { + object *base = vs_base, *top = vs_top, *lex = lex_env; + object xx; + + lex_new(); + eval(x); + xx = vs_base[0]; + lex_env = lex; + vs_top = top; + vs_base = base; + x = xx; + } + if (print != Cnil) { + SETUP_PRINT_DEFAULT(x); + write_object(x, 0); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + } + + RETURN1(Ct); + +} + +DEFUN_NEW("LOAD-FASL",object,fSload_fasl,SI,2,2,NONE,OO,OO,OO,OO,(object fasl_filename,object print),"") { + + int i; + + if (sSAcollect_binary_modulesA->s.s_dbind==Ct) { + object _x=sSAbinary_modulesA->s.s_dbind; + object _y=Cnil; + while (_x!=Cnil) { + _y=_x; + _x=_x->c.c_cdr; + } + if (_y==Cnil) + sSAbinary_modulesA->s.s_dbind=make_cons(fasl_filename,Cnil); + else + _y->c.c_cdr=make_cons(fasl_filename,Cnil); + } + i = fasload(fasl_filename); + if (print != Cnil) { + SETUP_PRINT_DEFAULT(Cnil); + vs_top = PRINTvs_top; + if (file_column(PRINTstream) != 0) + write_str("\n"); + write_str(";; Fasload successfully ended."); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + + RETURN1(make_fixnum(i)); + +} static void FFN(siLget_string_input_stream_index)() @@ -2018,9 +1960,6 @@ FFN(siLget_string_input_stream_index)() vs_base[0] = make_fixnum(STRING_INPUT_STREAM_NEXT(vs_base[0])); } -DEFUN_NEW("TERMINAL-INPUT-STREAM-P",object,fSterminal_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { - RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_input && x->sm.sm_fp && isatty(fileno((FILE *)x->sm.sm_fp)) ? Ct : Cnil); -} LFD(siLmake_string_output_stream_from_string)() { @@ -2038,6 +1977,7 @@ LFD(siLmake_string_output_stream_from_string)() strm->sm.sm_object1 = OBJNULL; /* strm->sm.sm_int0 = strng->st.st_fillp; */ STREAM_FILE_COLUMN(strm) = 0; + strm->sm.sm_flags=0; vs_base[0] = strm; } @@ -2071,14 +2011,14 @@ static void cannot_open(fn) object fn; { - FEerror("Cannot open the file ~A.", 1, fn); + FILE_ERROR(fn,"Cannot open"); } static void cannot_create(fn) object fn; { - FEerror("Cannot create the file ~A.", 1, fn); + FILE_ERROR(fn,"Cannot create"); } static void @@ -2141,6 +2081,7 @@ int out; 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) @@ -2566,6 +2507,7 @@ gcl_init_file(void) #endif standard_input->sm.sm_int0 = 0; /* unused */ standard_input->sm.sm_int1 = 0; /* unused */ + standard_input->sm.sm_flags=0; standard_output = alloc_object(t_stream); standard_output->sm.sm_mode = (short)smm_output; @@ -2578,18 +2520,20 @@ gcl_init_file(void) #endif standard_output->sm.sm_int0 = 0; /* unused */ STREAM_FILE_COLUMN(standard_output) = 0; + standard_output->sm.sm_flags=0; terminal_io = standard = make_two_way_stream(standard_input, standard_output); enter_mark_origin(&terminal_io); x = alloc_object(t_stream); - x->sm.sm_mode = (short)smm_synonym; + x->sm.sm_mode = (short)smm_file_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_int0 = x->sm.sm_int1 = 0; /* unused */ + x->sm.sm_flags=0; standard_io = x; enter_mark_origin(&standard_io); @@ -2597,7 +2541,9 @@ gcl_init_file(void) DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,""); DEFVAR("*LOAD-PATHNAME*",sLAload_pathnameA,LISP,Cnil,""); +DEFVAR("*LOAD-TRUENAME*",sSAload_truenameA,LISP,Cnil,""); DEFVAR("*LOAD-VERBOSE*",sLAload_verboseA,LISP,Ct,""); +DEFVAR("*LOAD-PRINT*",sLAload_printA,LISP,Cnil,""); DEF_ORDINARY("ABORT",sKabort,KEYWORD,""); DEF_ORDINARY("APPEND",sKappend,KEYWORD,""); @@ -2622,6 +2568,7 @@ DEF_ORDINARY("SUPERSEDE",sKsupersede,KEYWORD,""); DEF_ORDINARY("VERBOSE",sKverbose,KEYWORD,""); +DEF_ORDINARY("DELETE-FILE",sLdelete_file,LISP,""); void @@ -2673,13 +2620,9 @@ gcl_init_file_function() make_function("STREAM-ELEMENT-TYPE", Lstream_element_type); make_function("CLOSE", Lclose); - make_function("OPEN", Lopen); - make_function("FILE-POSITION", Lfile_position); make_function("FILE-LENGTH", Lfile_length); - make_function("LOAD", Lload); - make_si_function("GET-STRING-INPUT-STREAM-INDEX", siLget_string_input_stream_index); make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING", diff --git a/o/gbc.c b/o/gbc.c index 6514771..dd2f5a0 100755 --- a/o/gbc.c +++ b/o/gbc.c @@ -57,7 +57,7 @@ mark_contblock(void *, int); 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 @@ -72,7 +72,7 @@ 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; @@ -84,7 +84,7 @@ 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); @@ -146,7 +146,7 @@ pageinfo_p(void *v) { (!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); @@ -157,16 +157,6 @@ get_bit(char *v,struct pageinfo *pi,void *x) { return (v[i]>>s)&0x1; } -/* static inline void */ -/* set_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_set(v,i,s) (v[i]|=(1UL<d.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++; @@ -460,7 +440,7 @@ mark_leaf_data(object x,void **pp,ufixnum s,ufixnum r) { 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) { @@ -468,7 +448,7 @@ mark_object_address(object *o,int f) { static ufixnum lr; ufixnum p=page(o); - + if (lp!=p || !f) { lp=p; lr= @@ -496,7 +476,7 @@ mark_object_array(object *o,object *oe) { static void mark_object1(object x) { - + fixnum i,j=0;/*FIXME*/ if (is_marked_or_free(x)) @@ -567,7 +547,7 @@ mark_object1(object x) { break; case t_array: - MARK_LEAF_DATA(x,x->a.a_dims,sizeof(int)*x->a.a_rank); + MARK_LEAF_DATA(x,x->a.a_dims,sizeof(*x->a.a_dims)*x->a.a_rank); case t_vector: case t_bitvector: @@ -615,7 +595,7 @@ mark_object1(object x) { x->v.v_self=p; adjust_displaced(x,j); } - } + } mark_object(x->v.v_displaced); break; @@ -627,7 +607,7 @@ mark_object1(object x) { mark_object(x->str.str_def); if (x->str.str_self) for (i=0,j=S_DATA(def)->length;istr.str_self,S_DATA(def)->size); } @@ -646,7 +626,8 @@ mark_object1(object x) { MARK_LEAF_DATA(x,x->sm.sm_buffer,BUFSIZ); } break; - + + case smm_file_synonym: case smm_synonym: mark_object(x->sm.sm_object0); break; @@ -676,7 +657,7 @@ mark_object1(object x) { 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; @@ -700,6 +681,7 @@ mark_object1(object x) { mark_object(x->pn.pn_name); mark_object(x->pn.pn_type); mark_object(x->pn.pn_version); + mark_object(x->pn.pn_namestring); break; case t_closure: @@ -854,24 +836,6 @@ mark_phase(void) { } #endif - /* - if (what_to_collect != t_symbol && - (int)what_to_collect < (int)t_contiguous) { - */ - - /* {int size; */ - - /* for (pp = pack_pointer; pp != NULL; pp = pp->p_link) { */ - /* size = pp->p_internal_size; */ - /* if (pp->p_internal != NULL) */ - /* for (i = 0; i < size; i++) */ - /* mark_object(pp->p_internal[i]); */ - /* size = pp->p_external_size; */ - /* if (pp->p_external != NULL) */ - /* for (i = 0; i < size; i++) */ - /* mark_object(pp->p_external[i]); */ - /* }} */ - /* mark the c stack */ #ifndef N_RECURSION_REQD #define N_RECURSION_REQD 2 @@ -979,15 +943,15 @@ mark_c_stack(jmp_buf env1, int n, void (*fn)(void *,void *,int)) { 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 @@ -1035,7 +999,7 @@ 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++) { @@ -1045,7 +1009,7 @@ contblock_sweep_phase(void) { #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; @@ -1070,25 +1034,6 @@ contblock_sweep_phase(void) { int (*GBC_enter_hook)() = NULL; int (*GBC_exit_hook)() = NULL; -/* void */ -/* ttss(void) { */ - -/* struct typemanager *tm; */ -/* void *x,*y; */ - -/* for (tm=tm_table;tmtm_free;x!=OBJNULL;x=(void *)((struct freelist *)x)->f_link) { */ -/* if (x==Cnil) */ -/* printf("barr\n"); */ -/* /\* for (y=(void *)((struct freelist *)x)->f_link;y!=OBJNULL && y!=x;y=(void *)((struct freelist *)y)->f_link); *\/ */ -/* /\* if (y==x) *\/ */ -/* /\* printf("circle\n"); *\/ */ -/* } */ -/* } */ - -/* } */ - fixnum fault_pages=0; static ufixnum @@ -1102,7 +1047,7 @@ count_contblocks(void) { return ncb; } - + void GBC(enum type t) { @@ -1120,7 +1065,7 @@ GBC(enum type t) { ngc_thresh=fix(sSAleaf_collection_thresholdA->s.s_dbind); recent_allocation=0; - + if (in_signal_handler && t == t_relocatable) error("cant gc relocatable in signal handler"); @@ -1146,7 +1091,6 @@ GBC(enum type t) { close_stream(o); } - /* t = t_relocatable; */ gc_time = -1; } @@ -1265,54 +1209,6 @@ GBC(enum type t) { #endif } - -/* { */ -/* static int promoting; */ -/* if (!promoting && promotion_pointer>promotion_pointer1) { */ -/* object *p,st; */ -/* promoting=1; */ -/* st=alloc_simple_string(""); */ -/* for (p=promotion_pointer1;pst.st_dim; */ - -/* else switch (x->v.v_elttype) { */ - -/* case aet_lf: */ -/* j=sizeof(longfloat)*x->v.v_dim; */ -/* break; */ -/* case aet_bit: */ -/* #define W_SIZE (8*sizeof(fixnum)) */ -/* j=sizeof(fixnum)*((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); */ -/* break; */ -/* case aet_char: */ -/* case aet_uchar: */ -/* j=sizeof(char)*x->v.v_dim; */ -/* break; */ -/* case aet_short: */ -/* case aet_ushort: */ -/* j=sizeof(short)*x->v.v_dim; */ -/* break; */ -/* default: */ -/* j=sizeof(fixnum)*x->v.v_dim; */ -/* } */ - -/* st->st.st_dim=j; */ -/* st->st.st_self=alloc_contblock(st->st.st_dim); */ -/* fprintf(stderr,"Promoting vector leaf bytes %lu at %p, %p -> %p\n",j,x,x->v.v_self,st->st.st_self); */ -/* fflush(stderr); */ -/* memcpy(st->st.st_self,x->v.v_self,st->st.st_dim); */ -/* x->v.v_self=(void *)st->st.st_self; */ -/* } */ -/* promoting=0; */ -/* } */ -/* } */ - - #ifdef DEBUG if (debug) { int i,j; @@ -1361,8 +1257,6 @@ GBC(enum type t) { CHECK_INTERRUPT; - /* ttss(); */ - } static void @@ -1472,7 +1366,7 @@ mark_contblock(void *p, int s) { STATIC char *q; STATIC char *x, *y; struct pageinfo *v; - + if (NULL_OR_ON_C_STACK(p)) return; @@ -1495,17 +1389,17 @@ DEFUN_NEW("CONTIGUOUS-REPORT",object,fScontiguous_report,SI,1,1,NONE,OO,OO,OO,OO 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++) + + 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; @@ -1520,7 +1414,7 @@ DEFUN_NEW("CONTIGUOUS-REPORT",object,fScontiguous_report,SI,1,1,NONE,OO,OO,OO,OO } } 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; @@ -1589,15 +1483,13 @@ DEFUN_NEW("CONTIGUOUS-REPORT",object,fScontiguous_report,SI,1,1,NONE,OO,OO,OO,OO } } emsg("\nTotal leaf bytes %lu in %lu pieces\n",i,j); - + return Cnil; } DEFUN_NEW("GBC",object,fSgbc,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { - /* 1 args */ - if (x0 == Ct) { tm_table[t_contiguous].tm_adjgbccnt--; GBC(t_other); @@ -1644,5 +1536,5 @@ gcl_init_GBC(void) { #ifdef SGC make_si_function("SGC-ON",siLsgc_on); #endif - + } diff --git a/o/iteration.c b/o/iteration.c index 452ea6d..7cfe21c 100755 --- a/o/iteration.c +++ b/o/iteration.c @@ -95,7 +95,7 @@ do_var_list(object var_list) - if (type_of(x) != t_cons) + if (!consp(x)) FEinvalid_form("The index, ~S, is illegal.", x); y = MMcar(x); check_var(y); @@ -326,7 +326,7 @@ FFN(Fdolist)(VOL object arg) } eval_assign(start->bt_init, listform); - body = find_special(MMcdr(arg), start, start+1); + 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) @@ -410,7 +410,7 @@ FFN(Fdotimes)(VOL object arg) 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); + 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) { diff --git a/o/let.c b/o/let.c index a2db64b..18cd3ab 100755 --- a/o/let.c +++ b/o/let.c @@ -151,7 +151,7 @@ FFN(Fmultiple_value_bind)(object form) } { object *vt = vs_top; - vs_push(find_special(body, start, (struct bind_temp *)vt)); + vs_push(find_special(body, start, (struct bind_temp *)vt,NULL)); /*?*/ } for (i = 0; i < n; i++) bind_var(start[i].bt_var, @@ -230,7 +230,7 @@ is an illegal function definition in FLET.", lex_fun_bind(MMcar(def), top[0]); def_list = MMcdr(def_list); } - vs_push(find_special(MMcdr(args), NULL, NULL)); + vs_push(find_special(MMcdr(args), NULL, NULL,NULL)); Fprogn(vs_head); lex_env = lex; } @@ -271,7 +271,7 @@ is an illegal function definition in LABELS.", MMcaar(closure_list) = lex_env[1]; closure_list = MMcdr(closure_list); } - vs_push(find_special(MMcdr(args), NULL, NULL)); + vs_push(find_special(MMcdr(args), NULL, NULL,NULL)); Fprogn(vs_head); lex_env = lex; } @@ -304,7 +304,7 @@ is an illegal macro definition in MACROFLET.", lex_macro_bind(MMcar(def), MMcaddr(top[0])); def_list = MMcdr(def_list); } - vs_push(find_special(MMcdr(args), NULL, NULL)); + vs_push(find_special(MMcdr(args), NULL, NULL,NULL)); Fprogn(vs_head); lex_env = lex; } diff --git a/o/pathname.d b/o/pathname.d index c508bab..b236d78 100755 --- a/o/pathname.d +++ b/o/pathname.d @@ -28,744 +28,93 @@ Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. #include #include "include.h" - -object -make_pathname(host, device, directory, name, type, version) -object host, device, directory, name, type, version; -{ - object x; - - 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; - return(x); +DEFUN_NEW("C-SET-T-TT",object,fSc_set_t_tt,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum y),"") { + x->d.tt=y; + RETURN1(x); } -static void -make_one(s, end) -char *s; -int end; -{ - int i; - -#ifdef UNIX - for (i = 0; i < end; i++) - token->st.st_self[i] = s[i]; -#endif -#ifdef AOSVS - - - -#endif - token->st.st_fillp = end; - vs_push(copy_simple_string(token)); -} - -/* The function below does not attempt to handle DOS pathnames - which use backslashes as directory separators. It needs - TLC from someone who feels pedantic. MJT */ - -/* !!!!! Bug Fix. NLG */ -object -parse_namestring(s, start, end, ep) -object s; -int start, end, *ep; -{ - int i, j, k, founddosdev = FALSE, oldstart=start, oldend=end, justdevice = FALSE; - int d; - object *vsp; - object x; - vs_mark; - -#ifndef IS_DIR_SEPARATOR -#define IS_DIR_SEPARATOR(x) (x == '/') -#endif - - *ep=oldend; - vsp = vs_top + 1; - for (;--end >= start && isspace((int)s->st.st_self[end]);); - - /* Check for a DOS path and process later */ - if ( ( (start+1) <= end) && (s->st.st_self[start+1] == ':' )) { - start+=2; - founddosdev = TRUE; - } - if ( start > end ) { - make_one(&s->st.st_self[0], 0); - justdevice = TRUE; - } else { - for (i = j = start; i <= end; ) { -#ifdef UNIX - if (IS_DIR_SEPARATOR(s->st.st_self[i])) { -#endif - if (j == start && i == start) { - i++; - vs_push(sKroot); - j = i; - continue; - } -#ifdef UNIX - if (i-j == 1 && s->st.st_self[j] == '.') { - vs_push(sKcurrent); - } else if (i-j == 1 && s->st.st_self[j] == '*') { - vs_push(sKwild); - } else if (i-j==2 && s->st.st_self[j]=='.' && s->st.st_self[j+1]=='.') { - vs_push(sKparent); - } else { - make_one(&s->st.st_self[j], i-j); - } -#endif - i++; - j = i; - } else { - i++; - } - } - *ep = i; - vs_push(Cnil); - while (vs_top > vsp) - stack_cons(); - if (i == j) { - /* no file and no type */ - vs_push(Cnil); - vs_push(Cnil); - goto L; - } - for (k = j, d = -1; k < i; k++) - if (s->st.st_self[k] == '.') - d = k; - if (d == -1) { - /* no file type */ -#ifdef UNIX - if (i-j == 1 && s->st.st_self[j] == '*') -#endif - vs_push(sKwild); - else - make_one(&s->st.st_self[j], i-j); - - vs_push(Cnil); - } else if (d == j) { - /* no file name */ - vs_push(Cnil); -#ifdef UNIX - if (i-d-1 == 1 && s->st.st_self[d+1] == '*') -#endif - vs_push(sKwild); - else - make_one(&s->st.st_self[d+1], i-d-1); - } else { - /* file name and file type */ -#ifdef UNIX - if (d-j == 1 && s->st.st_self[j] == '*') -#endif - vs_push(sKwild); - else { - make_one(&s->st.st_self[j], d-j); - } -#ifdef UNIX - if (i-d-1 == 1 && s->st.st_self[d+1] == '*') -#endif - vs_push(sKwild); - else - make_one(&s->st.st_self[d+1], i-d-1); - } - } -L: - /* Process DOS device name found earlier, build a string in a list and push it */ - if ( founddosdev ) { - /* Drive letter */ - token->st.st_self[0] = s->st.st_self[oldstart]; - /* Colon */ - token->st.st_self[1] = s->st.st_self[oldstart+1]; - /* Fill pointer */ - token->st.st_fillp = 2; - /* Push */ - vs_push(make_cons(copy_simple_string(token),Cnil)); - } else { - /* No device name */ - vs_push(Cnil); - } - if ( justdevice ) { - x = make_pathname ( Cnil, vs_top[-1], Cnil, Cnil, Cnil, Cnil ); - } else { - x = make_pathname ( Cnil, vs_top[-1], vs_top[-4], vs_top[-3], vs_top[-2], Cnil ); - } - vs_reset; - return(x); -} - -object -coerce_to_pathname(x) -object x; -{ - object y; - int e; - -L: - switch (type_of(x)) { - case t_symbol: - case t_string: - /* !!!!! Bug Fix. NLG */ - y = parse_namestring(x, 0, x->st.st_fillp, &e); - if (y == OBJNULL || e != x->st.st_fillp) - goto CANNOT_COERCE; - return(y); - - case t_pathname: - return(x); - - case t_stream: - switch (x->sm.sm_mode) { - case smm_input: - case smm_output: - case smm_probe: - case smm_io: - x = x->sm.sm_object1; - /* - The file was stored in sm.sm_object1. - See open. - */ - goto L; - case smm_synonym: - x = symbol_value(x->sm.sm_object0); - goto L; - - default: - goto CANNOT_COERCE; - } - - default: - CANNOT_COERCE: - FEerror("~S cannot be coerced to a pathname.", 1, x); - return(Cnil); - } +DEFUN_NEW("C-T-TT",object,fSc_t_tt,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { + RETURN1((object)(fixnum)x->d.tt); } -static object -default_device(host) -object host; -{ - return(Cnil); - /* not implemented yet */ -} - -object -merge_pathnames(path, defaults, default_version) -object path, defaults, default_version; -{ - object host, device, directory, name, type, version; - - if (path->pn.pn_host == Cnil) - host = defaults->pn.pn_host; - else - host = path->pn.pn_host; - if (path->pn.pn_device == Cnil) - if (path->pn.pn_host == Cnil) - device = defaults->pn.pn_device; - else if (path->pn.pn_host == defaults->pn.pn_host) - device = defaults->pn.pn_device; - else - device = default_device(path->pn.pn_host); - else - device = path->pn.pn_device; - if (defaults->pn.pn_directory==Cnil || - (type_of(path->pn.pn_directory)==t_cons - && path->pn.pn_directory->c.c_car==sKroot)) - directory=path->pn.pn_directory; - else - directory=path->pn.pn_directory==Cnil ? - defaults->pn.pn_directory : - append(defaults->pn.pn_directory,path->pn.pn_directory); - - if (path->pn.pn_name == Cnil) - name = defaults->pn.pn_name; - else - name = path->pn.pn_name; - if (path->pn.pn_type == Cnil) - type = defaults->pn.pn_type; - else - type = path->pn.pn_type; - version = Cnil; - /* - In this implimentation, version is not counted - */ - return(make_pathname(host,device,directory,name,type,version)); +DEFUN_NEW("C-SET-PATHNAME-NAMESTRING",object,fSc_set_pathname_namestring,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { + check_type_pathname(&x); + x->pn.pn_namestring=y; + RETURN1(x); } -/* - Namestring(x) converts a pathname to a namestring. -*/ -object -namestring(x) -object x; -{ - - int i, j; - object l, y; - - i = 0; - - l = x->pn.pn_device; - if (endp(l)) { - goto D; - } - y = l->c.c_car; - y = coerce_to_string(y); - for (j = 0; j < y->st.st_fillp; j++) { - token->st.st_self[i++] = y->st.st_self[j]; - } - -D: l = x->pn.pn_directory; - if (endp(l)) - goto L; - y = l->c.c_car; - if (y == sKroot) { -#ifdef UNIX - token->st.st_self[i++] = '/'; -#endif - l = l->c.c_cdr; - } - for (; !endp(l); l = l->c.c_cdr) { - y = l->c.c_car; -#ifdef UNIX - if (y == sKcurrent) { - token->st.st_self[i++] = '.'; - token->st.st_self[i++] = '/'; - continue; - } else if (y == sKwild) { - token->st.st_self[i++] = '*'; - token->st.st_self[i++] = '/'; - continue; - } else if (y == sKparent) { - token->st.st_self[i++] = '.'; - token->st.st_self[i++] = '.'; - token->st.st_self[i++] = '/'; - continue; - } -#endif - y = coerce_to_string(y); - for (j = 0; j < y->st.st_fillp; j++) - token->st.st_self[i++] - = y->st.st_self[j]; -#ifdef UNIX - token->st.st_self[i++] = '/'; -#endif -#ifdef AOSVS - -#endif - } -L: - y = x->pn.pn_name; - if (y == Cnil) - goto M; - if (y == sKwild) { -#ifdef UNIX - token->st.st_self[i++] = '*'; -#endif -#ifdef AOSVS - -#endif - goto M; - } - if (type_of(y) != t_string) - FEerror("~S is an illegal pathname name.", 1, y); - for (j = 0; j < y->st.st_fillp; j++) - token->st.st_self[i++] = y->st.st_self[j]; -M: - y = x->pn.pn_type; - if (y == Cnil) - goto N; - if (y == sKwild) { - token->st.st_self[i++] = '.'; -#ifdef UNIX - token->st.st_self[i++] = '*'; -#endif -#ifdef AOSVS - -#endif - goto N; - } - if (type_of(y) != t_string) - FEerror("~S is an illegal pathname name.", 1, y); - token->st.st_self[i++] = '.'; - for (j = 0; j < y->st.st_fillp; j++) - token->st.st_self[i++] = y->st.st_self[j]; -N: - token->st.st_fillp = i; -#ifdef FIX_FILENAME - {char buf[MAXPATHLEN]; - if (i > MAXPATHLEN-1) i =MAXPATHLEN-1; - memcpy(buf,token->st.st_self,i); - buf[i]=0; - FIX_FILENAME(x,buf); - return (make_simple_string(buf)); - } -#endif - return(copy_simple_string(token)); +DEFUN_NEW("C-PATHNAME-HOST",object,fSc_pathname_host,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_pathname(&x); + RETURN1(x->pn.pn_host); } - -object -coerce_to_namestring(x) -object x; -{ - -L: - switch (type_of(x)) { - case t_symbol: - {BEGIN_NO_INTERRUPT; - vs_push(alloc_simple_string(x->s.s_fillp)); - /* By Nick Gall */ - vs_head->st.st_self = alloc_relblock(x->s.s_fillp); - { - int i; - for (i = 0; i < x->s.s_fillp; i++) - vs_head->st.st_self[i] = x->s.s_self[i]; - } - END_NO_INTERRUPT;} - return(vs_pop); - - case t_string: - return(x); - - case t_pathname: - return(namestring(x)); - - case t_stream: - switch (x->sm.sm_mode) { - case smm_input: - case smm_output: - case smm_probe: - case smm_io: - x = x->sm.sm_object1; - /* - The file was stored in sm.sm_object1. - See open. - */ - goto L; - - case smm_synonym: - x = symbol_value(x->sm.sm_object0); - goto L; - - default: - goto CANNOT_COERCE; - } - - default: - CANNOT_COERCE: - FEerror("~S cannot be coerced to a namestring.", 1, x); - return(Cnil); - } +DEFUN_NEW("C-PATHNAME-DEVICE",object,fSc_pathname_device,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_pathname(&x); + RETURN1(x->pn.pn_device); } - -LFD(Lpathname)(void) -{ - check_arg(1); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); +DEFUN_NEW("C-PATHNAME-DIRECTORY",object,fSc_pathname_directory,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_pathname(&x); + RETURN1(x->pn.pn_directory); } - -@(defun parse_namestring (thing - &o host - (defaults `symbol_value(Vdefault_pathname_defaults)`) - &k start end junk_allowed - &a x y) - int s, e, ee; -@ - check_type_or_pathname_string_symbol_stream(&thing); - check_type_or_pathname_string_symbol_stream(&defaults); - defaults = coerce_to_pathname(defaults); - x = thing; -L: - switch (type_of(x)) { - case t_symbol: - case t_string: - get_string_start_end(x, start, end, &s, &e); - for (; s < e && isspace((int)x->st.st_self[s]); s++) - ; - y - /* !!!!! Bug Fix. NLG */ - = parse_namestring(x, - s, - e - s, - &ee); - if (junk_allowed == Cnil) { - for (; ee < e - s; ee++) - if (!isspace((int)x->st.st_self[s + ee])) - break; - if (y == OBJNULL || ee != e - s) - FEerror("Cannot parse the namestring ~S~%\ -from ~S to ~S.", - 3, x, start, end); - } else - if (y == OBJNULL) - @(return Cnil `make_fixnum(s + ee)`) - start = make_fixnum(s + ee); - break; - - case t_pathname: - y = x; - break; - - case t_stream: - switch (x->sm.sm_mode) { - case smm_input: - case smm_output: - case smm_probe: - case smm_io: - x = x->sm.sm_object1; - /* - The file was stored in sm.sm_object1. - See open. - */ - goto L; - - case smm_synonym: - x = symbol_value(x->sm.sm_object0); - goto L; - - default: - goto CANNOT_PARSE; - } - - default: - CANNOT_PARSE: - FEerror("Cannot parse the namestring ~S.", 1, x); - } - if (host != Cnil && y->pn.pn_host != Cnil && - host != y->pn.pn_host) - FEerror("The hosts ~S and ~S do not match.", - 2, host, y->pn.pn_host); - @(return y start) -@) - -@(defun merge_pathnames (path - &o (defaults `symbol_value(Vdefault_pathname_defaults)`) - (default_version sKnewest)) -@ - check_type_or_pathname_string_symbol_stream(&path); - check_type_or_pathname_string_symbol_stream(&defaults); - path = coerce_to_pathname(path); - defaults = coerce_to_pathname(defaults); - @(return `merge_pathnames(path, defaults, default_version)`) -@) - -@(defun make_pathname (&key - (host `Cnil` host_supplied_p) - (device `Cnil` device_supplied_p) - (directory `Cnil` directory_supplied_p) - (name `Cnil` name_supplied_p) - (type `Cnil` type_supplied_p) - (version `Cnil` version_supplied_p) - defaults - &aux x) -@ - if ( defaults == Cnil ) { - defaults = symbol_value ( Vdefault_pathname_defaults ); - defaults = coerce_to_pathname ( defaults ); - defaults = make_pathname ( defaults->pn.pn_host, - Cnil, Cnil, Cnil, Cnil, Cnil); - } else { - defaults = coerce_to_pathname(defaults); - } - x = make_pathname(host, device, directory, name, type, version); - x = merge_pathnames(x, defaults, Cnil); - if ( host_supplied_p) x->pn.pn_host = host; - if (device_supplied_p) x->pn.pn_device = device; - if (directory_supplied_p) x->pn.pn_directory = directory; - if (name_supplied_p) x->pn.pn_name = name; - if (type_supplied_p) x->pn.pn_type = type; - if (version_supplied_p) x->pn.pn_version = version; - @(return x) -@) - -LFD(Lpathnamep)(void) -{ - check_arg(1); - - if (type_of(vs_base[0]) == t_pathname) - vs_base[0] = Ct; - else - vs_base[0] = Cnil; +DEFUN_NEW("C-PATHNAME-NAME",object,fSc_pathname_name,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_pathname(&x); + RETURN1(x->pn.pn_name); } - -LFD(Lpathname_host)(void) -{ - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] = vs_base[0]->pn.pn_host; +DEFUN_NEW("C-PATHNAME-TYPE",object,fSc_pathname_type,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_pathname(&x); + RETURN1(x->pn.pn_type); } - -LFD(Lpathname_device)(void) -{ - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] = vs_base[0]->pn.pn_device; +DEFUN_NEW("C-PATHNAME-VERSION",object,fSc_pathname_version,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_pathname(&x); + RETURN1(x->pn.pn_version); } - -LFD(Lpathname_directory)(void) -{ - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] = vs_base[0]->pn.pn_directory; +DEFUN_NEW("C-PATHNAME-NAMESTRING",object,fSc_pathname_namestring,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_pathname(&x); + RETURN1(x->pn.pn_namestring); } -LFD(Lpathname_name)(void) -{ - check_arg(1); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] = vs_base[0]->pn.pn_name; +DEFUN_NEW("C-STREAM-OBJECT0",object,fSc_stream_object0,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(x->sm.sm_object0); } -LFD(Lpathname_type)(void) -{ - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] = vs_base[0]->pn.pn_type; +DEFUN_NEW("C-STREAM-OBJECT1",object,fSc_stream_object1,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(x->sm.sm_object1); } -LFD(Lpathname_version)(void) -{ - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] = vs_base[0]->pn.pn_version; +DEFUN_NEW("C-SET-STREAM-OBJECT1",object,fSc_set_stream_object1,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { + x->sm.sm_object1=y; + RETURN1(x); } -LFD(Lnamestring)(void) -{ - check_arg(1); +DEFUN_NEW("INIT-PATHNAME",object,fSinit_pathname,SI,7,7,NONE,OO,OO,OO,OO, + (object host,object device,object directory,object name,object type,object version,object namestring),"") { - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_namestring(vs_base[0]); -} + object x=alloc_object(t_pathname); -LFD(Lfile_namestring)(void) -{ - check_arg(1); + 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; - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] - = make_pathname(Cnil, Cnil, Cnil, - vs_base[0]->pn.pn_name, - vs_base[0]->pn.pn_type, - vs_base[0]->pn.pn_version); - vs_base[0] = namestring(vs_base[0]); -} - -LFD(Ldirectory_namestring)(void) -{ - check_arg(1); + RETURN1(x); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] - = make_pathname(Cnil, Cnil, - vs_base[0]->pn.pn_directory, - Cnil, Cnil, Cnil); - vs_base[0] = namestring(vs_base[0]); } -LFD(Lhost_namestring)(void) -{ - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0] = vs_base[0]->pn.pn_host; - if (vs_base[0] == Cnil || vs_base[0] == sKwild) - vs_base[0] = make_simple_string(""); +DEFUN_NEW("PATHNAMEP",object,fLpathnamep,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_pathname ? Ct : Cnil); } -@(defun enough_namestring (path - &o (defaults `symbol_value(Vdefault_pathname_defaults)`)) -@ - check_type_or_pathname_string_symbol_stream(&path); - check_type_or_pathname_string_symbol_stream(&defaults); - defaults = coerce_to_pathname(defaults); - path = coerce_to_pathname(path); - path - = make_pathname(equalp(path->pn.pn_host, defaults->pn.pn_host) ? - Cnil : path->pn.pn_host, - equalp(path->pn.pn_device, - defaults->pn.pn_device) ? - Cnil : path->pn.pn_device, - equalp(path->pn.pn_directory, - defaults->pn.pn_directory) ? - Cnil : path->pn.pn_directory, - equalp(path->pn.pn_name, defaults->pn.pn_name) ? - Cnil : path->pn.pn_name, - equalp(path->pn.pn_type, defaults->pn.pn_type) ? - Cnil : path->pn.pn_type, - equalp(path->pn.pn_version, - defaults->pn.pn_version) ? - Cnil : path->pn.pn_version); - @(return `namestring(path)`) -@) - void -gcl_init_pathname(void) -{ - Vdefault_pathname_defaults = - make_special("*DEFAULT-PATHNAME-DEFAULTS*", - make_pathname(Cnil, Cnil, Cnil, Cnil, Cnil, Cnil)); +gcl_init_pathname(void) { - sKwild = make_keyword("WILD"); - sKnewest = make_keyword("NEWEST"); - - sKstart = make_keyword("START"); - sKend = make_keyword("END"); - sKjunk_allowed = make_keyword("JUNK-ALLOWED"); - - sKhost = make_keyword("HOST"); - sKdevice = make_keyword("DEVICE"); - sKdirectory = make_keyword("DIRECTORY"); - sKname = make_keyword("NAME"); - sKtype = make_keyword("TYPE"); - sKversion = make_keyword("VERSION"); - sKdefaults = make_keyword("DEFAULTS"); - - sKroot = make_keyword("ROOT"); - sKcurrent = make_keyword("CURRENT"); - sKparent = make_keyword("PARENT"); - sKper = make_keyword("PER"); } void -gcl_init_pathname_function() -{ - make_function("PATHNAME", Lpathname); - make_function("PARSE-NAMESTRING", Lparse_namestring); - make_function("MERGE-PATHNAMES", Lmerge_pathnames); - make_function("MAKE-PATHNAME", Lmake_pathname); - make_function("PATHNAMEP", Lpathnamep); - make_function("PATHNAME-HOST", Lpathname_host); - make_function("PATHNAME-DEVICE", Lpathname_device); - make_function("PATHNAME-DIRECTORY", Lpathname_directory); - make_function("PATHNAME-NAME", Lpathname_name); - make_function("PATHNAME-TYPE", Lpathname_type); - make_function("PATHNAME-VERSION", Lpathname_version); - make_function("NAMESTRING", Lnamestring); - make_function("FILE-NAMESTRING", Lfile_namestring); - make_function("DIRECTORY-NAMESTRING", Ldirectory_namestring); - make_function("HOST-NAMESTRING", Lhost_namestring); - make_function("ENOUGH-NAMESTRING", Lenough_namestring); +gcl_init_pathname_function(void) { + } diff --git a/o/predicate.c b/o/predicate.c index f5456cf..da829cc 100755 --- a/o/predicate.c +++ b/o/predicate.c @@ -29,6 +29,10 @@ Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. #include #include "include.h" +DEFUN_NEW("PATHNAME-DESIGNATORP",object,fSpathname_designatorp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(pathname_designatorp(x) ? Ct : Cnil); +} + DEFUNO_NEW("NULL",object,fLnull,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lnull,(object x0),"") { diff --git a/o/print.d b/o/print.d index 70f3e0e..9f256d3 100755 --- a/o/print.d +++ b/o/print.d @@ -1260,6 +1260,7 @@ int level; write_ch('>'); break; + case smm_file_synonym: case smm_synonym: write_str("#sm.sm_object0, level); @@ -1381,7 +1382,7 @@ int level; if (1 || PRINTescape) { write_ch('#'); write_ch('p'); - vs_push(namestring(x)); + vs_push(x->pn.pn_namestring==Cnil ? make_simple_string("") : x->pn.pn_namestring); write_object(vs_head, level); vs_popp; } else { diff --git a/o/read.d b/o/read.d index baae4d6..00c9822 100755 --- a/o/read.d +++ b/o/read.d @@ -1563,38 +1563,6 @@ Ldefault_dispatch_macro() FEerror("The default dispatch macro signalled an error.", 0); } -/* - #p" ... " returns the pathname with namestring ... . -*/ -static void -Lsharp_p_reader() -{ - check_arg(3); - if (vs_base[2] != Cnil && !READsuppress) - extra_argument('p'); - vs_popp; - vs_popp; - vs_base[0] = read_object(vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); -} - -/* - #" ... " returns the pathname with namestring ... . -*/ -static void -Lsharp_double_quote_reader() -{ - check_arg(3); - - if (vs_base[2] != Cnil && !READsuppress) - extra_argument('"'); - vs_popp; - unread_char(vs_base[1], vs_base[0]); - vs_popp; - vs_base[0] = read_object(vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); -} - /* #$ fixnum returns a random-state with the fixnum as its content. @@ -2369,9 +2337,6 @@ gcl_init_read() dtab['<'] = make_cf(Lsharp_less_than_reader); */ dtab['|'] = make_cf(Lsharp_vertical_bar_reader); - dtab['"'] = make_cf(Lsharp_double_quote_reader); - dtab['p'] = make_cf(Lsharp_p_reader); - dtab['P'] = make_cf(Lsharp_p_reader); /* This is specific to this implimentation */ dtab['$'] = make_cf(Lsharp_dollar_reader); /* This is specific to this implimentation */ diff --git a/o/regexp.c b/o/regexp.c index 11a0503..8bb832c 100755 --- a/o/regexp.c +++ b/o/regexp.c @@ -117,7 +117,7 @@ min_initial_branch_length(regexp *, unsigned char *, int); #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 30 /* no Analogous to OPEN. */ +#define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */ /* * Opcode notes: @@ -1083,15 +1083,8 @@ regmatch(char *prog) break; case BACK: break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: { + case OPEN+1 ... OPEN+NSUBEXP-1: + { register int no; register char *save; @@ -1112,15 +1105,8 @@ regmatch(char *prog) } /* NOTREACHED */ break; - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: { + case CLOSE+1 ... CLOSE+NSUBEXP-1: + { register int no; register char *save; @@ -1394,27 +1380,11 @@ char *op; case END: p = "END"; break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: + case OPEN+1 ... OPEN+NSUBEXP-1: sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); p = NULL; break; - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: + case CLOSE+1 ... CLOSE+NSUBEXP-1: sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); p = NULL; break; diff --git a/o/regexp.h b/o/regexp.h index e87e9f0..8535654 100755 --- a/o/regexp.h +++ b/o/regexp.h @@ -1,7 +1,7 @@ #ifndef _REGEXP #define _REGEXP 1 -#define NSUBEXP 10 +#define NSUBEXP 19 typedef struct regexp { char *startp[NSUBEXP]; char *endp[NSUBEXP]; diff --git a/o/regexpr.c b/o/regexpr.c index 93f177b..74f8a7e 100755 --- a/o/regexpr.c +++ b/o/regexpr.c @@ -81,6 +81,7 @@ DEFUN_NEW("COMPILE-REGEXP",object,fScompile_regexp,SI,1,1,NONE,OO,OO,OO,OO,(obje res->v.v_elttype=aet_uchar; res->v.v_adjustable=0; res->v.v_offset=0; + res->v.v_self=NULL; if (!(res->v.v_self=(void *)regcomp(tmp,&res->v.v_dim))) FEerror("regcomp failure",0); res->v.v_fillp=res->v.v_dim; diff --git a/o/run_process.c b/o/run_process.c index 3dce94b..288d6de 100755 --- a/o/run_process.c +++ b/o/run_process.c @@ -177,10 +177,12 @@ void run_process ( char *name ) stream_in->sm.sm_mode = smm_input; stream_in->sm.sm_fp = ofp; stream_in->sm.sm_buffer = 0; + stream_in->sm.sm_flags=0; stream_out = (object) alloc_object(t_stream); stream_out->sm.sm_mode = smm_output; stream_out->sm.sm_fp = ifp; stream_out->sm.sm_buffer = 0; + stream_out->sm.sm_flags=0; setup_stream_buffer ( stream_in ); setup_stream_buffer ( stream_out ); stream = make_two_way_stream ( stream_in, stream_out ); @@ -433,6 +435,7 @@ enum smmode smm; stream->sm.sm_object0 = sLcharacter; stream->sm.sm_object1 = host_l; stream->sm.sm_int0 = stream->sm.sm_int1 = 0; + stream->sm.sm_flags=0; vs_push(stream); setup_stream_buffer(stream); vs_reset; @@ -503,6 +506,7 @@ make_socket_pair() stream_in->sm.sm_int0 = sockets_in[1]; stream_in->sm.sm_int1 = 0; stream_in->sm.sm_object0=stream_in->sm.sm_object1=OBJNULL; + stream_in->sm.sm_flags = 0; stream_out = (object) alloc_object(t_stream); stream_out->sm.sm_mode = smm_output; stream_out->sm.sm_fp = fp2; @@ -511,6 +515,7 @@ make_socket_pair() setup_stream_buffer(stream_out); stream_out->sm.sm_int0 = sockets_out[1]; stream_out->sm.sm_int1 = 0; + 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); diff --git a/o/sfaslcoff.c b/o/sfaslcoff.c index ae6e481..d2cea90 100644 --- a/o/sfaslcoff.c +++ b/o/sfaslcoff.c @@ -151,6 +151,16 @@ find_init_address(struct syment *sym,struct syment *sye,ul *ptr,char *st1) { } +static ul +get_sym_value(const char *name) { + + struct node *answ; + + return (answ=find_sym_ptable(name)) ? answ->address : + ({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) { @@ -163,22 +173,10 @@ relocate_symbols(struct syment *sym,struct syment *sye,struct scnhdr *sec1,char else if (!sym->n_scnum) { - char c=0,*s; - - if (sym->n.n.n_zeroes) { - c=sym->n.n_name[8]; - sym->n.n_name[8]=0; - s=sym->n.n_name; - } else - s=st1+sym->n.n.n_offset; - - if ((answ=find_sym_ptable(s))) - sym->n_value=answ->address; + if (sym->n.n.n_zeroes) + STOP(sym->n.n_name,sym->n_value=get_sym_value(sym->n.n_name)); else - massert(!emsg("Unrelocated non-local symbol: %s\n",s)); - - if (c) - sym->n.n_name[8]=c; + sym->n_value=get_sym_value(st1+sym->n.n.n_offset); } @@ -391,13 +389,11 @@ fasload(object faslfile) { struct reloc *rel,*rele; object memory, data; FILE *fp; - char filename[MAXPATHLEN],*st1,*ste; + char *st1,*ste; int i; ul init_address=0; void *st,*est; - coerce_to_filename(faslfile, filename); - faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); fp = faslfile->sm.sm_fp; massert(st=get_mmap(fp,&est)); @@ -427,7 +423,6 @@ fasload(object faslfile) { data = read_fasl_vector(faslfile); massert(!un_mmap(st,est)); - close_stream(faslfile); #ifdef CLEAR_CACHE CLEAR_CACHE; diff --git a/o/sfaslelf.c b/o/sfaslelf.c index 8bc47a4..f649fa4 100755 --- a/o/sfaslelf.c +++ b/o/sfaslelf.c @@ -542,15 +542,13 @@ int fasload(object faslfile) { FILE *fp; - char filename[256],*sn,*st1,*dst1; + char *sn,*st1,*dst1; ul init_address=0,end,gs=0,*got=&gs,*gote=got+1; object memory,data; Shdr *sec1,*sece; Sym *sym1,*syme,*dsym1,*dsyme; void *v1,*ve; - coerce_to_filename(faslfile, filename); - faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); fp = faslfile->sm.sm_fp; massert(v1=get_mmap(fp,&ve)); @@ -573,7 +571,6 @@ fasload(object faslfile) { data=feof(fp) ? 0 : read_fasl_vector(faslfile); massert(!un_mmap(v1,ve)); - close_stream(faslfile); massert(!clear_protect_memory(memory)); diff --git a/o/sfaslmacho.c b/o/sfaslmacho.c index 8b3c811..39a2b57 100644 --- a/o/sfaslmacho.c +++ b/o/sfaslmacho.c @@ -524,7 +524,6 @@ fasload(object faslfile) { FILE *fp; object data; - char filename[256]; ul init_address=-1; object memory; void *v1,*ve,*p; @@ -533,8 +532,6 @@ fasload(object faslfile) { char *st1=NULL,*ste=NULL; ul gs,*got=&gs,*gote,*io1=NULL,rls,start; - coerce_to_filename(faslfile, filename); - faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); fp = faslfile->sm.sm_fp; massert(v1=get_mmap(fp,&ve)); @@ -563,7 +560,6 @@ fasload(object faslfile) { #endif massert(!un_mmap(v1,ve)); - close_stream(faslfile); init_address-=(ul)memory->cfd.cfd_start; call_init(init_address,memory,data,0); diff --git a/o/sgbc.c b/o/sgbc.c index 8261690..9dc6438 100755 --- a/o/sgbc.c +++ b/o/sgbc.c @@ -717,7 +717,7 @@ sgc_start(void) { void *p=NULL,*pe; struct pageinfo *pi; ufixnum i; - + old_cb_pointer=cb_pointer; reset_contblock_freelist(); @@ -774,6 +774,8 @@ sgc_start(void) { 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; @@ -787,7 +789,7 @@ sgc_start(void) { Turn memory protection on for the pages which are writable. */ sgc_enabled=1; - if (memory_protect(1)) + if (memory_protect(1)) sgc_quit(); if (sSAnotify_gbcA->s.s_dbind != Cnil) emsg("[SGC on]"); @@ -897,7 +899,7 @@ sgc_quit(void) { 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)); @@ -931,7 +933,7 @@ memprotect_handler(int sig, long code, void *scp, char *addr) { #endif if (faddr >= (void *)core_end || faddr < data_start) { static void *old_faddr; - if (old_faddr==faddr) + if (old_faddr==faddr) if (fault_count++ > 300) error("fault count too high"); old_faddr=faddr; INSTALL_MPROTECT_HANDLER; @@ -1017,7 +1019,7 @@ memory_protect(int on) { if (writable==WRITABLE_PAGE_P(i) && ism.sm_fp); #endif -static void -FFN(siLfaslink)(void) -{ - bds_ptr old_bds_top; - int i; - object package; - - check_arg(2); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - check_type_string(&vs_base[1]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[0]->pn.pn_type = FASL_string; - vs_base[0] = namestring(vs_base[0]); - package = symbol_value(sLApackageA); - old_bds_top = bds_top; - bds_bind(sLApackageA, package); - i = faslink(vs_base[0], vs_base[1]); - bds_unwind(old_bds_top); - vs_top = vs_base; - vs_push(make_fixnum(i)); -} - #endif #endif/* svr4 */ #endif /* UNIXFASL */ void -gcl_init_unixfasl(void) -{ -#ifdef FASLINK - make_si_function("FASLINK", siLfaslink); -#endif +gcl_init_unixfasl(void) { } diff --git a/o/unixfsys.c b/o/unixfsys.c index ea2f9dd..be5885e 100755 --- a/o/unixfsys.c +++ b/o/unixfsys.c @@ -44,10 +44,6 @@ Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. #define HAVE_RENAME #endif -void Ldirectory(void); - - - #ifdef NEED_GETWD #include @@ -168,17 +164,41 @@ getwd(char *buffer) { b_[_c+_d]=0;\ }) +static object +get_string(object x) { + switch(type_of(x)) { + case t_symbol: + case t_string: + return x; + case t_pathname: + return x->pn.pn_namestring; + case t_stream: + switch(x->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_probe: + case smm_io: + return get_string(x->sm.sm_object1); + case smm_file_synonym: + case smm_synonym: + return get_string(x->sm.sm_object0->s.s_dbind); + } + } + return Cnil; +} + + void coerce_to_filename(object pathname,char *p) { - object namestring=coerce_to_namestring(pathname); + object namestring=get_string(pathname); unsigned e=namestring->st.st_fillp; - char *q=namestring->st.st_self,*qe=q+e;; + char *q=namestring->st.st_self,*qe=q+e; - if (pathname==Cnil) + if (pathname==Cnil||namestring==Cnil) FEerror ( "NIL argument.", 1, pathname ); - if (*q=='~') { + if (*q=='~' && e) { unsigned m=0; char *s=++q,*c; @@ -224,134 +244,6 @@ coerce_to_filename(object pathname,char *p) { } -object -truename(object pathname) -{ - register char *p, *q; - char filename[MAXPATHLEN]; - char truefilename[MAXPATHLEN]; - char current_directory[MAXPATHLEN]; - char directory[MAXPATHLEN]; -#ifdef __MINGW32__ - DWORD current_directory_length = - GetCurrentDirectory ( MAXPATHLEN, current_directory ); - if ( MAXPATHLEN < current_directory_length ) { - FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); - } - if ( 0 == current_directory_length ) { - FEerror ( "truename could not determine the current directory.", 1, "" ); - } -#else - massert(current_directory==getcwd(current_directory,sizeof(current_directory))); -#endif - - coerce_to_filename(pathname, filename); - -#ifdef S_IFLNK - { - - struct stat filestatus; - int islinkcount=8; - - if (lstat(filename, &filestatus) >= 0) - - while (((filestatus.st_mode&S_IFMT) == S_IFLNK) && (--islinkcount>0)) { - - char newname[MAXPATHLEN]; - int newlen; - - newlen=readlink(filename,newname,MAXPATHLEN-1); - if (newlen < 0) - return((FEerror("Symlink broken at ~S.",1,pathname),Cnil)); - - for (p = filename, q = 0; *p != '\0'; p++) - if (*p == '/') q = p; - if (q == 0 || *newname == '/') - q = filename; - else - q++; - - memcpy(q,newname,newlen); - q[newlen]=0; - if (lstat(filename, &filestatus) < 0) - islinkcount=0; /* It would be ANSI to do the following : - return(file_error("Symlink broken at ~S.",pathname)); - but this would break DIRECTORY if a file points to nowhere */ - } - } -#endif - - for (p = filename, q = 0; *p != '\0'; p++) - if (*p == '/') - q = p; - if (q == filename) { - q++; - p = "/"; - } else if (q == 0) { - q = filename; - p = current_directory; - } else -#ifdef __MINGW32__ - if ( ( q > filename ) && ( q[-1] == ':' ) ) { - int current = (q++, q[0]); - q[0]=0; - if (chdir(filename) < 0) - FEerror("Cannot get the truename of ~S.", 1, pathname); - current_directory_length = - GetCurrentDirectory ( MAXPATHLEN, directory ); - if ( MAXPATHLEN < current_directory_length ) { - FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); - } - if ( 0 == current_directory_length ) { - FEerror ( "truename could not determine the current directory.", 1, "" ); - } - p = directory; - if ( p[1]==':' && ( p[2]=='\\' || p[2]=='/' ) && p[3]==0 ) p[2]=0; - q[0]=current; - } - else -#endif - { - *q++ = '\0'; - if (chdir(filename) < 0) - FEerror("Cannot get the truename of ~S.", 1, pathname); -#ifdef __MINGW32__ - current_directory_length = GetCurrentDirectory ( MAXPATHLEN, directory ); - if ( MAXPATHLEN < current_directory_length ) { - FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); - } - if ( 0 == current_directory_length ) { - FEerror ( "truename could not determine the current directory.", 1, "" ); - } - p = directory; -#else - p = getcwd(directory,sizeof(directory)); -#endif - } - if (p[0] == '/' && p[1] == '\0') { - if (strcmp(q, "..") == 0) - strcpy(truefilename, "/."); - else - sprintf(truefilename, "/%s", q); - } else if (strcmp(q, ".") == 0) - strcpy(truefilename, p); - else if (strcmp(q, "..") == 0) { - for (q = p + strlen(p); *--q != '/';) ; - if (p == q) - strcpy(truefilename, "/."); - else { - *q = '\0'; - strcpy(truefilename, p); - *q = '/'; - } - } else - sprintf(truefilename, "%s/%s", p, q); - massert(!chdir(current_directory)); - vs_push(make_simple_string(truefilename)); - pathname = coerce_to_pathname(vs_head); - vs_popp; - return(pathname); -} object sSAallow_gzipped_fileA; bool @@ -429,41 +321,6 @@ file_len(FILE *fp) else return 0; } -LFD(Ltruename)(void) -{ - check_arg(1); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = truename(vs_base[0]); -} - -LFD(Lrename_file)(void) -{ - char filename[MAXPATHLEN]; - char newfilename[MAXPATHLEN]; - - check_arg(2); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - check_type_or_Pathname_string_symbol(&vs_base[1]); - coerce_to_filename(vs_base[0], filename); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_base[1] = coerce_to_pathname(vs_base[1]); - vs_base[1] = merge_pathnames(vs_base[1], vs_base[0], Cnil); - coerce_to_filename(vs_base[1], newfilename); -#ifdef HAVE_RENAME - if (rename(filename, newfilename) < 0) - FEerror("Cannot rename the file ~S to ~S.", - 2, vs_base[0], vs_base[1]); -#else - sprintf(command, "mv %s %s", filename, newfilename); - msystem(command); -#endif - vs_push(vs_base[1]); - vs_push(truename(vs_base[0])); - vs_push(truename(vs_base[1])); - vs_base += 2; -} - - DEF_ORDINARY("DIRECTORY",sKdirectory,KEYWORD,""); DEF_ORDINARY("LINK",sKlink,KEYWORD,""); DEF_ORDINARY("FILE",sKfile,KEYWORD,""); @@ -500,33 +357,28 @@ int gcl_putc(int i,void *v) {return putc(i,((FILE *)v));} -DEFUN_NEW("STAT",object,fSstat,SI,1,1,NONE,OO,OO,OO,OO,(object path),"") { +DEFUNM_NEW("STAT",object,fSstat,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { - char filename[4096]; struct stat ss; - - bzero(filename,sizeof(filename)); - coerce_to_filename(path,filename); + check_type_string(&x); + coerce_to_filename(x,FN1); + #ifdef __MINGW32__ { - char *p=filename+strlen(filename)-1; - for (;p>filename && *p=='/';p--) + char *p=FN1+strlen(FN1)-1; + for (;p>FN1 && *p=='/';p--) *p=0; } #endif - if (lstat(filename,&ss)) + if (lstat(FN1,&ss)) RETURN1(Cnil); - else {/* ctime_r insufficiently portable */ - /* int j; - ctime_r(&ss.st_ctime,filename); - j=strlen(filename); - if (isspace(filename[j-1])) - filename[j-1]=0;*/ - RETURN1(list(3,S_ISDIR(ss.st_mode) ? sKdirectory : - (S_ISLNK(ss.st_mode) ? sKlink : sKfile), - make_fixnum(ss.st_size),make_fixnum(ss.st_ctime))); - } + else + RETURN4(S_ISDIR(ss.st_mode) ? sKdirectory : + (S_ISLNK(ss.st_mode) ? sKlink : sKfile), + make_fixnum(ss.st_size), + make_fixnum(ss.st_ctime), + make_fixnum(ss.st_uid)); } DEFUN_NEW("SETENV",object,fSsetenv,SI,2,2,NONE,OO,OO,OO,OO,(object variable,object value),"Set environment VARIABLE to VALUE") @@ -551,266 +403,6 @@ DEFUN_NEW("SETENV",object,fSsetenv,SI,2,2,NONE,OO,OO,OO,OO,(object variable,obje RETURN1((res == 0 ? Ct : Cnil )); } -DEFUNO_NEW("DELETE-FILE",object,fLdelete_file,LISP - ,1,1,NONE,OO,OO,OO,OO,void,Ldelete_file,(object path),"") - -{ - char filename[MAXPATHLEN]; - - /* 1 args */ - check_type_or_pathname_string_symbol_stream(&path); - coerce_to_filename(path, filename); - if (unlink(filename) < 0 && rmdir(filename) < 0) - FEerror("Cannot delete the file ~S: ~s.", 2, path, make_simple_string(strerror(errno))); - path = Ct; - RETURN1(path); -} -#ifdef STATIC_FUNCTION_POINTERS -object -fLdelete_file(object path) { - return FFN(fLdelete_file)(path); -} -#endif - -LFD(Lprobe_file)(void) -{ - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - if (file_exists(vs_base[0])) - vs_base[0] = truename(vs_base[0]); - else - vs_base[0] = Cnil; -} - -LFD(Lfile_write_date)(void) -{ - char filename[MAXPATHLEN]; - struct stat filestatus; - - check_arg(1); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - coerce_to_filename(vs_base[0], filename); - if (stat(filename, &filestatus) < 0 || S_ISDIR(filestatus.st_mode)) - { vs_base[0] = Cnil; return;} - vs_base[0] = unix_time_to_universal_time(filestatus.st_mtime); -} - -LFD(Lfile_author)(void) -{ -#if !defined(NO_PWD_H) && !defined(STATIC_LINKING) - char filename[MAXPATHLEN]; - struct stat filestatus; - struct passwd *pwent; -#ifndef __STDC__ - extern struct passwd *getpwuid(); -#endif - - check_arg(1); - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - coerce_to_filename(vs_base[0], filename); - if (stat(filename, &filestatus) < 0 || S_ISDIR(filestatus.st_mode)) - { vs_base[0] = Cnil; return;} - pwent = getpwuid(filestatus.st_uid); - vs_base[0] = make_simple_string(pwent->pw_name); -#else - vs_base[0] = Cnil; return; -#endif - -} - -static void -FFN(Luser_homedir_pathname)(void) -{ - - char filename[MAXPATHLEN]; - - coerce_to_filename(make_simple_string("~/"),filename); - vs_base[0]=coerce_to_pathname(make_simple_string(filename)); - vs_top = vs_base+1; - -} - - -#ifdef BSD -LFD(Ldirectory)(void) -{ - char filename[MAXPATHLEN]; - char command[MAXPATHLEN * 2]; - FILE *fp; - register int i, c; - object *top = vs_top; - char iobuffer[BUFSIZ]; - extern FILE *popen(const char *, const char *); - - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - if (vs_base[0]->pn.pn_name==Cnil && vs_base[0]->pn.pn_type==Cnil) { - coerce_to_filename(vs_base[0], filename); - strcat(filename, "*"); - } else if (vs_base[0]->pn.pn_name==Cnil) { - vs_base[0]->pn.pn_name = sKwild; - coerce_to_filename(vs_base[0], filename); - vs_base[0]->pn.pn_name = Cnil; - } else if (vs_base[0]->pn.pn_type==Cnil) { - coerce_to_filename(vs_base[0], filename); - strcat(filename, "*"); - } else - coerce_to_filename(vs_base[0], filename); - sprintf(command, "ls -d %s 2> /dev/null", filename); - fp = popen(command, "r"); - setbuf(fp, iobuffer); - for (;;) { - for (i = 0; (c = getc(fp)); i++) - if (c <= 0) - goto L; - else if (c == '\n') - break; - else - filename[i] = c; - filename[i] = '\0'; - vs_push(make_simple_string(filename)); - vs_head = truename(vs_head); - } -L: - pclose(fp); - vs_push(Cnil); - while (vs_top > top + 1) - stack_cons(); - vs_base = top; -} -#endif - - -#ifdef ATT -LFD(Ldirectory)() -{ - object name, type; - char filename[MAXPATHLEN]; - FILE *fp; - object *top = vs_top; - char iobuffer[BUFSIZ]; - struct direct dir; - int i; - - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_push(vs_base[0]->pn.pn_name); - vs_push(vs_base[0]->pn.pn_type); - vs_base[0]->pn.pn_name = Cnil; - vs_base[0]->pn.pn_type = Cnil; - coerce_to_filename(vs_base[0], filename); - type = vs_base[0]->pn.pn_type = vs_pop; - name = vs_base[0]->pn.pn_name = vs_pop; - i = strlen(filename); - if (i > 1 && filename[i-1] == '/') - filename[i-1] = '\0'; - if (i == 0) - strcpy(filename, "."); - fp = fopen(filename, "r"); - if (fp == NULL) { - vs_push(make_simple_string(filename)); - FEerror("Can't open the directory ~S.", 1, vs_head); - } - setbuf(fp, iobuffer); - fread(&dir, sizeof(struct direct), 1, fp); - fread(&dir, sizeof(struct direct), 1, fp); - filename[DIRSIZ] = '\0'; - for (;;) { - if (fread(&dir, sizeof(struct direct), 1, fp) <=0) - break; - if (dir.d_ino == 0) - continue; - strncpy(filename, dir.d_name, DIRSIZ); - vs_push(make_simple_string(filename)); - vs_head = coerce_to_pathname(vs_head); - if ((name == Cnil || name == sKwild || - equal(name, vs_head->pn.pn_name)) && - (type == Cnil || type == sKwild || - equal(type, vs_head->pn.pn_type))) { - vs_head->pn.pn_directory - = vs_base[0]->pn.pn_directory; - vs_head = truename(vs_head); - } else - vs_pop; - } - fclose(fp); - vs_push(Cnil); - while (vs_top > top + 1) - stack_cons(); - vs_base = top; -} -#endif - - -#ifdef E15 -#include - -LFD(Ldirectory)() -{ - object name, type; - char filename[MAXPATHLEN]; - FILE *fp; - object *top = vs_top; - char iobuffer[BUFSIZ]; - struct direct dir; - int i; - - check_arg(1); - - check_type_or_pathname_string_symbol_stream(&vs_base[0]); - vs_base[0] = coerce_to_pathname(vs_base[0]); - vs_push(vs_base[0]->pn.pn_name); - vs_push(vs_base[0]->pn.pn_type); - vs_base[0]->pn.pn_name = Cnil; - vs_base[0]->pn.pn_type = Cnil; - coerce_to_filename(vs_base[0], filename); - type = vs_base[0]->pn.pn_type = vs_pop; - name = vs_base[0]->pn.pn_name = vs_pop; - i = strlen(filename); - if (i > 1 && filename[i-1] == '/') - filename[i-1] = '\0'; - if (i == 0) - strcpy(filename, "."); - fp = fopen(filename, "r"); - if (fp == NULL) { - vs_push(make_simple_string(filename)); - FEerror("Can't open the directory ~S.", 1, vs_head); - } - setbuf(fp, iobuffer); - fread(&dir, sizeof(struct direct), 1, fp); - fread(&dir, sizeof(struct direct), 1, fp); - filename[DIRSIZ] = '\0'; - for (;;) { - if (fread(&dir, sizeof(struct direct), 1, fp) <=0) - break; - if (dir.d_ino == 0) - continue; - strncpy(filename, dir.d_name, DIRSIZ); - vs_push(make_simple_string(filename)); - vs_head = coerce_to_pathname(vs_head); - if ((name == Cnil || name == sKwild || - equal(name, vs_head->pn.pn_name)) && - (type == Cnil || type == sKwild || - equal(type, vs_head->pn.pn_type))) { - vs_head->pn.pn_directory - = vs_base[0]->pn.pn_directory; - vs_head = truename(vs_head); - } else - vs_pop; - } - fclose(fp); - vs_push(Cnil); - while (vs_top > top + 1) - stack_cons(); - vs_base = top; -} -#endif - #include #include @@ -840,17 +432,31 @@ DEFUN_NEW("D-TYPE-LIST",object,fSd_type_list,SI,0,0,NONE,OI,OO,OO,OO,(void),"") } #endif -DEFUN_NEW("READDIR",object,fSreaddir,SI,2,2,NONE,OI,IO,OO,OO,(fixnum x,fixnum y),"") { +DEFUN_NEW("READDIR",object,fSreaddir,SI,3,3,NONE,OI,IO,OO,OO,(fixnum x,fixnum y,object s),"") { struct dirent *e; object z; + long tl; + size_t l; if (!x) RETURN1(Cnil); - e=readdir((DIR *)x); - RETURN1(e ? make_simple_string(e->d_name) : Cnil); + tl=telldir((DIR *)x); #ifdef HAVE_D_TYPE for (;(e=readdir((DIR *)x)) && y!=DT_UNKNOWN && e->d_type!=y;); #endif if (!e) RETURN1(Cnil); - z=make_simple_string(e->d_name); + 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)); + } + } #ifdef HAVE_D_TYPE if (y==DT_UNKNOWN) z=MMcons(z,make_fixnum(e->d_type)); #endif @@ -882,7 +488,126 @@ DEFUN_NEW("MKDIR",object,fSmkdir,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { } +DEFUN_NEW("RMDIR",object,fSrmdir,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_string(&x); + + coerce_to_filename(x,FN1); + + RETURN1(rmdir(FN1) ? Cnil : Ct); + +} + + + +#include +#include +#include +#include + +DEFUN_NEW("READLINKAT",object,fSreadlinkat,SI,2,2,NONE,OI,OO,OO,OO,(fixnum d,object s),"") { + char *b1,*b2=NULL; + ssize_t l,z1,z2; + check_type_string(&s); + /* l=s->st.st_hasfillp ? s->st.st_fillp : s->st.st_dim; */ + z1=length(s); + massert((b1=alloca(z1+1))); + memcpy(b1,s->st.st_self,z1); + b1[z1]=0; + for (l=z2=0;l>=z2;) { + memset(b2,0,z2); + z2+=z2+10; + massert((b2=alloca(z2))); + massert((l=readlinkat(d ? dirfd((DIR *)d) : AT_FDCWD,b1,b2,z2))>=0); + } + b2[l]=0; + s=make_simple_string(b2); + memset(b1,0,z1); + memset(b2,0,z2); + RETURN1(s); +} + +DEFUN_NEW("GETCWD",object,fSgetcwd,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + char *b=NULL; + size_t z; + object s; + + for (z=0;!(errno=0) && !getcwd(b,z) && errno==ERANGE;b=memset(b,0,z),z+=z+10,({massert((b=alloca(z)));})); + massert((b=getcwd(b,z))); + s=make_simple_string(b); + memset(b,0,z); + RETURN1(s); + +} + +DEFUN_NEW("UID-TO-NAME",object,fSuid_to_name,SI,1,1,NONE,OI,OO,OO,OO,(fixnum uid),"") { + struct passwd *pwent,pw; + char *b; + long r; + + massert((r=sysconf(_SC_GETPW_R_SIZE_MAX))>=0); + massert(b=alloca(r)); + + massert(!getpwuid_r(uid,&pw,b,r,&pwent)); + + RETURN1(make_simple_string(pwent->pw_name)); + +} + +DEFUN_NEW("HOME-NAMESTRING",object,fShome_namestring,SI,1,1,NONE,OO,OO,OO,OO,(object nm),"") { + + struct passwd *pwent,pw; + char *b; + long r; + + massert((r=sysconf(_SC_GETPW_R_SIZE_MAX))>=0); + massert(b=alloca(r)); + + if (nm->st.st_fillp==1) + + if ((pw.pw_dir=getenv("HOME"))) + pwent=&pw; + else + massert(!getpwuid_r(getuid(),&pw,b,r,&pwent)); + + else { + + char *name; + + massert(name=alloca(nm->st.st_fillp)); + memcpy(name,nm->st.st_self+1,nm->st.st_fillp-1); + name[nm->st.st_fillp-1]=0; + + massert(!getpwnam_r(name,&pw,b,r,&pwent)); + + } + + massert((b=alloca(strlen(pwent->pw_dir)+2))); + memcpy(b,pwent->pw_dir,strlen(pwent->pw_dir)); + b[strlen(pwent->pw_dir)]='/'; + b[strlen(pwent->pw_dir)+1]=0; + RETURN1(make_simple_string(b)); + +} + +DEFUN_NEW("RENAME",object,fSrename,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { + check_type_string(&x); + check_type_string(&y); + + coerce_to_filename(x,FN1); + coerce_to_filename(y,FN2); + + RETURN1(rename(FN1,FN2) ? Cnil : Ct); + +} + +DEFUN_NEW("UNLINK",object,fSunlink,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + + coerce_to_filename(x,FN1); + + RETURN1(unlink(FN1) ? Cnil : Ct); + +} static void @@ -900,16 +625,8 @@ FFN(siLchdir)(void) } void -gcl_init_unixfsys(void) -{ - make_function("TRUENAME", Ltruename); - make_function("RENAME-FILE", Lrename_file); - make_function("DELETE-FILE", Ldelete_file); - make_function("PROBE-FILE", Lprobe_file); - make_function("FILE-WRITE-DATE", Lfile_write_date); - make_function("FILE-AUTHOR", Lfile_author); - make_function("USER-HOMEDIR-PATHNAME", Luser_homedir_pathname); - make_function("DIRECTORY", Ldirectory); - - make_si_function("CHDIR", siLchdir); +gcl_init_unixfsys(void) { + + make_si_function("CHDIR", siLchdir); + } diff --git a/o/usig.c b/o/usig.c index e3d28ab..f38c5e5 100755 --- a/o/usig.c +++ b/o/usig.c @@ -148,13 +148,15 @@ DEFUN_NEW("FLD",object,fSfld,SI,1,1,NONE,OI,OO,OO,OO,(fixnum val),"") { #endif -DEFUN_NEW("*FIXNUM",fixnum,fSAfixnum,SI,1,1,NONE,II,OO,OO,OO,(fixnum addr),"") { - RETURN1(*(fixnum *)addr); +/* For now ignore last three args governing offsets and data modification, just to + support fpe sync with master*/ +DEFUN_NEW("*FIXNUM",object,fSAfixnum,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") { + RETURN1((object)*(fixnum *)addr); } -DEFUN_NEW("*FLOAT",object,fSAfloat,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") { +DEFUN_NEW("*FLOAT",object,fSAfloat,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") { RETURN1(make_shortfloat(*(float *)addr)); } -DEFUN_NEW("*DOUBLE",object,fSAdouble,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") { +DEFUN_NEW("*DOUBLE",object,fSAdouble,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") { RETURN1(make_longfloat(*(double *)addr)); } @@ -264,7 +266,6 @@ sigpipe(void) FEerror("Broken pipe", 0); } - void sigint(void) { @@ -272,8 +273,6 @@ sigint(void) terminal_interrupt(1); } - - static void sigalrm(void) { diff --git a/unixport/sys_ansi_gcl.c b/unixport/sys_ansi_gcl.c index a2a635c..83a21b6 100644 --- a/unixport/sys_ansi_gcl.c +++ b/unixport/sys_ansi_gcl.c @@ -41,7 +41,6 @@ gcl_init_system(object no_init) #ifdef HAVE_JAPI_H ar_check_init(gcl_japi,no_init); #endif - ar_check_init(gcl_iolib,no_init); ar_check_init(gcl_listlib,no_init); ar_check_init(gcl_mislib,no_init); ar_check_init(gcl_numlib,no_init); @@ -56,9 +55,23 @@ gcl_init_system(object no_init) ar_check_init(gcl_defpackage,no_init); ar_check_init(gcl_make_defpackage,no_init); ar_check_init(gcl_sharp,no_init); - ar_check_init(gcl_fpe,no_init); + ar_check_init(gcl_sharp_uv,no_init); + ar_check_init(gcl_namestring,no_init); + ar_check_init(gcl_logical_pathname_translations,no_init); + ar_check_init(gcl_make_pathname,no_init); + ar_check_init(gcl_parse_namestring,no_init); + ar_check_init(gcl_translate_pathname,no_init); + ar_check_init(gcl_directory,no_init); + ar_check_init(gcl_merge_pathnames,no_init); + ar_check_init(gcl_truename,no_init); + ar_check_init(gcl_rename_file,no_init); + ar_check_init(gcl_wild_pathname_p,no_init); + ar_check_init(gcl_pathname_match_p,no_init); + ar_check_init(gcl_iolib,no_init); + ar_check_init(gcl_fpe,no_init); + ar_check_init(gcl_cmpinline,no_init); ar_check_init(gcl_cmputil,no_init); @@ -107,6 +120,7 @@ gcl_init_system(object no_init) ar_check_init(gcl_index,no_init); #endif + lsp_init("../pcl/package.lisp"); ar_check_init(gcl_pcl_pkg,no_init); ar_check_init(gcl_pcl_walk,no_init); ar_check_init(gcl_pcl_iterate,no_init); @@ -142,6 +156,7 @@ gcl_init_system(object no_init) ar_check_init(gcl_pcl_precom1,no_init); ar_check_init(gcl_pcl_precom2,no_init); + lsp_init("../clcs/package.lisp"); ar_check_init(gcl_clcs_precom,no_init); ar_check_init(gcl_clcs_handler,no_init); ar_check_init(gcl_clcs_conditions,no_init); diff --git a/unixport/sys_gcl.c b/unixport/sys_gcl.c index 80a9b4e..818d51c 100755 --- a/unixport/sys_gcl.c +++ b/unixport/sys_gcl.c @@ -34,7 +34,6 @@ gcl_init_system(object no_init) { #ifdef HAVE_JAPI_H ar_check_init(gcl_japi,no_init); #endif - ar_check_init(gcl_iolib,no_init); ar_check_init(gcl_listlib,no_init); ar_check_init(gcl_mislib,no_init); ar_check_init(gcl_numlib,no_init); @@ -49,9 +48,23 @@ gcl_init_system(object no_init) { ar_check_init(gcl_defpackage,no_init); ar_check_init(gcl_make_defpackage,no_init); ar_check_init(gcl_sharp,no_init); - ar_check_init(gcl_fpe,no_init); + ar_check_init(gcl_sharp_uv,no_init); + ar_check_init(gcl_namestring,no_init); + ar_check_init(gcl_logical_pathname_translations,no_init); + ar_check_init(gcl_make_pathname,no_init); + ar_check_init(gcl_parse_namestring,no_init); + ar_check_init(gcl_translate_pathname,no_init); + ar_check_init(gcl_directory,no_init); + ar_check_init(gcl_merge_pathnames,no_init); + ar_check_init(gcl_truename,no_init); + ar_check_init(gcl_rename_file,no_init); + ar_check_init(gcl_wild_pathname_p,no_init); + ar_check_init(gcl_pathname_match_p,no_init); + ar_check_init(gcl_iolib,no_init); + ar_check_init(gcl_fpe,no_init); + ar_check_init(gcl_cmpinline,no_init); ar_check_init(gcl_cmputil,no_init); diff --git a/unixport/sys_init.lsp.in b/unixport/sys_init.lsp.in index 8f13c91..dc6f989 100644 --- a/unixport/sys_init.lsp.in +++ b/unixport/sys_init.lsp.in @@ -9,9 +9,6 @@ (in-package :system) (use-package :fpe) -#+(or pcl ansi-cl)(load "../pcl/package.lisp") -#+ansi-cl(load "../clcs/package.lisp") - (init-system) (in-package :si) (gbc t) @@ -20,7 +17,7 @@ (setq *link-array* (make-array (ash 1 11) :element-type 'character :fill-pointer 0))) (use-fast-links t) -(let* ((x (append (pathname-directory *system-directory*) (list :parent))) +(let* ((x (append (pathname-directory *system-directory*) (list :back))) (lsp (append x (list "lsp"))) (cmpnew (append x (list "cmpnew"))) (h (append x (list "h"))) @@ -59,6 +56,7 @@ (fmakunbound 'init-cmp-anon) (when (fboundp 'user-init) (user-init)) + (in-package :compiler) (setq *cc* @LI-CC@ *ld* @LI-LD@ @@ -79,7 +77,9 @@ #-ansi-cl(do-symbols (s :cltl1-compat) (export s :lisp))) #+ansi-cl (use-package :pcl :user) -#+ansi-cl (import 'si::(clines defentry defcfun object void int double quit bye gbc system) :user) + +(import 'si::(clines defentry defcfun object void int double quit bye gbc system + *lib-directory* *system-directory*) :user) (let* ((i 4096)(j (si::equal-tail-recursion-check i))) (unless (<= (ash i -1) j) diff --git a/unixport/sys_pcl_gcl.c b/unixport/sys_pcl_gcl.c index 721f820..0aaaba2 100644 --- a/unixport/sys_pcl_gcl.c +++ b/unixport/sys_pcl_gcl.c @@ -41,7 +41,6 @@ gcl_init_system(object no_init) #ifdef HAVE_JAPI_H ar_check_init(gcl_japi,no_init); #endif - ar_check_init(gcl_iolib,no_init); ar_check_init(gcl_listlib,no_init); ar_check_init(gcl_mislib,no_init); ar_check_init(gcl_numlib,no_init); @@ -56,9 +55,23 @@ gcl_init_system(object no_init) ar_check_init(gcl_defpackage,no_init); ar_check_init(gcl_make_defpackage,no_init); ar_check_init(gcl_sharp,no_init); - ar_check_init(gcl_fpe,no_init); + ar_check_init(gcl_sharp_uv,no_init); + ar_check_init(gcl_namestring,no_init); + ar_check_init(gcl_logical_pathname_translations,no_init); + ar_check_init(gcl_make_pathname,no_init); + ar_check_init(gcl_parse_namestring,no_init); + ar_check_init(gcl_translate_pathname,no_init); + ar_check_init(gcl_directory,no_init); + ar_check_init(gcl_merge_pathnames,no_init); + ar_check_init(gcl_truename,no_init); + ar_check_init(gcl_rename_file,no_init); + ar_check_init(gcl_wild_pathname_p,no_init); + ar_check_init(gcl_pathname_match_p,no_init); + ar_check_init(gcl_iolib,no_init); + ar_check_init(gcl_fpe,no_init); + ar_check_init(gcl_cmpinline,no_init); ar_check_init(gcl_cmputil,no_init); @@ -107,6 +120,7 @@ gcl_init_system(object no_init) ar_check_init(gcl_index,no_init); #endif + lsp_init("../pcl/package.lisp"); ar_check_init(gcl_pcl_pkg,no_init); ar_check_init(gcl_pcl_walk,no_init); ar_check_init(gcl_pcl_iterate,no_init); diff --git a/unixport/sys_pre_gcl.c b/unixport/sys_pre_gcl.c index 60446ff..528c8b3 100755 --- a/unixport/sys_pre_gcl.c +++ b/unixport/sys_pre_gcl.c @@ -39,7 +39,6 @@ gcl_init_system(object no_init) #ifdef HAVE_JAPI_H lsp_init("../lsp/gcl_japi.lsp"); #endif - lsp_init("../lsp/gcl_iolib.lsp"); /* lsp_init("../lsp/gcl_listlib.lsp"); */ lsp_init("../lsp/gcl_mislib.lsp"); lsp_init("../lsp/gcl_numlib.lsp"); @@ -54,6 +53,21 @@ gcl_init_system(object no_init) lsp_init("../lsp/gcl_defpackage.lsp"); lsp_init("../lsp/gcl_make_defpackage.lsp"); lsp_init("../lsp/gcl_sharp.lsp"); + + lsp_init("../lsp/gcl_sharp_uv.lsp"); + lsp_init("../lsp/gcl_logical_pathname_translations.lsp"); + lsp_init("../lsp/gcl_make_pathname.lsp"); + lsp_init("../lsp/gcl_parse_namestring.lsp"); + lsp_init("../lsp/gcl_namestring.lsp"); + lsp_init("../lsp/gcl_translate_pathname.lsp"); + lsp_init("../lsp/gcl_directory.lsp"); + lsp_init("../lsp/gcl_merge_pathnames.lsp"); + lsp_init("../lsp/gcl_truename.lsp"); + lsp_init("../lsp/gcl_rename_file.lsp"); + lsp_init("../lsp/gcl_wild_pathname_p.lsp"); + lsp_init("../lsp/gcl_pathname_match_p.lsp"); + + lsp_init("../lsp/gcl_iolib.lsp"); lsp_init("../lsp/gcl_fpe.lsp"); lsp_init("../cmpnew/gcl_cmpinline.lsp"); diff --git a/xbin/make-fn b/xbin/make-fn index dee5c9e..32a482c 100755 --- a/xbin/make-fn +++ b/xbin/make-fn @@ -6,8 +6,11 @@ TMP=/tmp/tmpd$$ mkdir ${TMP} cp $@ ${TMP} -for v in $@ ; +for v in $1 ; do +echo '(load (format nil "~a~a" si::*system-directory* "../cmpnew/gcl_collectfn"))' \ + '(compiler::emit-fn t)'\ + "(compile-file \"${TMP}/$v\" :o-file nil)" echo '(load (format nil "~a~a" si::*system-directory* "../cmpnew/gcl_collectfn"))' \ '(compiler::emit-fn t)'\ "(compile-file \"${TMP}/$v\" :o-file nil)" | ${LISP}