;; common.lsp. functions missing that are part of common lisp,
;; and commonly used
;; It is assumed you are using XLISP-PLUS 3.0 with all Common Lisp related
;; options (except packages) turned on before you load this file.
;; Author either unknown or Tom Almy unless indicated.
(in-package "XLISP")
; (unintern sym) - remove a symbol from the oblist
#-:packages
(defun unintern (symbol)
(let ((subhash (hash symbol (length *obarray*))))
(cond ((member symbol (aref *obarray* subhash))
(setf (aref *obarray* subhash)
(delete symbol (aref *obarray* subhash)))
t)
(t nil))))
(export '(pairlis copy-list copy-alist copy-tree signum))
;; pairlis does not check for lengths of keys and values being unequal
(defun pairlis (keys values &optional list)
(nconc (mapcar #'cons keys values) list))
(defun copy-list (list) (append list 'nil))
(defun copy-alist (list)
(if (null list)
'nil
(cons (if (consp (car list))
(cons (caar list) (cdar list))
(car list))
(copy-alist (cdr list)))))
(defun copy-tree (list)
(if (consp list)
(cons (copy-tree (car list)) (copy-tree (cdr list)))
list))
(defun signum (x)
(cond ((not (numberp x)) (error "~s is not a number" x))
((zerop (abs x)) x)
(t (/ x (abs x)))))
(export '(remf incf decf push pushnew pop))
; Cruddy but simple versions of these functions.
; Commented out since XLISP will now expand macros once, making
; good version much preferred.
;(defmacro incf (var &optional (delta 1))
; `(setf ,var (+ ,var ,delta)))
;(defmacro decf (var &optional (delta 1))
; `(setf ,var (- ,var ,delta)))
;(defmacro push (v l)
; `(setf ,l (cons ,v ,l))))
;(defmacro pushnew (a l &rest args)
; `(unless (member ,a ,l ,@args) (push ,a ,l) nil))
;(defmacro pop (l)
; `(prog1 (first ,l) (setf ,l (rest ,l)))))
; This is what one really needs to do for incf decf and
; (in common.lsp) push and pop. The setf form must only be evaluated once.
; But is it worth all this overhead for correctness?
; (By Tom Almy)
(defun |DoForm| (form) ; returns (cons |list for let| |new form|)
(let* ((args (rest form)) ; raw form arguments
(letlist (mapcan #'(lambda (x) (when (consp x)
(list (list (gensym) x))))
form))
(revlist (mapcar #'(lambda (x) (cons (second x) (first x)))
letlist))
(newform (cons (first form) (sublis revlist args))))
(cons letlist newform)))
(defun |RemProp| (l prop)
(do ((cl l (cddr cl))
(flg nil cl))
((atom cl) nil) ; none found
(cond ((atom (cdr l))
(error "odd length property list"))
((eq (car cl) prop) ; a match!
(if flg ; different if first in list from later
(rplacd (cdr flg) (cddr cl))
(setq l (cddr l)))
(return (list l))))))
(defmacro remf (form prop &aux (remres (gensym)))
(if (and (consp form) (some #'consp form))
(let ((retval (|DoForm| form)))
`(let* ( ,@(car retval)
(,remres (|RemProp| ,(cdr retval) ,prop)))
(if ,remres
(progn (setf ,(cdr retval) (car ,remres))
t)
nil)))
`(let ((,remres (|RemProp| ,form ,prop)))
(if ,remres (progn (setf ,form (car ,remres)) t)
nil))))
#-:packages
(unintern '|RemProp|)
(defmacro incf (form &optional (delta 1))
(if (and (consp form) (some #'consp form))
(let ((retval (|DoForm| form)))
`(let ,(car retval)
(setf ,(cdr retval)
(+ ,(cdr retval) ,delta))))
`(setf ,form (+ ,form ,delta))))
(defmacro decf (form &optional (delta 1))
(if (and (consp form) (some #'consp form))
(let ((retval (|DoForm| form)))
`(let ,(car retval)
(setf ,(cdr retval)
(- ,(cdr retval) ,delta))))
`(setf ,form (- ,form ,delta))))
(defmacro push (val form)
(if (and (consp form) (some #'consp form))
(let ((retval (|DoForm| form)))
`(let ,(car retval)
(setf ,(cdr retval)
(cons ,val ,(cdr retval)))))
`(setf ,form (cons ,val ,form))))
(defmacro pop (form)
(if (and (consp form) (some #'consp form))
(let ((retval (|DoForm| form)))
`(let ,(car retval)
(prog1 (first ,(cdr retval))
(setf ,(cdr retval)
(rest ,(cdr retval))))))
`(prog1 (first ,form)
(setf ,form (rest ,form)))))
(defmacro pushnew (val form &rest rest)
(if (and (consp form) (some #'consp form))
(let ((retval (|DoForm| form)))
`(let ,(car retval)
(setf ,(cdr retval)
(adjoin ,val ,(cdr retval) ,@rest))))
`(setf ,form (adjoin ,val ,form ,@rest))))
; DoForm is now needed in COMMON2.LSP
; #-:packages
; (unintern '|DoForm|)
;; Hyperbolic functions Ken Whedbee from CLtL
(export '(logtest cis sinh cosh tanh asinh acosh atanh))
#-:bignums (defun logtest (x y) (not (zerop (logand x y))))
(defconstant imag-one #C(0.0 1.0))
(defun cis (x) (exp (* imag-one x)))
(defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0))
(defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0))
(defun tanh (x) (/ (sinh x) (cosh x)))
(defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
(defun acosh (x)
(log (+ x
(* (1+ x)
(sqrt (/ (1- x) (1+ x)))))))
(defun atanh (x)
(when (or (= x 1.0) (= x -1.0))
(error "~s is a logarithmic singularity" x))
(log (/ (1+ x) (sqrt (- 1.0 (* x x))))))
;; Additional Common Lisp Functions by Luke Tierney
;; from xlisp-stat
;;
;; Defsetf and documentation functions
;; Corrected for Common Lisp compatibility (requires XLISP-PLUS 2.1e or later)
;; Modified by Tom Almy, 7/92
;; Corrected again in 6/93
;; and again (Luke Tierney) 11/93
;;
(export '(defsetf))
(defun apply-arg-rotate (f args)
(apply f (list 'quote (car (last args))) (butlast args)))
; (defsetf) - define setf method
(defmacro defsetf (sym first &rest rest)
(if (symbolp first)
`(progn (setf (get ',sym '*setf*) #',first)
(remprop ',sym '*setf-lambda*)
',sym)
(let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
(args (gensym)))
`(progn
(setf (get ',sym '*setf-lambda*) ; changed *setf* to *setf-lambda*
#'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
(remprop ',sym '*setf*)
',sym))))
;;;;
;;;;
;;;; *Modules*, provide and require: Leo Sarasua
;;;;
;;;;
(export '(provide require *modules*)) ; LSG
(defvar *modules*)
(defun provide (name) ; LSG
(pushnew (string name) *modules* :test #'string=))
(defun require (name &optional (pathname)) ; LSG
(let ((name (string name))
(path (string pathname)))
(or (find name *modules* :test #'string=)
(load (strcat pathname name)) )))
(defun require (name &optional (pathname)) ; LSG
(let ((namelist (mapcar #'string (if (listp name) name (list name))))
(path (string pathname)))
(dolist (name1 namelist)
(or (find name1 *modules* :test #'string=)
(load (strcat pathname name1)) ))))
;;;;
;;;;
;;;; Miscellaneous Functions: Luke Tierney
;;;; from xlisp-stat
;;;;
(export '(equalp y-or-n-p yes-or-no-p functionp with-input-from-string
with-output-to-string with-open-file))
; equalp rewritten by Tom Almy to better match Common Lisp
(defun equalp (x y)
(cond ((equal x y) t)
((numberp x) (if (numberp y) (= x y) nil))
((characterp x) (if (characterp y) (char-equal x y) nil))
((and (or (arrayp x) (stringp x))
(or (arrayp y) (stringp y))
(eql (length x) (length y)))
(every #'equalp x y))))
; Modified by TAA
#-:getkey
(defun y-or-n-p (&rest args)
(reset-system)
(when args (fresh-line) (apply #'format *terminal-io* args))
(do ((answer (string-trim " " (read-line))
(string-trim " " (read-line))))
((or (string-equal answer "Y")
(string-equal answer "N"))
(string-equal answer "Y"))
(princ " Answer \"y\" or \"n\": " *terminal-io*)))
#+:getkey
(defun y-or-n-p (&rest args)
(when args (fresh-line) (apply #'format *terminal-io* args))
(do ((answer (princ (int-char (get-key)))
(princ (int-char (get-key)))))
((or (char-equal answer #\Y)
(char-equal answer #\N))
(char-equal answer #\Y))
(princ "\nAnswer \"y\" or \"n\": " *terminal-io*)))
; Based on y-or-n-p
(defun yes-or-no-p (&rest args)
(reset-system)
(when args (fresh-line) (apply #'format *terminal-io* args))
(do ((answer (string-trim " " (read-line))
(string-trim " " (read-line))))
((or (string-equal answer "YES")
(string-equal answer "NO"))
(string-equal answer "YES"))
(princ " Answer \"yes\" or \"no\": " *terminal-io*)))
; Improved by TAA to match common lisp definition
(defun functionp (x)
(if (typep x '(or closure subr symbol))
t
(and (consp x) (eq (car x) 'lambda))))
;(defmacro with-input-from-string (stream-string &rest body)
; (let ((stream (first stream-string))
; (string (second stream-string)))
; `(let ((,stream (make-string-input-stream ,string)))
; (progn ,@body))))
(defmacro with-input-from-string
(stream-string &rest body)
(let ((stream (first stream-string))
(string (second stream-string))
(start (second (member :start (cddr stream-string))))
(end (second (member :end (cddr stream-string))))
(index (second (member :index (cddr stream-string)))))
(when (null start) (setf start 0))
(if index
(let ((str (gensym)))
`(let* ((,str ,string)
(,stream (make-string-input-stream ,str
,start
,end)))
(prog1 (progn ,@body)
(setf ,index
(- (length ,str)
(length (get-output-stream-list
,stream)))))))
`(let ((,stream (make-string-input-stream ,string ,start ,end)))
(progn ,@body)))))
(defmacro with-output-to-string (str-list &rest body)
(let ((stream (first str-list)))
`(let ((,stream (make-string-output-stream)))
(progn ,@body)
(get-output-stream-string ,stream))))
(defmacro with-open-file (stream-file-args &rest body)
(let ((stream (first stream-file-args))
(file-args (rest stream-file-args)))
`(let ((,stream (open ,@file-args)))
(unwind-protect
(progn ,@body)
(when ,stream (close ,stream))))))
(export '(eval-when declare proclaim special))
;; Dummy function to allow importing CL code
(defmacro eval-when (when &rest body)
(if (or (member 'eval when) (member 'execute when))
`(progn ,@body)))
(defmacro declare (&rest args)
(if *displace-macros*
(dolist (a args)
(if (eq (first a) 'special)
(return (cerror "special ignored"
"special declarations are not supported"))))))
(defun proclaim (decl)
(if (eq (first decl) 'special)
(dolist (s (rest decl))
(mark-as-special s))))
;; array functions. KCW from Kyoto Common Lisp
(export '(fill replace acons))
(defun fill (sequence item
&key (start 0) end)
(when (null end) (setf end (length sequence)))
(do ((i start (1+ i)))
((>= i end) sequence)
(setf (elt sequence i) item)))
(defun replace (sequence1 sequence2
&key (start1 0) end1
(start2 0) end2)
(when (null end1) (setf end1 (length sequence1)))
(when (null end2) (setf end2 (length sequence2)))
(if (and (eq sequence1 sequence2)
(> start1 start2))
(do* ((i 0 (1+ i))
(l (if (< (- end1 start1) (- end2 start2))
(- end1 start1)
(- end2 start2)))
(s1 (+ start1 (1- l)) (1- s1))
(s2 (+ start2 (1- l)) (1- s2)))
((>= i l) sequence1)
(setf (elt sequence1 s1) (elt sequence2 s2)))
(do ((i 0 (1+ i))
(l (if (< (- end1 start1)(- end2 start2))
(- end1 start1)
(- end2 start2)))
(s1 start1 (1+ s1))
(s2 start2 (1+ s2)))
((>= i l) sequence1)
(setf (elt sequence1 s1) (elt sequence2 s2)))))
(defun acons (x y a) ; from CLtL
(cons (cons x y) a))
;; more set functions. KCW from Kyoto Common Lisp
;; Modified to pass keys to subfunctions without checking here
;; (more efficient)
;; (Tom Almy states:) we can't get the destructive versions of union
;; intersection, and set-difference to run faster than the non-destructive
;; subrs. Therefore we will just have the destructive versions do their
;; non-destructive counterparts
(export '(nunion nintersection nset-difference
set-exclusive-or nset-exclusive-or))
(setf (symbol-function 'nunion)
(symbol-function 'union)
(symbol-function 'nintersection)
(symbol-function 'intersection)
(symbol-function 'nset-difference)
(symbol-function 'set-difference))
(defun set-exclusive-or (list1 list2 &rest rest)
(append (apply #'set-difference list1 list2 rest)
(apply #'set-difference list2 list1 rest)))
(defun nset-exclusive-or (list1 list2 &rest rest)
(nconc (apply #'set-difference list1 list2 rest)
(apply #'set-difference list2 list1 rest)))
;;;;;
;;;;; Symbol and Package Functions
;;;;;
#+:packages
(export '(defpackage do-symbols do-external-symbols do-all-symbols
apropos apropos-list))
#+:packages
(defmacro do-symbol-arrays (s res a body)
(let ((arraysym (gensym))
(isym (gensym))
(asym (gensym))
(listsym (gensym)))
`(let ((,arraysym ,a)
(,isym 0)
(,asym nil)
(,listsym nil)
(,s nil))
(block nil
(tagbody
new-array
(when (null ,arraysym)
(setf ,s nil)
(return ,res))
(setf ,asym (first ,arraysym) ,arraysym (rest ,arraysym) ,isym -1)
new-list
(setf ,isym (1+ ,isym))
(if (<= 199 ,isym) (go new-array))
(setf ,listsym (aref ,asym ,isym))
new-item
(if (null ,listsym) (go new-list))
(setf ,s (first ,listsym) ,listsym (rest ,listsym))
(tagbody ,@body)
(go new-item))))))
#+:packages
(defmacro do-symbols (spr &rest body)
(let ((packsym (gensym))
(usessym (gensym))
(arraysym (gensym)))
`(let* ((,packsym ,(if (second spr) (second spr) '*package*))
(,usessym (package-use-list ,packsym))
(,arraysym (cons (package-obarray ,packsym nil)
(mapcar #'package-obarray
(cons ,packsym ,usessym)))))
(do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
#+:packages
(defmacro do-external-symbols (spr &rest body)
(let ((packsym (gensym))
(arraysym (gensym)))
`(let* ((,packsym ,(if (second spr) (second spr) '*package*))
(,arraysym (list (package-obarray ,packsym))))
(do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
#+:packages
(defmacro do-all-symbols (sr &rest body)
(let ((packsym (gensym))
(arraysym (gensym)))
`(let* ((,packsym (list-all-packages))
(,arraysym nil))
(dolist (p ,packsym)
(push (package-obarray p) ,arraysym)
(push (package-obarray p nil) ,arraysym))
(do-symbol-arrays ,(first sr) ,(second sr) ,arraysym ,body))))
#+:packages
(defmacro defpackage (pname &rest options)
`(let* ((pname ',pname)
(options ',options)
(pack (find-package ',pname))
(nicknames nil))
(dolist (opt options)
(if (eq (first opt) :nicknames)
(setf nicknames (append (rest opt) nicknames))))
(if pack
(rename-package pack
pname
(mapcar #'string
(append nicknames (package-nicknames pack))))
(setf pack (make-package pname :nicknames
(mapcar #'string nicknames))))
(dolist (opt options)
(case (first opt)
(:shadow (shadow (mapcar #'string (rest opt)) pack))
(:shadowing-import-from
(let ((from-pack (find-package (second opt))))
(dolist (sname (rest (rest opt)))
(multiple-value-bind (sym found)
(find-symbol (string sname) from-pack)
(if found
(shadowing-import sym pack)
(error "no symbol named ~s in package ~s"
(string sname)
from-pack))))))))
(dolist (opt options)
(if (eq (first opt) :use)
(use-package (mapcar #'string (rest opt)) pack)))
(dolist (opt options)
(case (first opt)
(:intern
(dolist (sname (rest opt)) (intern (string sname) pack)))
(:import-from
(let ((from-pack (find-package (second opt))))
(dolist (sname (rest (rest opt)))
(multiple-value-bind (sym found)
(find-symbol (string sname) from-pack)
(if found
(import sym pack)
(error "no symbol named ~s in package ~s"
(string sname)
from-pack))))))))
(dolist (opt options)
(if (eq (first opt) :export)
(dolist (sname (rest opt))
(export (intern (string sname) pack) pack))))
pack))
#+:packages
(defun apropos2 (s)
(format t "~&~s" s)
(when (fboundp s) (format t " Function"))
(if (constantp s)
(format t " Constant=~s" (symbol-value s))
(when (boundp s) (format t " Value=~s" (symbol-value s)))))
#+:packages
(defun apropos (x &optional package)
(if package
(do-symbols (s package)
(if (search x (string s) :test #'char-equal)
(apropos2 s)))
(do-all-symbols (s)
(if (search x (string s) :test #'char-equal)
(apropos2 s))))
(values))
#+:packages
(defun apropos-list (x &optional package)
(let ((res nil))
(if package
(do-symbols (s package res)
(if (search x (string s) :test #'char-equal)
(push s res)))
(do-all-symbols (s res)
(if (search x (string s) :test #'char-equal)
(push s res))))))
;;;;;
;;;;; Additional Multiple Value Functions and Macros
;;;;;
(export
'(values-list multiple-value-list multiple-value-bind multiple-value-setq))
(defun values-list (x) (apply #'values x))
(defmacro multiple-value-list (form)
`(multiple-value-call #'list ,form))
(defmacro multiple-value-bind (vars form &rest body)
`(multiple-value-call #'(lambda (&optional ,@vars &rest ,(gensym)) ,@body)
,form))
(defmacro multiple-value-setq (variables form)
(let* ((tvars (mapcar #'(lambda (x) (gensym "V")) variables))
(pairs nil))
(mapc #'(lambda (x y) (push y pairs) (push x pairs)) variables tvars)
(if (null tvars) (push (gensym) tvars))
`(multiple-value-bind ,tvars ,form (setq ,@pairs) ,(first tvars))))
(push :common *features*)
syntax highlighted by Code2HTML, v. 0.9.1