home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / examples / xlisp-1.6 / init.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  3.4 KB  |  100 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         init.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  initialization file for XLISP 1.6
  7. ; Author:       David Betz
  8. ; Created:      Sat Oct  5 20:55:28 1991
  9. ; Modified:     Sat Oct  5 20:55:53 1991 (Niels Mayer) mayer@hplnpm
  10. ; Language:     Lisp
  11. ; Package:      N/A
  12. ; Status:       X11r5 contrib tape release
  13. ;
  14. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. ;
  17. ; Permission to use, copy, modify, distribute, and sell this software and its
  18. ; documentation for any purpose is hereby granted without fee, provided that
  19. ; the above copyright notice appear in all copies and that both that
  20. ; copyright notice and this permission notice appear in supporting
  21. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  22. ; used in advertising or publicity pertaining to distribution of the software
  23. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  24. ; makes no representations about the suitability of this software for any
  25. ; purpose.  It is provided "as is" without express or implied warranty.
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. ; get some more memory
  29. (expand 1)
  30.  
  31. ; some fake definitions for Common Lisp pseudo compatiblity
  32. (setq first  car)
  33. (setq second cadr)
  34. (setq rest   cdr)
  35.  
  36. ; (when test code...) - execute code when test is true
  37. (defmacro when (test &rest code)
  38.           `(cond (,test ,@code)))
  39.  
  40. ; (unless test code...) - execute code unless test is true
  41. (defmacro unless (test &rest code)
  42.           `(cond ((not ,test) ,@code)))
  43.  
  44. ; (makunbound sym) - make a symbol be unbound
  45. (defun makunbound (sym) (setq sym '*unbound*) sym)
  46.  
  47. ; (objectp expr) - object predicate
  48. (defun objectp (x) (eq (type-of x) :OBJECT))
  49.  
  50. ; (filep expr) - file predicate
  51. (defun filep (x) (eq (type-of x) :FILE))
  52.  
  53. ; (unintern sym) - remove a symbol from the oblist
  54. (defun unintern (sym) (cond ((member sym *oblist*)
  55.                              (setq *oblist* (delete sym *oblist*))
  56.                              t)
  57.                             (t nil)))
  58.  
  59. ; (mapcan fun list [ list ]...)
  60. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  61.  
  62. ; (mapcon fun list [ list ]...)
  63. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  64.  
  65. ; (set-macro-character ch fun [ tflag ])
  66. (defun set-macro-character (ch fun &optional tflag)
  67.     (setf (aref *readtable* ch) (cons (if tflag :tmacro :nmacro) fun))
  68.     t)
  69.  
  70. ; (get-macro-character ch)
  71. (defun get-macro-character (ch)
  72.   (if (consp (aref *readtable* ch))
  73.     (cdr (aref *readtable* ch))
  74.     nil))
  75.  
  76. ; (save fun) - save a function definition to a file
  77. (defmacro save (fun)
  78.          `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  79.                  (fval (car ,fun))
  80.                  (fp (openo fname)))
  81.                 (cond (fp (print (cons (if (eq (car fval) 'lambda)
  82.                                            'defun
  83.                                            'defmacro)
  84.                                        (cons ',fun (cdr fval))) fp)
  85.                           (close fp)
  86.                           fname)
  87.                       (t nil))))
  88.  
  89. ; (debug) - enable debug breaks
  90. (defun debug ()
  91.        (setq *breakenable* t))
  92.  
  93. ; (nodebug) - disable debug breaks
  94. (defun nodebug ()
  95.        (setq *breakenable* nil))
  96.  
  97. ; initialize to enable breaks but no trace back
  98. (setq *breakenable* t)
  99. (setq *tracenable* nil)
  100.