mcdonley@dinl.uucp (alan mcdonley) (03/20/90)
comp.sources.amiga but couldnt so here they are. Have fun
----*-----*-----*-----*CUT HERE*-----*-----*-----*-----*-----*
;***********************************************************************
;FILE: common.lsp
;DESCRIPTION: variety of XLISP functions to imitate Common Lisp
; these functions were origially developed under XLISP1.7 and
; have not been tested under AMXLISP2.0 but confidence is
; high that they will still work as far as implemented. Some
; funcs do not have all the options listed in Steele.
;POSTED BY: Alan McDonley - mcdonley@inlatlas.den.mmc.com
; ncar!dinl!mcdonley
;***********************************************************************
;FUNCTION: any
;PART OF:
;AUTHOR: Alan McDonley
;LAST MODIFIED: 11/22/87
;INPUTS: predicate and a list to apply the predicate to
;DESCRIPTION
; applys the predicate to every item in list
; returns non nil if any application of pred was successful
(defun any (pred lst)
(cond
((null lst) nil)
((atom lst) (if (pred lst) lst))
((pred (car lst)) (car lst))
(t (any pred (cdr lst)))))
;***********************************************************************
;FUNCTION: every
;PART OF:
;AUTHOR: Alan McDonley
;LAST MODIFIED: 11/21/87
;INPUTS: predicate and a list to apply the predicate to
;DESCRIPTION
; applys the predicate to every item in list
; returns non nil if every application of pred was successful
(defun every (pred lst)
(cond
((null lst) t)
((atom lst) (pred lst))
((pred (car lst)) (every pred (cdr lst)))))
;***********************************************************************
;FUNCTION: COERCE
;PART OF: common lisp
;AUTHOR: Alan McDonley
;LAST MODIFIED: 12/6/87
;INPUTS: valid lisp type and new type name
;DESCRIPTION
; Convert valid lisp type to specified new type.
; If new type same as current type, do not change.
; Currently only list to string
; and string to list
; implemented.
(defun coerce (thing newtype &aux temp1) ;need a temporary variable
(case newtype
('list
(case (type-of thing)
(:CONS thing)
(:STRING ;convert string to list
(dotimes (indx (flatc thing) (reverse temp1) )
(setq temp1 (cons (char thing indx) temp1))))
)
)
('string
(case (type-of thing)
(:STRING thing)
(:CONS ;convert list to string
(dolist (symb thing temp1)
(if (null temp1) (setq temp1 ""))
(setq temp1 (strcat temp1 (string symb)))))))
)
)
;***********************************************************************
(defmacro defvar (sym &optional valu doc)
(cond ((not (boundp sym)) ;set if not previously bound
`(setq ,sym ,valu)) ;valu will be nil if not supplied
(t nil)))
;***********************************************************************
(defun list-length (x)
(do ((n 0 (+ n 2)) ;counter
(fast x (cddr fast)) ;fast pointer leaps by 2.
(slow x (cdr slow))) ;slow pointer leaps by 1.
(nil)
;; if fast pointer hits the end, return the count.
(when (endp fast) (return n))
(when (endp (cdr fast)) (return (+ n 1)))
;;if fast pointer eventually equals slow pointer,
;;then we must be stuck in a circular list.
;;( a deeper property is the converse: if we are
;;stuck in a circular list, then eventually the
;;fast pointer will equal the slow pointer.
;;that fact justifies this implementation.)
(when (and (eq fast slow) (> n 0)) (return nil))))
;***********************************************************************
(DEFUN MYFORMAT (STREAM STR &REST VARS)
(PROG ((V VARS) (S STR))
TAG
(COND
((EQUAL (STRING (CHAR S 0)) "~")
(CASE (STRING (CHAR S 1))
("%" (TERPRI))
("a" (PRINC (CAR V))
(SETQ V (CDR V)))
("s" (PRIN1 (CAR V))
(SETQ V (CDR V)))
("A" (PRINC (CAR V))
(SETQ V (CDR V)))
("S" (PRIN1 (CAR V))
(SETQ V (CDR V)))
)
(SETQ S (SUBSTR S 2))
)
(T (WRITE-CHAR (CHAR S 0))))
(SETQ S (SUBSTR S 2))
(COND
((EQUAL S "") (RETURN T))
(T (GO TAG)))))
;***********************************************************************
(DEFUN REPLACE (S OLD NEW) ;substitute new s-exp for old s-exp in S
(COND
((EQUAL S OLD) NEW) ;test for old s-exp at every level
((NULL S) ()) ;done when empty
((LISTP S) ;not found yet, if list then break into
(CONS ; two parts and look in both, put answers
(REPLACE (CAR S) OLD NEW) ;in a list
(REPLACE (CDR S) OLD NEW))) ;look down deeper in list tail
(T S))) ;an atom and not equal to old so just put
; it into the list or return it if not
; preparing one.
;***********************************************************************
;common lisp push
;Winston and Horn pg 356
; (setq x '(c))
; (push 'b x)
(DEFMACRO PUSH (ITEM STACK)
`(SETQ ,STACK (CONS ,ITEM ,STACK)))
;***********************************************************************
;common lisp pop
;author: alan mcdonley
; (setq x '(a b c))
; (pop x)=> a
(DEFMACRO POP (STACK)
`(LET ((LOCAL_STACK ,STACK))
(EVAL `(SETQ ,STACK (CDR ,STACK)))
(CAR LOCAL_STACK)))
--
---------------------------------------------------------------------------
Alan McDonley, Martin Marietta Information and Communication Systems
(303) 977-3347 mcdonley@inlatlas.den.mmc.com
P.O.Box 1260 ncar!dinl!mcdonley
Denver,CO 80201-1260 Opinions are my own, not my employer's.
--------------------------------------------------------------------------sdl@lyra.mitre.org (Steven D. Litvinchouk) (03/21/90)
> ;FILE: common.lsp > ;DESCRIPTION: variety of XLISP functions to imitate Common Lisp > ; these functions were origially developed under XLISP1.7 and > ; have not been tested under AMXLISP2.0 but confidence is > ; high that they will still work as far as implemented. Some > ; funcs do not have all the options listed in Steele. Are there ftp sites that have AMXLISP2.0 available for anonymous ftp? Steven Litvintchouk MITRE Corporation Burlington Road Bedford, MA 01730 (617)271-7753 ARPA: sdl@mbunix.mitre.org UUCP: ...{att,decvax,genrad,ll-xn,philabs,utzoo}!linus!sdl "Where does he get those wonderful toys?" -- J. Napier (a.k.a. "The Joker") -- Steven Litvintchouk MITRE Corporation Burlington Road Bedford, MA 01730 (617)271-7753 ARPA: sdl@mbunix.mitre.org UUCP: ...{att,decvax,genrad,ll-xn,philabs,utzoo}!linus!sdl "Where does he get those wonderful toys?" -- J. Napier (a.k.a. "The Joker")