sys.lac

;;; -*-Lisp-*-

;;; Rationale:
;;;
;;; The basic definitions, except where noted, are compatible with
;;; LISP 1.5.
;;; The evaluator itself is, though, differente, and this shows in
;;; the presence of LET and the absence of FUNCTION

;;;
;;; Definitions
;;;

(define defmacro
  (macro (name binds &rest body) `(define ,name (macro ,binds ,@body))))

(defmacro defun (name binds &rest body)
  `(define ,name (labels ,name , binds ,@body)))

(defmacro setq (x v) `(set ',x ,v))

(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))
(defun caaar (x) (car (car (car x))))
(defun caadr (x) (car (car (cdr x))))
(defun cadar (x) (car (cdr (car x))))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdaar (x) (cdr (car (car x))))
(defun cdadr (x) (cdr (car (cdr x))))
(defun cddar (x) (cdr (cdr (car x))))
(defun cdddr (x) (cdr (cdr (cdr x))))

(defmacro let (binds &rest body)
  `((lambda ,(mapcar car binds) ,@body)
    ,@(mapcar cadr binds)))

;;;
;;; Logical Connectives
;;;

(defun not (x)
	(cond (x NIL) (T)))

(defmacro or (&rest y)
  (cond
   (y `(cond (,(car y)) ((or ,@(cdr y)))))
   (T 'NIL)))

(defmacro and (&rest y)
  (cond
   (y `(cond (,(car y) (and ,@(cdr y)))))
   (T 'T)))


;;;
;;; Elementary Functions
;;;

;; car implicit
;; cdr implicit
;; cons implicit

(defun atom (x) (cond ((consp x) NIL)(T T)))

;; eq implicit

(defun equal (x y)
  (cond
   ((atom x) (cond ((atom y) (atom-equal x y))))
   ((consp x)(cond ((consp y) (cond ((equal (car x) (car y))
				     (equal (cdr x) (cdr y)))))))))

(defun list (&rest y) y)

(defun null (x) (eq x NIL))

(defun listp (x) (or (null x) (consp x)))

;; rplaca implicit
;; rplacd implicit

;;;
;;; List Handling Functions
;;;

;;; N.B.: LISP 1.5 seem to support only two arguments
(defun append (&rest y)
  (cond
   ((null y)        NIL)
   ((null (caar y)) (apply append (cdr y)))
   (t               (cons (caar y)
                          (apply append (cons (cdar y) (cdr y)))))))

(defun assoc (x a)
  (cond
   ((null a)           NIL)
   ((equal (caar a) x) (car a))
   (t                  (assoc x (cdr a)))))

(defun assq (x a)
  (cond
   ((null a)        NIL)
   ((eq (caar a) x) (car a))
   (t               (assq x (cdr a)))))

;; differ from clisp: (nconc 'X) error here.
(defun nconc (x y)
  (cond ((null x) y)
	(T (let ((f (labels f (z)
			    (cond ((cdr z) (f (cdr z)))
				  (T       (rplacd z y))))))
	     (f x))
	   x)))

(defmacro conc (&rest y)
  (cond
   ((null y) 'NIL)
   (T        `(nconc ,(car y) (conc ,@(cdr y))))))

(defun copy (x)
  (cond
   ((null x) NIL)
   ((atom x) x)
   (T        (cons (copy (car x)) (copy (cdr x))))))

(defun reverse (l)
  (let ((r) (f (labels f (u v)
		  (cond (u (f (cdr u) (cons (car u) v)))
		  	(T v)))))
	  (f l NIL)))

(defun member (x l)
  (cond
   ((null l) NIL)
   ((equal x (car l)) T)
   (T        (member x (cdr l)))))
    
(defun member (el lst)
  (if (null lst) 
      NIL 
      (or (eq (car lst) el) (member el (cdr lst)))))

(defun length (lst)
  (cond
   ((null lst) 0)
   (T          (+ 1 (length (cdr lst))))))

(defun efface (x l)
  (cond
   ((null l)          NIL)
   ((equal x (car l)) (cdr l))
   (T                 (rplacd l (efface x (cdr l))))))

(defun subst (x y z)
	(cond
	 ((equal y z) 	x)
	 ((atom z)	z)	
	 (t		(cons	(subst x y (car z))
				(subst x y (cdr z))))))

;;;
;;; Functionals
;;; N.B.: Original LISP 1.5 (not MACLISP and subsequents) had the functional
;;;       argument as last parameter.
;;;

(defun maplist (f x)
  (cond
   ((null x) NIL)
   (T        (cons (f x) (maplist (cdr x) f)))))

(defun mapcon (f x)
  (cond
   ((null x) NIL)
   (T        (nconc (f x) (maplist (cdr x) f)))))

(defun map (f x)
  (cond
   ((null x) NIL)
   (T        (maplist (cdr x) f)))
   NIL)

;; mapcar is embedded, for historical reasons

(defun search (x p f u)
  (cond
   ((null x) (u x))
   ((p x) (f x))
   (t (search (cdr x) p f u))))


;;;
;;; Arithmetic Functions
;;; N.B.: These should work both for fixnums and floats
;;;

(defun lessp (x y) (< x y))
(defun greaterp (x y) (> x y))
(defun zerop (x) (eq x 0))
(defun onep (x) (eq x 1))
(defun minusp (x) (< x 0))
(defun numberp (x) (integerp x))
;; fixp is integerp

(defun plus (&rest x)
  (cond
   ((null x) 0)
   (t        (+ (car x) (apply plus (cdr x))))))

(defun difference (x y) (- x y))

(defun minus (x) -x)

(defun times (&rest x)
  (cond
   ((null x) 1)
   (t        (* (car x) (apply times (cdr x))))))

(defun add1 (x) (+ x 1))

(defun sub1 (x) (- x 1))

(defun max (x &rest y)
  (cond
   ((null y)       x)
   ((<= x (car y)) (apply max y))
   (t              (apply max (cons x (cdr y))))))

(defun min (x &rest y)
  (cond
   ((null y)       x)
   ((>= x (car y)) (apply min y))
   (t              (apply min (cons x (cdr y))))))

(defun quotient (x y) (/ x y))
(defun remainder (x y) (% x y))
(defun divide (x y) (list (quotient x y) (remainder x y)))

(defun expt (x y)
  (cond
   ((zerop y) 1)
   (t         (* x (expt x (sub1 y))))))


;;;
;;; Misc
;;; Mostly from Common Lisp
;;;

(defun first (l) (car l))
(defun second (l) (first (cdr l)))
(defun third (l) (second (cdr l)))
(defun fourth (l) (third (cdr l)))
(defun fifth (l) (fourth (cdr l)))
(defun sixth (l) (fifth (cdr l)))
(defun seventh (l) (sixth (cdr l)))
(defun eighth (l) (seventh (cdr l)))
(defun ninth (l) (eighth (cdr l)))
(defun tenth (l) (ninth (cdr l)))
(defun last (x) (cond ((null (cdr x)) x) (t (last (cdr x)))))

(defmacro if (test true false)
  `(cond (,test ,true) (t ,false)))

(defun remove-if (test lst) 
  (if (null lst) 
      NIL 
      (if (test (car lst)) 
	  (remove-if test (cdr lst)) 
	  (cons (car lst) (remove-if test (cdr lst)))))) 

(defun remove-if-not (test lst)
  (remove-if (lambda (x) (not (test x))) lst))

(defmacro push (x place) 
  (list 'set (list 'quote place) (list 'cons x place)))

(defun nthcdr (n l)
       (cond ((eq n 0) l)
       	     (t        (nthcdr (- n 1) (cdr l)))))
(defun nth (n l)
       (car (nthcdr n l)))

(defun 1+ (x) (+ 1 x))
(defun 1- (x) (- x 1))
(defun evenp (x) (eq (% x 2) 0))
(defun oddp (x) (eq (% x 2) 1))
(defmacro incf (x) `(setq ,x (1+ ,x)))
(defmacro decf (x) `(setq ,x (1- ,x)))