home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / MENUSPCS.ZIP / MENCO.S next >
Encoding:
Text File  |  1987-12-14  |  3.2 KB  |  78 lines
  1. ;;; ------------------------------------------------------------
  2. ;;; Menus for Scheme (tm)
  3. ;;; AN EXPERIMENTAL MENU-DRIVEN USER INTERFACE FOR PC SCHEME
  4. ;;; COMPILE MENU
  5. ;;; $Revision:   1.0  $   $Date:   14 Dec 1987  0:39:44  $
  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 -- Compile 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. ;;; COMPILE MENU
  32. ;;; ------------------------------------------------------------
  33. ;;; REMOVE THE EXTENSION FROM A FILE-SPEC STRING
  34.  
  35. ;;; Given that `file-spec' is a string such as "foo.fsl",
  36. ;;; "foo.", or "foo", this procedure returns "foo".
  37. (define (remove-extension file-spec)
  38.   ;; Look for #\. and return everything to the left of it.
  39.   (let ((nn (substring-find-previous-char-in-set
  40.               file-spec 0 (string-length file-spec) #\.)))
  41.     (if nn
  42.       (substring file-spec 0 nn)
  43.       file-spec)))
  44.  
  45. ;;; ------------------------------------------------------------
  46.  
  47. ;;; Link to the top-level menu.
  48.  
  49. ;;; Calling this menu function will create a menu of the *.S
  50. ;;; files in the current directory and display it.  Assuming
  51. ;;; that the string "<name>.S" is chosen by the user, then (1)
  52. ;;; file <name>.S will be compiled to give the file <name>.SO,
  53. ;;; (2) <name>.SO will be converted to <name>.FSL, and (3)
  54. ;;; <name>.SO will be deleted.
  55. (define (compile-menu)
  56.   (define s-file "")
  57.   (define (choice-is a-string)
  58.     (set! s-file a-string))
  59.   (define menu
  60.     (files->menu "*.S" 20 choice-is *vertical-menu-init*))
  61.   (when menu
  62.     (h-justify 'CENTER menu)
  63.     (v-justify 'TOP menu)
  64.     (send menu popup)
  65.     (if (> (string-length s-file) 0)
  66.       (let* ((base-name (remove-extension s-file))
  67.             (so-file (string-append base-name ".SO"))
  68.             (fsl-file (string-append base-name ".FSL"))
  69.             (cmd-tail (string-append so-file " " fsl-file)))
  70.         ;; Need a graceful way to handle compiler errors.
  71.         (eval `(compile-file ,s-file ,so-file)
  72.               user-initial-environment)
  73.         (dos-call *make-fsl-spec* cmd-tail 16384)
  74.         (dos-delete so-file))))
  75.   *the-non-printing-object*)
  76.  
  77. ;;; ------------------------------------------------------------
  78.