home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / INIT.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  4KB  |  114 lines
  1. ; initialization file for XLISP-PLUS 2.1h
  2.  
  3. (princ "XLISP-PLUS 2.1h contains contributed code by:
  4. Tom Almy, Mikael Pettersson, Neal Holtz, Johnny Greenblatt, Ken Whedbee,
  5. Blake McBride, Pete Yadlowsky, Hume Smith, and Richard Zidlicky.
  6. Portions copyright (c) 1988, Luke Tierney.\n")
  7.  
  8. ;; Set this up however you want it
  9. (setq *features* (list :xlisp :21h))
  10.  
  11. ;; Differences in various implementations, needed by example programs
  12. (when (fboundp 'export)
  13.       (setq *features* (cons :packages *features*)))
  14. #+:packages
  15. (in-package "XLISP")
  16. (when (fboundp 'get-internal-run-time) 
  17.       (setq *features* (cons :times *features*)))
  18. (when (fboundp 'generic) 
  19.       (setq *features* (cons :generic *features*)))
  20. (when (fboundp 'find-if)
  21.       (setq *features* (cons :posfcns *features*)))
  22. (when (fboundp 'numerator)
  23.       (setq *features* (cons :bignums *features*)))
  24. (when (fboundp 'log)
  25.       (setq *features* (cons :math *features*)))
  26. (when (alphanumericp #\M-C-@)
  27.       (setq *features* (cons :pc8 *features*)))
  28. (when (fboundp 'values)
  29.       (setq *features* (cons :mulvals *features*)))
  30. (when (fboundp 'get-key)
  31.       (setq *features* (cons :getkey *features*)))
  32.  
  33. #+:packages  ;; These should not be exported from XLISP
  34. (unexport '(%copy-struct %struct-set %struct-ref %struct-type-p %make-struct))
  35.  
  36. #-:packages
  37. (defun export (x))    ;; dummy definitions for package functions
  38. #-:packages
  39. (defun in-package (x))
  40.  
  41. (export '(strcat set-macro-character get-macro-character savefun
  42.       debug nodebug))
  43.  
  44. (defun strcat (&rest str)    ;; Backwards compatibility
  45.        (apply #'concatenate 'string str))
  46.  
  47.  
  48. ; (set-macro-character ch fun [ tflag ])
  49. (defun set-macro-character (ch fun &optional tflag)
  50.     (setf (aref *readtable* (char-int ch))
  51.           (cons (if tflag :tmacro :nmacro) fun))
  52.     t)
  53.  
  54. ; (get-macro-character ch)
  55. (defun get-macro-character (ch)
  56.   (if (consp (aref *readtable* (char-int ch)))
  57.     (cdr (aref *readtable* (char-int ch)))
  58.     nil))
  59.  
  60. ; (savefun fun) - save a function definition to a file
  61. (defmacro savefun (fun)
  62.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  63.           (fval (get-lambda-expression (symbol-function ',fun)))
  64.           (fp (open fname :direction :output)))
  65.      (cond (fp (print (cons (if (eq (car fval) 'lambda)
  66.                                 'defun
  67.                                 'defmacro)
  68.                             (cons ',fun (cdr fval))) fp)
  69.                (close fp)
  70.                fname)
  71.            (t nil))))
  72.  
  73. ; (debug) - enable debug breaks
  74. (defun debug ()
  75.        (setq *breakenable* t))
  76.  
  77. ; (nodebug) - disable debug breaks
  78. (defun nodebug ()
  79.        (setq *breakenable* nil))
  80.  
  81. ; initialize to enable breaks but no trace back
  82. (setq *breakenable* t *tracenable* nil)
  83.  
  84.  
  85. ; macros get displaced with expansion
  86.  
  87. (setq *displace-macros* t)
  88.  
  89. ;; Select one of these three choices
  90. ;; Other modes will not read in other standard lsp files
  91.  
  92.  
  93. ; print in upper case, case insensitive input
  94. ;(setq *print-case* :upcase *readtable-case* :upcase)
  95.  
  96. ; print in lower case
  97. (setq *print-case* :downcase *readtable-case* :upcase)
  98.  
  99. ; case sensitive, lowercase and uppercase swapped (favors lower case)
  100. ;(setq *print-case* :downcase *readtable-case* :invert)
  101.  
  102. ; Make this "T" to use doskey or run under Epsilon
  103. ; Comment out altogether for non-MSDOS environments
  104. (setq *dos-input* nil)
  105.  
  106. ;; Define Class and Object to be class and object when in case sensitive
  107. ;; mode
  108.  
  109. (when (eq *readtable-case* :invert)
  110.       (defconstant Class class)
  111.       (defconstant Object object)
  112.       (export '(Class Object)))
  113.  
  114.