home *** CD-ROM | disk | FTP | other *** search
/ No Fragments Archive 10: Diskmags / nf_archive_10.iso / MAGS / SMARTMAG / V2.MSA / XADVISOR.STQ_INIT.LSP < prev    next >
Lisp/Scheme  |  2003-12-17  |  2KB  |  94 lines
  1. ; INIT.LSP for XLisp Version 1.5b
  2. ; Modified by Christopher F. Chabris
  3.  
  4.  
  5. ; Get some more memory - this should be OK with TOS on disk
  6. ;  if there are no RAMdisks:
  7. (expand 9)
  8.  
  9. ; Some more cxr functions:
  10. (defun caaar (x) (car (caar x)))
  11. (defun cdaar (x) (cdr (caar x)))
  12. (defun caadr (x) (car (cadr x)))
  13. (defun cdadr (x) (cdr (cadr x)))
  14. (defun cadar (x) (car (cdar x)))
  15. (defun cddar (x) (cdr (cdar x)))
  16. (defun caddr (x) (car (cddr x)))
  17. (defun cdddr (x) (cdr (cddr x)))
  18.  
  19. ; Some fake definitions for Common Lisp pseudo-compatiblity:
  20. (setq first car)
  21. (setq second cadr)
  22. (setq third caddr)
  23. (setq rest cdr)
  24.  
  25.  
  26. ; (when test code...) - execute code when test is true:
  27. (defmacro when (test &rest code)
  28.   `(cond (,test ,@code)))
  29.  
  30. ; (unless test code...) - execute code unless test is true:
  31. (defmacro unless (test &rest code)
  32.   `(cond ((not ,test) ,@code)))
  33.  
  34. ; (makunbound sym) - make a symbol be unbound:
  35. (defun makunbound (sym)
  36.   (setq sym '*unbound*)
  37.   sym)
  38.  
  39. ; (objectp expr) - object predicate:
  40. (defun objectp (x)
  41.   (eq (type-of x) :OBJECT))
  42.  
  43. ; (filep expr) - file predicate:
  44. (defun filep (x)
  45.   (eq (type-of x) :FILE))
  46.  
  47. ; (unintern sym) - remove a symbol from the oblist:
  48. (defun unintern (sym)
  49.   (cond ((member sym *oblist*)
  50.          (setq *oblist* (delete sym *oblist*))
  51.           t)
  52.          (t nil)))
  53.  
  54. ; (mapcan ...)
  55. (defmacro mapcan (&rest args)
  56.   `(apply #'nconc (mapcar ,@args)))
  57.  
  58. ; (mapcon ...)
  59. (defmacro mapcon (&rest args)
  60.   `(apply #'nconc (maplist ,@args)))
  61.  
  62. ; (save fun) - save a function definition to a file:
  63. (defmacro save (fun)
  64.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  65.           (fval ',fun)
  66.           (fp (openo fname)))
  67.          (cond (fp (print (cons (if (eq (car fval) 'lambda)
  68.                                     'defun
  69.                                     'defmacro)
  70.                                 (cons fun (cdr fval))) fp)
  71.                    (close fp)
  72.                    fname)
  73.                (t nil))))
  74.  
  75. ; (debug) - enable debug breaks:
  76. (defun debug ()
  77.   (setq *breakenable* t))
  78.  
  79. ; (nodebug) - disable debug breaks:
  80. (defun nodebug ()
  81.   (setq *breakenable* nil))
  82.  
  83. ; initialize to enable breaks but no traceback:
  84. (setq *breakenable* t)
  85. (setq *tracenable* nil)
  86.  
  87.  
  88. ; load the pretty-printer:
  89. (load "pprint.lsp")
  90.  
  91. ; display the memory statistics:
  92. (mem)
  93.  
  94.