home *** CD-ROM | disk | FTP | other *** search
/ ftp.uni-stuttgart.de/pub/systems/acorn/ / Acorn.tar / Acorn / acornet / dev / xlisp+ / xlisp+.spk / lsp / init < prev    next >
Lisp/Scheme  |  1992-10-02  |  3KB  |  94 lines
  1. ; initialization file for XLISP-PLUS 2.1e
  2.  
  3. (princ "XLISP-PLUS contains contributed code by:
  4. Tom Almy, Mikael Pettersson, Neal Holtz, Johnny Greenblatt, Ken Whedbee,
  5. Blake McBride, and Pete Yadlowsky.
  6. Portions Copyright (c) 1988, Luke Tierney.\n")
  7.  
  8. (defun strcat (&rest str)    ;; Backwards compatibility
  9.        (apply #'concatenate 'string str))
  10.  
  11.  
  12. ; (fmakunbound sym) - make a symbol function be unbound
  13. (defun fmakunbound (sym) (setf (symbol-function sym) '*unbound*) sym)
  14.  
  15. ; (mapcan fun list [ list ]...)
  16. ; (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  17.  
  18. ; (mapcon fun list [ list ]...)
  19. ; (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  20.  
  21. ; (set-macro-character ch fun [ tflag ])
  22. (defun set-macro-character (ch fun &optional tflag)
  23.     (setf (aref *readtable* (char-int ch))
  24.           (cons (if tflag :tmacro :nmacro) fun))
  25.     t)
  26.  
  27. ; (get-macro-character ch)
  28. (defun get-macro-character (ch)
  29.   (if (consp (aref *readtable* (char-int ch)))
  30.     (cdr (aref *readtable* (char-int ch)))
  31.     nil))
  32.  
  33. ; (savefun fun) - save a function definition to a file
  34. (defmacro savefun (fun)
  35.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  36.           (fval (get-lambda-expression (symbol-function ',fun)))
  37.           (fp (open fname :direction :output)))
  38.      (cond (fp (print (cons (if (eq (car fval) 'lambda)
  39.                                 'defun
  40.                                 'defmacro)
  41.                             (cons ',fun (cdr fval))) fp)
  42.                (close fp)
  43.                fname)
  44.            (t nil))))
  45.  
  46. ; (debug) - enable debug breaks
  47. (defun debug ()
  48.        (setq *breakenable* t))
  49.  
  50. ; (nodebug) - disable debug breaks
  51. (defun nodebug ()
  52.        (setq *breakenable* nil))
  53.  
  54. ; initialize to enable breaks but no trace back
  55. (setq *breakenable* t *tracenable* nil)
  56.  
  57.  
  58. ; macros get displaced with expansion
  59. ; Good feature, but commented out to avoid shock.
  60. ; (setq *displace-macros* t)
  61.  
  62. ;; Select one of these three choices
  63. ;; Other modes will not read in other standard lsp files
  64.  
  65.  
  66. ; print in upper case, case insensitive input
  67. (setq *print-case* :upcase *readtable-case* :upcase)
  68.  
  69. ; print in lower case
  70. ; (setq *print-case* :downcase *readtable-case* :upcase)
  71.  
  72. ; case sensitive, lowercase and uppercase swapped (favors lower case)
  73. ; (setq *print-case* :downcase *readtable-case* :invert)
  74.  
  75.  
  76. ;; Define Class and Object to be class and object when in case sensitive
  77. ;; mode
  78.  
  79. (when (eq *readtable-case* :invert)
  80.       (defconstant Class class)
  81.       (defconstant Object object))
  82.  
  83. ;; Set this up however you want it
  84. (setq *features* (list :xlisp))
  85. ;; Differences in various implementations, needed by example programs
  86. (when (fboundp 'get-internal-run-time) 
  87.       (setq *features* (cons :times *features*)))
  88. (when (fboundp 'generic) 
  89.       (setq *features* (cons :generic *features*)))
  90. (when (fboundp 'find-if)
  91.       (setq *features* (cons :posfcns *features*)))
  92. (when (fboundp 'log)
  93.       (setq *features* (cons :math *features*)))
  94.