;============================================================================
; WinLisp:
;
;   A   L I T T L E   C O M M O N   L I S P   C O M P A T I B I L I T Y
;
; Copyright (c) Stephan POPOVITCH 1988-1989
; Author: Stephan POPOVITCH
;============================================================================

(setq #:winlisp:colon 'common)

;;;============================= some useful synonyms ==================
(synonym 'first			'car)
(synonym 'rest			'cdr)
(synonym 'second		'cadr)
(synonym 'third			'caddr)
(synonym 'mapfirst		'mapcar)
(synonym 'symbol-plist		'plist)
(synonym 'symbol-value		'symeval)
(synonym 'symbol-function	'valfn)
(synonym 'ceiling		'ceil)
(synonym 'eql			'equal)
(synonym '/=			'<>)

(defmacro adjoin (s l)
          `(if (member ,s ,l) ,l (cons ,s ,l)))

(defmacro format (channel . to-be-printed)
          `(prin ,@to-be-printed))

;;;============================= do and do* macros. =======================
;;;============================= don't support "return" function ==========
(defmacro do (lvar (test . result) . body)
  `(let ,(mapcar (lambda (x)
                         (list (car x) (cadr x)))
                 lvar)
         (until ,test
                ,@body
                ,@(let ((x (mapcan
                              (lambda (x)
                                 (when (consp (cddr x))
                                       (list (car x) (caddr x))))
                              lvar)))
                       (when x `((psetq ,@x)))))
         ,@result))

(defmacro do* (lvar (test . result) . body)
   `(let* ,(mapcar (lambda (x)
                           (list (car x) (cadr x)))
                   lvar)
         (until ,test
                ,@body
                ,@(let ((x (mapcan
                              (lambda (x)
                                 (when (consp (cddr x))
                                       (list (car x) (caddr x))))
                              lvar)))
                       (when x `((setq ,@x)))))
         ,@result))

;;;============================= setf macro. ============================
(dmd setf forms
     (let ((res ()))
          (while forms
                 (newl res (:setf1 (nextl forms) (nextl forms))))
          (if (null (cdr res))
              (car res)
              `(progn ,@(nreverse res)))))

(de :setf1 (form val)
    (cond ((symbolp form)
           `(setq ,form ,val))
          ((or (atom form) (not (symbolp (car form))))
           (error 'setf "Can't setf this" form))
          ((getfn1 (car form) 'setf)
           (funcall (getfn1 (car form) 'setf) form val))
          ((memq  (typefn (car form)) '(dmacro macro))
           (:setf1 (macroexpand1 form) val))
          (t
            (error 'setf "Can't find setf method for" form))))

(dmd defsetf (fun pat var . body)
     (let ((name (symbol fun 'setf)))
          `(de ,name ((,name ,.pat) ,(car var))
               ,.body)))

(defsetf car (x) (y)    `(rplaca ,x ,y))
(defsetf cdr (x) (y)    `(rplacd ,x ,y))

(defsetf caar (x) (y)   `(rplaca (car ,x) ,y))
(defsetf cadr (x) (y)   `(rplaca (cdr ,x) ,y))
(defsetf cdar (x) (y)   `(rplacd (car ,x) ,y))
(defsetf cddr (x) (y)   `(rplacd (cdr ,x) ,y))

(defsetf caaar (x) (y)  `(rplaca (caar ,x) ,y))
(defsetf caadr (x) (y)  `(rplaca (cadr ,x) ,y))
(defsetf cadar (x) (y)  `(rplaca (cdar ,x) ,y))
(defsetf caddr (x) (y)  `(rplaca (cddr ,x) ,y))
(defsetf cdaar (x) (y)  `(rplacd (caar ,x) ,y))
(defsetf cdadr (x) (y)  `(rplacd (cadr ,x) ,y))
(defsetf cddar (x) (y)  `(rplacd (cdar ,x) ,y))
(defsetf cdddr (x) (y)  `(rplacd (cddr ,x) ,y))

(defsetf nth (i x) (v) `(rplaca (nthcdr ,i ,x) ,v))

(defsetf get (s i) (v) `(putprop ,s ,v ,i))
(defsetf getprop (s i) (v) `(putprop ,s ,v ,i))
(defsetf plist (x) (p) `(plist ,x ,p))

(defsetf symeval (x) (y) `(set ,x ,y))

(defsetf vref (x i) (v) `(vset ,x ,i ,v))
(defsetf sref (x i) (v) `(sset ,x ,i ,v))
