home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / windows / winlisp.zip / LISPLIB.LZH / CMONLIB.WL < prev    next >
Text File  |  1989-09-22  |  4KB  |  114 lines
  1. ;============================================================================
  2. ; WinLisp:
  3. ;
  4. ;   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
  5. ;
  6. ; Copyright (c) Stephan POPOVITCH 1988-1989
  7. ; Author: Stephan POPOVITCH
  8. ;============================================================================
  9.  
  10. (setq #:winlisp:colon 'common)
  11.  
  12. ;;;============================= some useful synonyms ==================
  13. (synonym 'first            'car)
  14. (synonym 'rest            'cdr)
  15. (synonym 'second        'cadr)
  16. (synonym 'third            'caddr)
  17. (synonym 'mapfirst        'mapcar)
  18. (synonym 'symbol-plist        'plist)
  19. (synonym 'symbol-value        'symeval)
  20. (synonym 'symbol-function    'valfn)
  21. (synonym 'ceiling        'ceil)
  22. (synonym 'eql            'equal)
  23. (synonym '/=            '<>)
  24.  
  25. (defmacro adjoin (s l)
  26.           `(if (member ,s ,l) ,l (cons ,s ,l)))
  27.  
  28. (defmacro format (channel . to-be-printed)
  29.           `(prin ,@to-be-printed))
  30.  
  31. ;;;============================= do and do* macros. =======================
  32. ;;;============================= don't support "return" function ==========
  33. (defmacro do (lvar (test . result) . body)
  34.   `(let ,(mapcar (lambda (x)
  35.                          (list (car x) (cadr x)))
  36.                  lvar)
  37.          (until ,test
  38.                 ,@body
  39.                 ,@(let ((x (mapcan
  40.                               (lambda (x)
  41.                                  (when (consp (cddr x))
  42.                                        (list (car x) (caddr x))))
  43.                               lvar)))
  44.                        (when x `((psetq ,@x)))))
  45.          ,@result))
  46.  
  47. (defmacro do* (lvar (test . result) . body)
  48.    `(let* ,(mapcar (lambda (x)
  49.                            (list (car x) (cadr x)))
  50.                    lvar)
  51.          (until ,test
  52.                 ,@body
  53.                 ,@(let ((x (mapcan
  54.                               (lambda (x)
  55.                                  (when (consp (cddr x))
  56.                                        (list (car x) (caddr x))))
  57.                               lvar)))
  58.                        (when x `((setq ,@x)))))
  59.          ,@result))
  60.  
  61. ;;;============================= setf macro. ============================
  62. (dmd setf forms
  63.      (let ((res ()))
  64.           (while forms
  65.                  (newl res (:setf1 (nextl forms) (nextl forms))))
  66.           (if (null (cdr res))
  67.               (car res)
  68.               `(progn ,@(nreverse res)))))
  69.  
  70. (de :setf1 (form val)
  71.     (cond ((symbolp form)
  72.            `(setq ,form ,val))
  73.           ((or (atom form) (not (symbolp (car form))))
  74.            (error 'setf "Can't setf this" form))
  75.           ((getfn1 (car form) 'setf)
  76.            (funcall (getfn1 (car form) 'setf) form val))
  77.           ((memq  (typefn (car form)) '(dmacro macro))
  78.            (:setf1 (macroexpand1 form) val))
  79.           (t
  80.             (error 'setf "Can't find setf method for" form))))
  81.  
  82. (dmd defsetf (fun pat var . body)
  83.      (let ((name (symbol fun 'setf)))
  84.           `(de ,name ((,name ,.pat) ,(car var))
  85.                ,.body)))
  86.  
  87. (defsetf car (x) (y)    `(rplaca ,x ,y))
  88. (defsetf cdr (x) (y)    `(rplacd ,x ,y))
  89.  
  90. (defsetf caar (x) (y)   `(rplaca (car ,x) ,y))
  91. (defsetf cadr (x) (y)   `(rplaca (cdr ,x) ,y))
  92. (defsetf cdar (x) (y)   `(rplacd (car ,x) ,y))
  93. (defsetf cddr (x) (y)   `(rplacd (cdr ,x) ,y))
  94.  
  95. (defsetf caaar (x) (y)  `(rplaca (caar ,x) ,y))
  96. (defsetf caadr (x) (y)  `(rplaca (cadr ,x) ,y))
  97. (defsetf cadar (x) (y)  `(rplaca (cdar ,x) ,y))
  98. (defsetf caddr (x) (y)  `(rplaca (cddr ,x) ,y))
  99. (defsetf cdaar (x) (y)  `(rplacd (caar ,x) ,y))
  100. (defsetf cdadr (x) (y)  `(rplacd (cadr ,x) ,y))
  101. (defsetf cddar (x) (y)  `(rplacd (cdar ,x) ,y))
  102. (defsetf cdddr (x) (y)  `(rplacd (cddr ,x) ,y))
  103.  
  104. (defsetf nth (i x) (v) `(rplaca (nthcdr ,i ,x) ,v))
  105.  
  106. (defsetf get (s i) (v) `(putprop ,s ,v ,i))
  107. (defsetf getprop (s i) (v) `(putprop ,s ,v ,i))
  108. (defsetf plist (x) (p) `(plist ,x ,p))
  109.  
  110. (defsetf symeval (x) (y) `(set ,x ,y))
  111.  
  112. (defsetf vref (x i) (v) `(vset ,x ,i ,v))
  113. (defsetf sref (x i) (v) `(sset ,x ,i ,v))
  114.