home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / contrib / xmu / xmu-init.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  5.0 KB  |  131 lines

  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         xmu-init.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  WINTERP-based Menu Server INITIALIZATION FILE
  7. ; Author:       Richard Hess, Consilium
  8. ; Created:      Sun Oct  6 00:04:34 1991
  9. ; Modified:     Sun Oct  6 00:05:17 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 David Betz not be
  22. ; used in advertising or publicity pertaining to distribution of the software
  23. ; without specific, written prior permission.  Hewlett-Packard and David Betz
  24. ; make 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. ; +---------------------------------------------------------------------------
  29. ;  WHO:    Richard Hess                    CORP:   Consilium
  30. ;  TITLE:  Staff Engineer                  VOICE:  [415] 691-6342
  31. ;      [ X-SWAT Team:  Special Projects ]  USNAIL: 640 Clyde Court
  32. ;  UUCP:   ...!uunet!cimshop!rhess                 Mountain View, CA 94043
  33. ; +---------------------------------------------------------------------------
  34.  
  35. ; initialization file for XLISP 2.1 & WINTERP
  36.  
  37. ; define some macros
  38. (defmacro defvar (sym &optional val)
  39.   `(if (boundp ',sym) ,sym (setq ,sym ,val)))
  40. (defmacro defparameter (sym val)
  41.   `(setq ,sym ,val))
  42. (defmacro defconstant (sym val)
  43.   `(setq ,sym ,val))
  44.  
  45. ; (makunbound sym) - make a symbol value be unbound
  46. (defun makunbound (sym) (setf (symbol-value sym) '*unbound*) sym)
  47.  
  48. ; (fmakunbound sym) - make a symbol function be unbound
  49. (defun fmakunbound (sym) (setf (symbol-function sym) '*unbound*) sym)
  50.  
  51. ; (mapcan fun list [ list ]...)
  52. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  53.  
  54. ; (mapcon fun list [ list ]...)
  55. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  56.  
  57. ; (set-macro-character ch fun [ tflag ])
  58. (defun set-macro-character (ch fun &optional tflag)
  59.     (setf (aref *readtable* (char-int ch))
  60.           (cons (if tflag :tmacro :nmacro) fun))
  61.     t)
  62.  
  63. ; (get-macro-character ch)
  64. (defun get-macro-character (ch)
  65.   (if (consp (aref *readtable* (char-int ch)))
  66.     (cdr (aref *readtable* (char-int ch)))
  67.     nil))
  68.  
  69. ; (savefun fun) - save a function definition to a file
  70. (defmacro savefun (fun)
  71.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  72.           (fval (get-lambda-expression (symbol-function ',fun)))
  73.           (fp (open fname :direction :output)))
  74.      (cond (fp (print (cons (if (eq (car fval) 'lambda)
  75.                                 'defun
  76.                                 'defmacro)
  77.                             (cons ',fun (cdr fval))) fp)
  78.                (close fp)
  79.                fname)
  80.            (t nil))))
  81.  
  82. ; (debug) - enable debug breaks
  83. (defun debug ()
  84.        (setq *breakenable* t))
  85.  
  86. ; (nodebug) - disable debug breaks
  87. (defun nodebug ()
  88.        (setq *breakenable* nil))
  89.  
  90. (setq *breakenable* nil)        ; T allows entry into breakloop
  91. (setq *tracenable* t)            ; set this to T if you want to see a
  92.                     ; backtrace on error.
  93. (setq *gc-flag* t)            ; we want to see garbage collection messages
  94.  
  95.  
  96. ;; --------------------------------------------------------------------[ new ]
  97.  
  98. (send WIDGET_CLASS :answer :get '(resource-name)
  99.  '(
  100.    (car (send self :GET_VALUES resource-name NIL))
  101.    ))
  102.  
  103.  
  104. ;; ------------------------------------------------------------------[ rhess ]
  105.  
  106. (load "xmu-menu.lsp")        ;; [ NEW ]:  menu server library... [ core ]
  107. (load "xmu-cache.lsp")        ;; [ NEW ]:  initialize the menu cache...
  108. (load "gnu-hooks.lsp")        ;; [ NEW ]:  GNU hooks for menu server...
  109.  
  110. ;;; (setq *NUKE_WIDGET* (send TOP_LEVEL_SHELL_WIDGET_CLASS :new
  111. ;;;                           :XMN_TITLE            "XmuNuke"
  112. ;;;                           :XMN_ICON_NAME        "XmuNuke"
  113. ;;;                           :XMN_GEOMETRY         "+996+540"
  114. ;;;                           :XMN_MWM_FUNCTIONS     MWM_FUNC_MOVE
  115. ;;; ;;              :XMN_MWM_FUNCTIONS    (logior MWM_FUNC_MINIMIZE
  116. ;;; ;;                            MWM_FUNC_MOVE)
  117. ;;;                           ))
  118. ;;; 
  119. ;;; (setq *NEURO_W* (send XM_PUSH_BUTTON_WIDGET_CLASS
  120. ;;;                       :new :managed         *NUKE_WIDGET*
  121. ;;;                       :XMN_LABEL_STRING     "Neuromancer"
  122. ;;;                       :XMN_FONT_LIST        "-*-helvetica-bold-r-normal--12-*"
  123. ;;;                       :XMN_HIGHLIGHT_THICKNESS  0
  124. ;;;                       ))
  125. ;;; 
  126. ;;; (send *NEURO_W* :add_callback :XMN_ACTIVATE_CALLBACK '() '((exit)))
  127. ;;; 
  128. ;;; (send *NUKE_WIDGET* :REALIZE)
  129.  
  130. ;; ----------------------------------------------------------------------<eof>
  131.