home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / pd4.lzh / CMDS / init.lsp next >
Lisp/Scheme  |  1990-03-11  |  2KB  |  80 lines
  1. ; initialization file for XLISP 1.7
  2.  
  3. ; get some more memory
  4. (expand 1)
  5.  
  6. ; (when test code...) - execute code when test is true
  7. (defmacro when (test &rest code)
  8.           `(cond (,test ,@code)))
  9.  
  10. ; (unless test code...) - execute code unless test is true
  11. (defmacro unless (test &rest code)
  12.           `(cond ((not ,test) ,@code)))
  13.  
  14. ; (makunbound sym) - make a symbol be unbound
  15. (defun makunbound (sym) (setq sym '*unbound*) sym)
  16.  
  17. ; (objectp expr) - object predicate
  18. (defun objectp (x) (eq (type-of x) :OBJECT))
  19.  
  20. ; (filep expr) - file predicate
  21. (defun filep (x) (eq (type-of x) :FILE))
  22.  
  23. ; (mapcan fun list [ list ]...)
  24. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  25.  
  26. ; (mapcon fun list [ list ]...)
  27. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  28.  
  29. ; (set-macro-character ch fun [ tflag ])
  30. (defun set-macro-character (ch fun &optional tflag)
  31.     (setf (aref *readtable ch) (cons (if tflag :tmacro :nmacro) fun))
  32.     t)
  33.  
  34. ; (get-macro-character ch)
  35. (defun get-macro-character (ch)
  36.   (if (consp (aref *readtable* ch))
  37.     (cdr (aref *readtable* ch))
  38.     nil))
  39.  
  40. ; (save fun) - save a function definition to a file
  41. (defmacro save (fun)
  42.          `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  43.                  (fval (car ,fun))
  44.                  (fp (openo fname)))
  45.                 (cond (fp (print (cons (if (eq (car fval) 'lambda)
  46.                                            'defun
  47.                                            'defmacro)
  48.                                        (cons ',fun (cdr fval))) fp)
  49.                           (close fp)
  50.                           fname)
  51.                       (t nil))))
  52.  
  53. ; (debug) - enable debug breaks
  54. (defun debug ()
  55.        (setq *breakenable* t))
  56.  
  57. ; (nodebug) - disable debug breaks
  58. (defun nodebug ()
  59.        (setq *breakenable* nil))
  60.  
  61. ; initialize to enable breaks but no trace back
  62. (setq *breakenable* t)
  63. (setq *tracenable* nil)
  64.  
  65.  
  66. ; PC-specific Stuff
  67. (defun clear ()
  68.   (princ "\033\133\062\112") t)
  69.  
  70. (defun set-cursor (x y)
  71.   (princ "\033\133")(princ y)(princ "\073")(princ x)(princ "\110") t)
  72.  
  73. (defun home ()
  74.   (set-cursor 1 1) t)
  75.  
  76. (defun mode (m)
  77.   (princ "\033\133=")(princ m)(princ "h") t)
  78.  
  79.  
  80.