home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / MENUSPCS.ZIP / MENLD.S < prev    next >
Encoding:
Text File  |  1987-12-14  |  3.2 KB  |  90 lines
  1. ;;; ------------------------------------------------------------
  2. ;;; Menus for Scheme (tm)
  3. ;;; AN EXPERIMENTAL MENU-DRIVEN USER INTERFACE FOR PC SCHEME
  4. ;;; LOAD MENU
  5. ;;; $Revision:   1.0  $   $Date:   14 Dec 1987  0:40:28  $
  6. ;;; ------------------------------------------------------------
  7. ;;; Copyright (c) 1987 by Morton Goldberg.  
  8. ;;;
  9. ;;; Permission is granted to make copies of this program text
  10. ;;; for personal, non-commercial use provided this notice of
  11. ;;; copyright appears in all copies and derived works.  All
  12. ;;; other rights reserved.  In particular, you may not publish
  13. ;;; or otherwise distribute any copies of this text or any
  14. ;;; derived works without permission from the copyright holder.
  15. ;;; ------------------------------------------------------------
  16. ;;; Implementation Language: Texas Instruments' PC Scheme
  17. ;;; (Version 3.0)
  18. ;;; ------------------------------------------------------------
  19.  
  20. (writeln "Menu-Driven User Interface -- Load Menu")
  21. (writeln "Copyright (c) 1987 by Morton Goldberg")
  22. (let ((rev-number "$Revision:   1.0  $"))
  23.   ;; Write the revision number string without the leading
  24.   ;; and trailing dollar-signs (which are needed by the
  25.   ;; version control system).
  26.   (writeln (substring rev-number
  27.                       1
  28.                       (sub1 (string-length rev-number)))))
  29.  
  30. ;;; ------------------------------------------------------------
  31. ;;; LOAD MENU
  32. ;;; ------------------------------------------------------------
  33. ;;; *.Fsl CHOICE
  34.  
  35. ;;; Force a file to be loaded in the user-initial-environment
  36. ;;; instead of the current environment.
  37. (define (menu-load file)
  38.   (eval `(load ,file) user-initial-environment))
  39.  
  40. ;;; Create a menu of the *.FSL files in the current directory,
  41. ;;; display it, and load the file selected by the user.
  42. (define (fast-load-from-menu)
  43.   (define menu
  44.     (files->menu "*.FSL" 20 menu-load *vertical-menu-init*))
  45.   (if menu
  46.     (begin
  47.       (h-justify 'CENTER menu)
  48.       (v-justify 'TOP menu)
  49.       (send menu popup)))
  50.   'USER-ABORT)
  51.  
  52. ;;; ------------------------------------------------------------
  53. ;;; *.S CHOICE
  54.  
  55. ;;; Create a menu of the *.S files in the current directory,
  56. ;;; display it, and load the file selected by the user.
  57. (define (load-from-menu)
  58.   (define menu
  59.     (files->menu "*.S" 20 menu-load *vertical-menu-init*))
  60.   (if menu
  61.     (begin
  62.       (h-justify 'CENTER menu)
  63.       (v-justify 'TOP menu)
  64.       (send menu popup)))
  65.   'USER-ABORT)
  66.  
  67. ;;; ------------------------------------------------------------
  68. ;;; Load a .S or .FSL file from the current directory by
  69. ;;; choosing from a menu.
  70.  
  71. ;;; This is the item list for the load menu.
  72. (define *load-menu-items*
  73.   `(("*.S" #\s ,load-from-menu)
  74.     ("*.Fsl" #\f ,fast-load-from-menu)))
  75.  
  76. ;;; Create the load menu, which is a vertical menu.
  77. (define *load-menu*
  78.   (let ((menu (make-vertical-menu *vertical-menu-init*
  79.                                   *load-menu-items*)))
  80.     (h-justify 'CENTER menu)
  81.     (v-justify 'TOP menu)
  82.     menu))
  83.  
  84. ;;; Link to the top-level menu.
  85. (define (load-menu)
  86.   (send *load-menu* popup)
  87.   *the-non-printing-object*)
  88.  
  89. ;;; ------------------------------------------------------------
  90.