1;;; Basic extensions: conditions, compositions &c
2;;;
3;;; Copyright (C) 1999-2002 by Sam Steingold
4;;; This is open-source software.
5;;; GNU Lesser General Public License (LGPL) is applicable:
6;;; No warranty; you may copy/modify/redistribute under the same
7;;; conditions with the source code.
8;;; See <URL:http://www.gnu.org/copyleft/lesser.html>
9;;; for details and the precise copyright document.
10
11(in-package :port)
12
13;;;
14;;; Conditions
15;;;
16
17(define-condition code (error)
18  ((proc :reader code-proc :initarg :proc)
19   (mesg :type simple-string :reader code-mesg :initarg :mesg)
20   (args :type list :reader code-args :initarg :args))
21  (:documentation "An error in the user code.")
22  (:report (lambda (cc out)
23             (declare (stream out))
24             (format out "[~s]~@[ ~?~]" (code-proc cc)
25                     (and (slot-boundp cc 'mesg) (code-mesg cc))
26                     (and (slot-boundp cc 'args) (code-args cc))))))
27
28(define-condition case-error (code)
29  ((mesg :type simple-string :reader code-mesg :initform
30         "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]"))
31  (:documentation "An error in a case statement.
32This carries the function name which makes the error message more useful."))
33
34(define-condition not-implemented (code)
35  ((mesg :type simple-string :reader code-mesg :initform
36         "not implemented for ~a [~a]")
37   (args :type list :reader code-args :initform
38         (list (lisp-implementation-type) (lisp-implementation-version))))
39  (:documentation "Your implementation does not support this functionality."))
40
41;;;
42;;; Extensions
43;;;
44
45(defmacro defsubst (name arglist &body body)
46  "Declare an inline defun."
47  `(progn (declaim (inline ,name)) (defun ,name ,arglist ,@body)))
48
49(defmacro defcustom (name type init doc)
50  "Define a typed global variable."
51  `(progn (declaim (type ,type ,name))
52    (defvar ,name (the ,type ,init) ,doc)))
53
54(defmacro defconst (name type init doc)
55  "Define a typed constant."
56  `(progn (declaim (type ,type ,name))
57    ;; since constant redefinition must be the same under EQL, there
58    ;; can be no constants other than symbols, numbers and characters
59    ;; see ANSI CL spec 3.1.2.1.1.3 "Constant Variables"
60    (,(if (subtypep type '(or symbol number character)) 'defconstant 'defvar)
61     ,name (the ,type ,init) ,doc)))
62
63(defmacro mk-arr (type init &optional len)
64  "Make array with elements of TYPE, initializing."
65  (if len `(make-array ,len :element-type ,type :initial-element ,init)
66      `(make-array (length ,init) :element-type ,type
67        :initial-contents ,init)))
68
69(defmacro with-gensyms (syms &body body)
70  "Bind symbols to gensyms.  First sym is a string - `gensym' prefix.
71Inspired by Paul Graham, <On Lisp>, p. 145."
72  `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(car syms)))) (cdr syms)))
73    ,@body))
74
75(defmacro map-in (fn seq &rest seqs)
76  "`map-into' the first sequence, evaluating it once.
77  (map-in F S) == (map-into S F S)"
78  (with-gensyms ("MI-" mi)
79    `(let ((,mi ,seq)) (map-into ,mi ,fn ,mi ,@seqs))))
80
81(defun gc ()
82  "Invoke the garbage collector."
83  #+allegro (excl:gc)
84  #+clisp (#+lisp=cl ext:gc #-lisp=cl lisp:gc)
85  #+cmu (ext:gc)
86  #+cormanlisp (cl::gc)
87  #+gcl (si::gbc)
88  #+lispworks (hcl:normal-gc)
89  #+lucid (lcl:gc)
90  #+sbcl (sb-ext:gc)
91  #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
92  (error 'not-implemented :proc (list 'gc)))
93
94(defun quit (&optional code)
95  #+allegro (excl:exit code)
96  #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
97  #+cmu (ext:quit code)
98  #+cormanlisp (win32:exitprocess code)
99  #+gcl (lisp:bye code)
100  #+lispworks (lw:quit :status code)
101  #+lucid (lcl:quit code)
102  #+sbcl (sb-ext:quit :unix-code (typecase code (number code) (null 0) (t 1)))
103  #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
104  (error 'not-implemented :proc (list 'quit code)))
105
106(defconst +eof+ cons (list '+eof+)
107  "*The end-of-file object.
108To be passed as the third arg to `read' and checked against using `eq'.")
109
110(defun eof-p (stream)
111  "Return T if the stream has no more data in it."
112  (null (peek-char nil stream nil nil)))
113
114(defun string-tokens (string &key (start 0) max)
115  "Read from STRING repeatedly, starting with START, up to MAX tokens.
116Return the list of objects read and the final index in STRING.
117Binds `*package*' to the keyword package,
118so that the bare symbols are read as keywords."
119  (declare (type (or null fixnum) max) (type fixnum start))
120  (let ((*package* (find-package :keyword)))
121    (if max
122        (do ((beg start) obj res (num 0 (1+ num)))
123            ((= max num) (values (nreverse res) beg))
124          (declare (fixnum beg num))
125          (setf (values obj beg)
126                (read-from-string string nil +eof+ :start beg))
127          (if (eq obj +eof+)
128              (return (values (nreverse res) beg))
129              (push obj res)))
130        (read-from-string (concatenate 'string "(" string ")")
131                          t nil :start start))))
132
133#+cmu (progn
134        (import 'ext:required-argument :port)
135        (export 'ext:required-argument :port))
136#-cmu (progn
137        ;; return type NIL means non-returning function
138        (proclaim '(ftype (function () nil) required-argument))
139        (defun required-argument ()
140          "A useful default for required arguments and DEFSTRUCT slots."
141          (error "A required argument was not supplied.")))
142
143;;;
144;;; package locking
145;;;
146
147(defvar *lock-package-saved-value*)
148
149(defmacro unlock-package (pack)
150  #+allegro
151  `(eval-when (:compile-toplevel)
152     (let ((pa (find-package ,pack)))
153       (setf *lock-package-saved-value* (excl:package-definition-lock pa)
154             (excl:package-definition-lock pa) nil)))
155  #+clisp
156  `(eval-when (:compile-toplevel)
157     (setf *lock-package-saved-value* (ext:package-lock ,pack)
158           (ext:package-lock ,pack) nil))
159  #+lispworks (declare (ignore pack))
160  #+lispworks
161  `(eval-when (:compile-toplevel :load-toplevel)
162     (setf *lock-package-saved-value* lw:*handle-warn-on-redefinition*
163           lw:*handle-warn-on-redefinition* nil))
164  #-(or allegro clisp lispworks)
165  ;; nothing to be done
166  (declare (ignore pack)))
167
168(defmacro restore-package-lock (pack)
169  #+allegro
170  `(eval-when (:compile-toplevel)
171     (setf (excl:package-definition-lock (find-package ,pack))
172           *lock-package-saved-value*)
173     (makunbound '*lock-package-saved-value*))
174  #+clisp
175  `(eval-when (:compile-toplevel)
176     (setf (ext:package-lock ,pack) *lock-package-saved-value*)
177     (makunbound '*lock-package-saved-value*))
178  #+lispworks (declare (ignore pack))
179  #+lispworks
180  `(eval-when (:compile-toplevel :load-toplevel)
181     (setf lw:*handle-warn-on-redefinition* *lock-package-saved-value*)
182     (makunbound '*lock-package-saved-value*))
183  #-(or allegro clisp lispworks)
184  ;; nothing to be done
185  (declare (ignore pack)))
186
187;;;
188;;; Function Compositions
189;;;
190
191(defmacro compose (&rest functions)
192  "Macro: compose functions or macros of 1 argument into a lambda.
193E.g., (compose abs (dl-val zz) 'key) ==>
194  (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))"
195  (labels ((rec (xx yy)
196             (let ((rr (list (car xx) (if (cdr xx) (rec (cdr xx) yy) yy))))
197               (if (consp (car xx))
198                   (cons 'funcall (if (eq (caar xx) 'quote)
199                                      (cons (cadar xx) (cdr rr)) rr))
200                   rr))))
201    (with-gensyms ("COMPOSE-" arg)
202      (let ((ff (rec functions arg)))
203        `(lambda (,arg) ,ff)))))
204
205(defun compose-f (&rest functions)
206  "Return the composition of all the arguments.
207All FUNCTIONS should take one argument, except for
208the last one, which can take several."
209  (reduce (lambda (f0 f1)
210            (declare (function f0 f1))
211            (lambda (&rest args) (funcall f0 (apply f1 args))))
212          functions :initial-value #'identity))
213
214(defun compose-all (&rest functions)
215  "Return the composition of all the arguments.
216All the values from nth function are fed to the n-1th."
217  (reduce (lambda (f0 f1)
218            (declare (function f0 f1))
219            (lambda (&rest args) (multiple-value-call f0 (apply f1 args))))
220          functions :initial-value #'identity))
221
222(provide :port-ext)
223;;; file ext.lisp ends here
224