home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / LISP / XL2SRC.ZIP / XLisp2Src / Xlisp / lsp / init
Lisp/Scheme  |  1992-02-17  |  3KB  |  85 lines
  1. ; initialization file for XLISP-PLUS 2.1c
  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 be warned that it creates self modifying code!
  60. (setq *displace-macros* t)
  61.  
  62. ; Enable the following to have DOS do the line editing
  63. ; (setq  *dos-input* t)
  64.  
  65. ;; Select one of these three choices
  66. ;; Other modes will not read in other standard lsp files
  67.  
  68.  
  69. ; print in upper case, case insensitive input
  70.   (setq *print-case* :upcase *readtable-case* :upcase)
  71.  
  72. ; print in lower case
  73. ; (setq *print-case* :downcase *readtable-case* :upcase)
  74.  
  75. ; case sensitive, lowercase and uppercase swapped (favors lower case)
  76. ; (setq *print-case* :downcase *readtable-case* :invert)
  77.  
  78.  
  79. ;; Define Class and Object to be class and object when in case sensitive
  80. ;; mode
  81.  
  82. (when (eq *readtable-case* :invert)
  83.       (defconstant Class class)
  84.       (defconstant Object object))
  85.