"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)))))
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)
(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
(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)
(list n1)
(random-partition n3 (- p 1 r))))))))))
+(defmacro expand-in-current-env (macro-form &environment env)
+ (macroexpand macro-form env))
--- /dev/null
+;-*- 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)
+
+
+
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+(in-package "CL-TEST")
+
+(defun compile-file-test-fun.1 () nil)
--- /dev/null
+;-*- 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)
+
+
--- /dev/null
+;-*- 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)
+|#
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
+
+
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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
--- /dev/null
+;-*- 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)
+
+
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
+
+
--- /dev/null
+;-*- 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)
;;; 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")
--- /dev/null
+;-*- 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)
+
+
+
+
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+(in-package :cl-test) (defun LOAD-TEST-FUN-3 () :foo)
\ No newline at end of file
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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")
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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
--- /dev/null
+;-*- 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")
+
--- /dev/null
+;-*- 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")
--- /dev/null
+(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*))
+
--- /dev/null
+(in-package :cl-test)
+
+(defun load-file-test-fun.1 ()
+ '#.*load-pathname*)
+
+(defun load-file-test-fun.2 ()
+ '#.*load-truename*)
+
+
-;; 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)
--- /dev/null
+;-*- Mode: Lisp -*-
+;;;; Author: Paul Dietz
+;;;; Created: Wed Dec 31 09:46:08 2003
+;;;; Contains: Tests of LOGICAL-PATHNAME-TRANSLATIONS
+
+(in-package :cl-test)
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
+
+
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
+
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
+
--- /dev/null
+;-*- 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
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)))
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+|#
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
+
+
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
| 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)))
(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
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: #<error during printing>~%")))
+ (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)
(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*)
~^, ~}~)."
(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))))))
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
+
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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")
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
#-(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
--- /dev/null
+;-*- 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)
+
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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.
+
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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
+
+
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
+
--- /dev/null
+;-*- 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)
((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)))
`(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)
(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))
(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)
(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)))
(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();")))
(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"))))
(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*)
(*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*)
(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*)
(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)))
(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)
(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"
(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))
(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)
(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"))
(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)
;#-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)
(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)
(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)
(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)
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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
#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
#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
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;
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(); */
FEerror(x,y...)
FEwrong_type_argument(x,y)
BIT_ENDIAN(x)
+pathname_designatorp(x)
+pathnamep(x)
PFN(characterp)
PFN(symbolp)
PFN(stringp)
+PFN(pathnamep)
PFN(string_symbolp)
PFN(packagep)
PFN(consp)
#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)
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_))
object pn_name;
object pn_type;
object pn_version;
- SPAD;
+ object pn_namestring;
};
struct cfun {
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
EXTER bool right_trim;
int (*casefun)();
-#define Q_SIZE 128
+#define Q_SIZE 256
#define IS_SIZE 256
struct printStruct {
#include "gmp_wrappers.h"
+char FN1[PATH_MAX],FN2[PATH_MAX],FN3[PATH_MAX],FN4[PATH_MAX],FN5[PATH_MAX];
+
#include <errno.h>
#define massert(a_) ({errno=0;if (!(a_)||errno) assert_error(#a_,__LINE__,__FILE__,__FUNCTION__);})
#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
*/
gcl_sm_tcp_async,
gcl_sm_input,
gcl_sm_output,
+ gcl_sm_closed,
gcl_sm_had_error
-
};
enum chattrib { /* character attribute */
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)
/* 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, ... );
t_shortfloat,
t_longfloat,
t_complex,
+ t_stream,
t_pathname,
t_string,
t_bitvector,
t_character,
t_symbol,
t_package,
- t_stream,
t_random,
t_readtable,
t_cfun,
};
+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
#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;}})
#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)
|| _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);})
(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)
--- /dev/null
+(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)
(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
(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))))
-#.`(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)))))))
(,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"\1f"))
(defconstant +crnp+ (compile-regexp #u"[\1f\f]"))
+;; -*-Lisp-*-
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
;; This file is part of GNU Common Lisp, herein referred to as GCL
(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)
(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*)
(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)
(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)
(*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)
(*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))))
--- /dev/null
+(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)))
--- /dev/null
+(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))))
--- /dev/null
+(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)))))
(* (+ 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)
(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)))))))
--- /dev/null
+(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))
--- /dev/null
+(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))
+
--- /dev/null
+(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))))
+
(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)
(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)
((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)))
(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 )
--- /dev/null
+(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)))
+
(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))
--- /dev/null
+(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)
(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*)))
(defvar *error-p* nil)
+(defvar *lib-directory* nil)
+
(defun process-some-args (args &optional compile &aux *load-verbose*)
(when args
(let ((x (pop args)))
(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)))))
;;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)) )
(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))))
--- /dev/null
+(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)))
+
--- /dev/null
+(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)))
--- /dev/null
+(in-package :si)
+
+(defun wild-namestring-p (x)
+ (when (stringp x) (>= (string-match #v"(\\*|\\?|\\[|\\{)" x) 0)))
+
+(defun wild-dir-element-p (x)
+ (or (eq x :wild) (eq x :wild-inferiors) (wild-namestring-p x)))
+
+(defun wild-path-element-p (x)
+ (or (eq x :wild) (wild-namestring-p x)))
+
+#.`(defun wild-pathname-p (pd &optional f)
+ (declare (optimize (safety 1)))
+ (check-type pd pathname-designator)
+ (check-type f (or null (member ,@+pathname-keys+)))
+ (case f
+ ((nil) (or (wild-namestring-p (namestring pd))
+ (when (typep pd 'pathname);FIXME stream
+ (eq :wild (pathname-version pd)))))
+ ;; ((nil) (if (stringp pd) (wild-namestring-p pd)
+ ;; (let ((p (pathname pd)))
+ ;; (when (member-if (lambda (x) (wild-pathname-p p x)) +pathname-keys+) t))))
+ ((:host :device) nil)
+ (:directory (when (member-if 'wild-dir-element-p (pathname-directory pd)) t))
+ (:name (wild-path-element-p (pathname-name pd)))
+ (:type (wild-path-element-p (pathname-type pd)))
+ (:version (wild-path-element-p (pathname-version pd)))))
+
gcl_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)
(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
'(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
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;
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);
}
+ 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);
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
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));
/* } */
/* } */
-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);
*/
#include "include.h"
-#include <string.h>
static void
illegal_lambda(void);
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;
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);
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);
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);
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;
}
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]);
/**/
}
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
goto NEXT_ARG;
}
}
- other_keys_appeared = TRUE;
+ if (base[i] != sKallow_other_keys)
+ other_keys_appeared = TRUE;
NEXT_ARG:
continue;
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 {
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:
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;
continue;
/* lex_special_bind(v); */
temporary = MMcons(v, Cnil);
- lex_env[0] = MMcons(temporary, lex_env[0]);
+ s[0] = MMcons(temporary, s[0]);
/**/
}
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 {
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
*/
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;
vs_mark;
vs_push(Cnil);
+ s=s ? s : lex_env;
for (; !endp(body); body = body->c.c_cdr) {
form = body->c.c_car;
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;
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);
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);
}
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);
}
#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;
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;
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;
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);
make_cons(make_ordinary("&BODY"), Cnil)))))))));
make_constant("LAMBDA-PARAMETERS-LIMIT",
- make_fixnum(64));
+ make_fixnum(MAX_ARGS+1));
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);
}
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);
end_of_stream(strm)
object strm;
{
- FEerror("Unexpected end of ~S.", 1, strm);
+ END_OF_FILE(strm);
}
/*
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)
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)
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)
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;
}
/*
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
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);
}
strm->sm.sm_object1 = OBJNULL;
STRING_INPUT_STREAM_NEXT(strm)= istart;
STRING_INPUT_STREAM_END(strm)= iend;
+ strm->sm.sm_flags=0;
return(strm);
}
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);
}
/* 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)
/* --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)
break;
+ case smm_file_synonym:
case smm_synonym:
strm = symbol_value(strm->sm.sm_object0);
if (type_of(strm) != t_stream)
#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)
case smm_probe:
return(FALSE);
+ case smm_file_synonym:
case smm_synonym:
strm = symbol_value(strm->sm.sm_object0);
check_stream(strm);
#endif
return TRUE;
+ case smm_file_synonym:
case smm_synonym:
strm = symbol_value(strm->sm.sm_object0);
if (type_of(strm) != t_stream)
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)
}
return(0);
+ case smm_file_synonym:
case smm_synonym:
strm = symbol_value(strm->sm.sm_object0);
if (type_of(strm) != t_stream)
+ case smm_file_synonym:
case smm_synonym:
strm = symbol_value(strm->sm.sm_object0);
if (type_of(strm) != t_stream)
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)
\f
+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;
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;
}
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;
}
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;
}
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);
@(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;
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)()
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)()
{
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;
}
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
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)
#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;
#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);
DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,"");
DEFVAR("*LOAD-PATHNAME*",sLAload_pathnameA,LISP,Cnil,"");
+DEFVAR("*LOAD-TRUENAME*",sSAload_truenameA,LISP,Cnil,"");
DEFVAR("*LOAD-VERBOSE*",sLAload_verboseA,LISP,Ct,"");
+DEFVAR("*LOAD-PRINT*",sLAload_printA,LISP,Cnil,"");
DEF_ORDINARY("ABORT",sKabort,KEYWORD,"");
DEF_ORDINARY("APPEND",sKappend,KEYWORD,"");
DEF_ORDINARY("VERBOSE",sKverbose,KEYWORD,"");
+DEF_ORDINARY("DELETE-FILE",sLdelete_file,LISP,"");
void
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",
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
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;
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);
(!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);
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<<LOG_BITS_CHAR); */
-/* #ifdef CONTBLOCK_MARK_DEBUG */
-/* off_check(v,ve,i,pi); */
-/* #endif */
-/* v[i]|=(1UL<<s); */
-/* } */
-
#define bit_get(v,i,s) ((v[i]>>s)&0x1)
#define bit_set(v,i,s) (v[i]|=(1UL<<s))
#define ptr_get(v,i,s) (v+(((i<<LOG_BITS_CHAR)|s)<<LOG_BYTES_CONTBLOCK))
return get_bit(CB_MARK_START(pi),pi,x);
}
-/* static inline void */
-/* set_mark_bit(struct pageinfo *pi,void *x) { */
-/* set_bit(CB_MARK_START(pi),pi,x); */
-/* } */
-
static inline void *
get_mark_bits(struct pageinfo *pi,void *x) {
return get_bits(CB_MARK_START(pi),pi,x);
return get_bit(CB_SGCF_START(pi),pi,x);
}
-/* static inline void */
-/* set_sgc_bit(struct pageinfo *pi,void *x) { */
-/* set_bit(CB_SGCF_START(pi),pi,x); */
-/* } */
-
static inline void *
get_sgc_bits(struct pageinfo *pi,void *x) {
return get_bits(CB_SGCF_START(pi),pi,x);
if (!marking(p)||!collecting(p))
return;
- if (what_to_collect!=t_contiguous &&
+ if (what_to_collect!=t_contiguous &&
x && x->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.st<rst.d.st) x->d.st++;
static void mark_object1(object);
#define mark_object(x) if (marking(x)) mark_object1(x)
-
+
static inline void
mark_object_address(object *o,int f) {
static ufixnum lr;
ufixnum p=page(o);
-
+
if (lp!=p || !f) {
lp=p;
lr=
static void
mark_object1(object x) {
-
+
fixnum i,j=0;/*FIXME*/
if (is_marked_or_free(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:
x->v.v_self=p;
adjust_displaced(x,j);
}
- }
+ }
mark_object(x->v.v_displaced);
break;
mark_object(x->str.str_def);
if (x->str.str_self)
for (i=0,j=S_DATA(def)->length;i<j;i++)
- if (s_type[i]==0)
+ if (s_type[i]==aet_object)
mark_object_address(&STREF(object,x,s_pos[i]),i);
MARK_LEAF_DATA(x,x->str.str_self,S_DATA(def)->size);
}
MARK_LEAF_DATA(x,x->sm.sm_buffer,BUFSIZ);
}
break;
-
+
+ case smm_file_synonym:
case smm_synonym:
mark_object(x->sm.sm_object0);
break;
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;
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:
}
#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
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
struct pageinfo *v;
STATIC char *s, *e, *p, *q;
ufixnum i;
-
+
reset_contblock_freelist();
for (i=0;i<contblock_array->v.v_fillp && (v=(void *)contblock_array->v.v_self[i]);i++) {
#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;
int (*GBC_enter_hook)() = NULL;
int (*GBC_exit_hook)() = NULL;
-/* void */
-/* ttss(void) { */
-
-/* struct typemanager *tm; */
-/* void *x,*y; */
-
-/* for (tm=tm_table;tm<tm_table+t_end;tm++) { */
-
-/* for (x=tm->tm_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
return ncb;
}
-
+
void
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");
close_stream(o);
}
- /* t = t_relocatable; */
gc_time = -1;
}
#endif
}
-
-/* { */
-/* static int promoting; */
-/* if (!promoting && promotion_pointer>promotion_pointer1) { */
-/* object *p,st; */
-/* promoting=1; */
-/* st=alloc_simple_string(""); */
-/* for (p=promotion_pointer1;p<promotion_pointer;p++) { */
-/* fixnum j; */
-/* object x=*p; */
-
-/* if (type_of(x)==t_string) */
-
-/* j=x->st.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;
CHECK_INTERRUPT;
- /* ttss(); */
-
}
static void
STATIC char *q;
STATIC char *x, *y;
struct pageinfo *v;
-
+
if (NULL_OR_ON_C_STACK(p))
return;
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;k<contblock_array->v.v_fillp && (v=(void *)contblock_array->v.v_self[k]);k++,i+=v->in_use,j++)
+
+ for (i=j=k=0;k<contblock_array->v.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;
}
}
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;
}
}
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);
#ifdef SGC
make_si_function("SGC-ON",siLsgc_on);
#endif
-
+
}
- if (type_of(x) != t_cons)
+ if (!consp(x))
FEinvalid_form("The index, ~S, is illegal.", x);
y = MMcar(x);
check_var(y);
}
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)
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) {
}
{
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,
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;
}
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;
}
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;
}
#include <string.h>
#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) {
+
}
#include <string.h>
#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),"")
{
write_ch('>');
break;
+ case smm_file_synonym:
case smm_synonym:
write_str("#<synonym stream to ");
write_object(x->sm.sm_object0, 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 {
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.
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 */
#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:
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;
}
/* 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;
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;
#ifndef _REGEXP
#define _REGEXP 1
-#define NSUBEXP 10
+#define NSUBEXP 19
typedef struct regexp {
char *startp[NSUBEXP];
char *endp[NSUBEXP];
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;
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 );
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;
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;
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);
}
+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) {
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);
}
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));
data = read_fasl_vector(faslfile);
massert(!un_mmap(st,est));
- close_stream(faslfile);
#ifdef CLEAR_CACHE
CLEAR_CACHE;
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));
data=feof(fp) ? 0 : read_fasl_vector(faslfile);
massert(!un_mmap(v1,ve));
- close_stream(faslfile);
massert(!clear_protect_memory(memory));
FILE *fp;
object data;
- char filename[256];
ul init_address=-1;
object memory;
void *v1,*ve,*p;
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));
#endif
massert(!un_mmap(v1,ve));
- close_stream(faslfile);
init_address-=(ul)memory->cfd.cfd_start;
call_init(init_address,memory,data,0);
void *p=NULL,*pe;
struct pageinfo *pi;
ufixnum i;
-
+
old_cb_pointer=cb_pointer;
reset_contblock_freelist();
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;
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]");
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;i<contblock_array->v.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));
#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;
if (writable==WRITABLE_PAGE_P(i) && i<end) continue;
- if (sgc_mprotect(beg,i-beg,writable))
+ if (sgc_mprotect(beg,i-beg,writable))
return -1;
writable=1-writable;
beg=i;
object *oldlex = lex_env;
lex_copy();
- body = find_special(body, NULL, NULL);
+ body = find_special(body, NULL, NULL,NULL);
vs_push(body);
Fprogn(body);
lex_env = oldlex;
DEF_ORDINARY("UNSIGNED-SHORT",sSunsigned_short,SI,"");
DEF_ORDINARY("*",sLA,LISP,"");
DEF_ORDINARY("PLUSP",sLplusp,LISP,"");
-DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,"");
-DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,"");
-DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,"");
-DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,"");
-DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,"");
DEF_ORDINARY("METHOD-COMBINATION",sLmethod_combination,LISP,"");
-DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,"");
DEF_ORDINARY("BASE-CHAR",sLbase_char,LISP,"");
DEF_ORDINARY("BASE-STRING",sLbase_string,LISP,"");
DEF_ORDINARY("BROADCAST-STREAM",sLbroadcast_stream,LISP,"");
DEF_ORDINARY("BUILT-IN-CLASS",sLbuilt_in_class,LISP,"");
-DEF_ORDINARY("CELL-ERROR",sLcell_error,LISP,"");
DEF_ORDINARY("CLASS",sLclass,LISP,"");
DEF_ORDINARY("CONCATENATED-STREAM",sLconcatenated_stream,LISP,"");
-DEF_ORDINARY("CONDITION",sLcondition,LISP,"");
-DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,"");
DEF_ORDINARY("ECHO-STREAM",sLecho_stream,LISP,"");
-DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,"");
-DEF_ORDINARY("ERROR",sLerror,LISP,"");
DEF_ORDINARY("EXTENDED-CHAR",sLextended_char,LISP,"");
-DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,"");
DEF_ORDINARY("FILE-STREAM",sLfile_stream,LISP,"");
DEF_ORDINARY("GENERIC-FUNCTION",sLgeneric_function,LISP,"");
DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,"");
DEF_ORDINARY("METHOD",sLmethod,LISP,"");
/* FIXME -- need this for types in predlib.lsp, why can't we use the keyword sKpackage_error ? */
-DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,"");
-DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,"");
-DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,"");
-DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,"");
DEF_ORDINARY("SIMPLE-BASE-STRING",sLsimple_base_string,LISP,"");
-DEF_ORDINARY("SIMPLE-CONDITION",sLsimple_condition,LISP,"");
-DEF_ORDINARY("SIMPLE-TYPE-ERROR",sLsimple_type_error,LISP,"");
-DEF_ORDINARY("SIMPLE-WARNING",sLsimple_warning,LISP,"");
DEF_ORDINARY("STANDARD-CLASS",sLstandard_class,LISP,"");
DEF_ORDINARY("STANDARD-GENERIC-FUNCTION",sLstandard_generic_function,LISP,"");
DEF_ORDINARY("STANDARD-METHOD",sLstandard_method,LISP,"");
DEF_ORDINARY("STANDARD-OBJECT",sLstandard_object,LISP,"");
-DEF_ORDINARY("STORAGE-CONDITION",sLstorage_condition,LISP,"");
-DEF_ORDINARY("STREAM-ERROR",sLstream_error,LISP,"");
DEF_ORDINARY("STRING-STREAM",sLstring_stream,LISP,"");
DEF_ORDINARY("STRUCTURE-CLASS",sLstructure_class,LISP,"");
DEF_ORDINARY("STRUCTURE-OBJECT",sLstructure_object,LISP,"");
-DEF_ORDINARY("STYLE-WARNING",sLstyle_warning,LISP,"");
DEF_ORDINARY("SYNONYM-STREAM",sLsynonym_stream,LISP,"");
DEF_ORDINARY("TWO-WAY-STREAM",sLtwo_way_stream,LISP,"");
-DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,"");
-DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,"");
-DEF_ORDINARY("WARNING",sLwarning,LISP,"");
DEFCONST("CHAR-SIZE",sSchar_size,SI,small_fixnum(CHAR_SIZE),"Size in bits of a character");
DEFCONST("SHORT-SIZE",sSshort_size,SI,small_fixnum(CHAR_SIZE*sizeof(short)),"Size in bits of a short integer");
void
-gcl_init_typespec(void)
-{
+gcl_init_typespec(void) {
}
void
-gcl_init_typespec_function(void)
-{
- TSor_symbol_string
- = make_cons(sLor, make_cons(sLsymbol, make_cons(sLstring, Cnil)));
- enter_mark_origin(&TSor_symbol_string);
- TSor_string_symbol
- = make_cons(sLor, make_cons(sLstring, make_cons(sLsymbol, Cnil)));
- enter_mark_origin(&TSor_string_symbol);
- TSor_symbol_string_package
- = make_cons(sLor,
- make_cons(sLsymbol,
- make_cons(sLstring,
- make_cons(sLpackage, Cnil))));
- enter_mark_origin(&TSor_symbol_string_package);
-
- TSnon_negative_integer
- = make_cons(sLinteger,
- make_cons(make_fixnum(0), make_cons(sLA, Cnil)));
- enter_mark_origin(&TSnon_negative_integer);
- TSpositive_number = make_cons(sLsatisfies, make_cons(sLplusp, Cnil));
- enter_mark_origin(&TSpositive_number);
- TSor_integer_float
- = make_cons(sLor, make_cons(sLinteger, make_cons(sLfloat, Cnil)));
- enter_mark_origin(&TSor_integer_float);
- TSor_rational_float
- = make_cons(sLor, make_cons(sLrational, make_cons(sLfloat, Cnil)));
- enter_mark_origin(&TSor_rational_float);
+gcl_init_typespec_function(void) {
+
+ TSor_symbol_string=make_cons(sLor, make_cons(sLsymbol, make_cons(sLstring, Cnil)));
+ enter_mark_origin(&TSor_symbol_string);
+
+ TSor_string_symbol=make_cons(sLor, make_cons(sLstring, make_cons(sLsymbol, Cnil)));
+ enter_mark_origin(&TSor_string_symbol);
+
+ TSor_symbol_string_package=make_cons(sLor,make_cons(sLsymbol,make_cons(sLstring,make_cons(sLpackage, Cnil))));
+ enter_mark_origin(&TSor_symbol_string_package);
+
+ TSnon_negative_integer= make_cons(sLinteger,make_cons(make_fixnum(0), make_cons(sLA, Cnil)));
+ enter_mark_origin(&TSnon_negative_integer);
+
+ TSpositive_number=make_cons(sLsatisfies, make_cons(sLplusp, Cnil));
+ enter_mark_origin(&TSpositive_number);
+
+ TSor_integer_float=make_cons(sLor, make_cons(sLinteger, make_cons(sLfloat, Cnil)));
+ enter_mark_origin(&TSor_integer_float);
+
+ TSor_rational_float=make_cons(sLor, make_cons(sLrational, make_cons(sLfloat, Cnil)));
+ enter_mark_origin(&TSor_rational_float);
+
#ifdef UNIX
- TSor_pathname_string_symbol
- = make_cons(sLor,
- make_cons(sLpathname,
- make_cons(sLstring,
- make_cons(sLsymbol,
- Cnil))));
- enter_mark_origin(&TSor_pathname_string_symbol);
+ TSor_pathname_string_symbol=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,Cnil))));
+ enter_mark_origin(&TSor_pathname_string_symbol);
#endif
- TSor_pathname_string_symbol_stream
- = make_cons(sLor,
- make_cons(sLpathname,
- make_cons(sLstring,
- make_cons(sLsymbol,
- make_cons(sLstream,
- Cnil)))));
- enter_mark_origin(&TSor_pathname_string_symbol_stream);
-
- make_function("TYPE-OF", Ltype_of);
+
+ TSor_pathname_string_symbol_stream=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,make_cons(sLstream,Cnil)))));
+ enter_mark_origin(&TSor_pathname_string_symbol_stream);
+
+ make_function("TYPE-OF", Ltype_of);
+
}
/* The use of _execname is incompatible with RISCiX 1.1 */
- sprintf (command, "nm %s | fgrep mcount", _execname);
+ sprintf (command, "nm '%s' | fgrep mcount", _execname);
if ( (pfile = popen(command, "r")) == NULL)
{
/* The use of _execname is incompatible with RISCiX 1.1 */
- sprintf (command, "nm %s | fgrep mcount", _execname);
+ sprintf (command, "nm '%s' | fgrep mcount", _execname);
if ( (pfile = popen(command, "r")) == NULL)
{
#define FASLINK
#ifndef PRIVATE_FASLINK
-static int
-faslink(object faslfile, object ldargstring)
-{
+DEFUN_NEW("FASLINK-INT",object,fSfaslink_int,SI,2,2,NONE,II,OO,OO,OO,(object faslfile, object ldargstring),"") {
#if defined(__ELF__) || defined(DARWIN)
FEerror("faslink() not supported for ELF or DARWIN yet",0);
return 0;
#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) {
}
#define HAVE_RENAME
#endif
-void Ldirectory(void);
-
-
-
#ifdef NEED_GETWD
#include <sys/dir.h>
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;
}
-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
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,"");
-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")
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 <sys/dir.h>
-
-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 <sys/types.h>
#include <dirent.h>
}
#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
}
+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 <sys/types.h>
+#include <dirent.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+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
}
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);
+
}
#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));
}
FEerror("Broken pipe", 0);
}
-
void
sigint(void)
{
terminal_interrupt(1);
}
-
-
static void
sigalrm(void)
{
#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);
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);
ar_check_init(gcl_index,no_init);
#endif
+ lsp_init("../pcl/package.lisp");
ar_check_init(gcl_pcl_pkg,no_init);
ar_check_init(gcl_pcl_walk,no_init);
ar_check_init(gcl_pcl_iterate,no_init);
ar_check_init(gcl_pcl_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);
#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);
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);
(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)
(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")))
(fmakunbound 'init-cmp-anon)
(when (fboundp 'user-init) (user-init))
+
(in-package :compiler)
(setq *cc* @LI-CC@
*ld* @LI-LD@
#-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)
#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);
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);
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);
#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");
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");
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}
projects / gcl27.git / commitdiff