home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / prims.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  7.1 KB  |  219 lines
  1. ;-*- mode:lisp; package: Boxer;Base:10.; fonts: cptfont, cptfontb -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15.  
  16. ;; some primitives for the new evaluator
  17.  
  18. ;; control primitives 
  19.  
  20. (DEFBOXER-FUNCTION REPEAT (TIMES (LIST-REST STUFF))
  21.   (*CATCH 'REPEAT
  22.     (DOTIMES (I (NUMBERIZE TIMES))
  23.       (EV-THING STUFF))))
  24.  
  25. (DEFBOXER-FUNCTION REPEATX (TIMES STUFF)
  26.   (*CATCH 'REPEAT
  27.     (DOTIMES (I (NUMBERIZE TIMES))
  28.       (EVAL-BOX-ROWS STUFF))))
  29.  
  30. (DEFBOXER-FUNCTION STOP ()
  31.   (*THROW 'REPEAT :NOPRINT))
  32.  
  33. (DEFBOXER-FUNCTION RETURN (VALUE)
  34.   (*THROW 'REPEAT VALUE))
  35.  
  36. (DEFBOXER-FUNCTION IF (PRED (DATAFY THEN) (LIST-REST ELSE)) 
  37.   (IF (TRUE? PRED) (EVAL-BOX-ROWS THEN) (EV-THING ELSE)))
  38.  
  39. (DEFBOXER-FUNCTION IFS ((DATAFY BOX))
  40.   (LET ((ROWS (GET-BOX-ROWS-FOR-EVAL (CAR (GET-FIRST-ROW BOX)))))
  41.     (DOLIST (ROW ROWS)
  42.       (MULTIPLE-VALUE-BIND (PRED REST)
  43.       (RETURN-VALUE ROW)
  44.     (COND ((TRUE? PRED)
  45.            (RETURN (EV-EXPRESSION REST)))
  46.           ((NOT (FALSE? PRED))
  47.            (FERROR "The Predicate ~S, was neither TRUE nor FALSE" PRED)))))))
  48.  
  49. (DEFBOXER-FUNCTION RUN (BOX)
  50.   (EVAL-BOX-ROWS BOX))
  51.  
  52. (DEFBOXER-FUNCTION PORT-TO ((PORTIFY BOX))
  53.   BOX)
  54.  
  55. ;;; this still needs to hack top level !'s
  56. (DEFBOXER-FUNCTION TELL ((PORT-TO WHO) (LIST-REST WHAT))
  57.   (WITH-STATIC-ROOT-BOUND (GET-LEXICAL-ROOT WHO)
  58.     (if (evbox? *boxer-static-variables-root*)
  59.     (ferror "You can't do TELL on the result of a Boxer computation until 1//1//88.")
  60.     (EV-THING WHAT))))
  61.  
  62. (DEFBOXER-FUNCTION TELL-ALL ((PORT-TO WHOS) (LIST-REST WHAT))
  63.   (LOOP FOR WHO IN (MAPCAR #'(LAMBDA (X) (EV-THING X '(PORTIFY DONT-IGNORE)))
  64.                (SUBSET #'(LAMBDA (B) (AND (OR (EVAL-BOX? B) (EVAL-PORT? B))
  65.                               (NOT (LL-BOX? B))))
  66.                    (IF (EVAL-PORT? WHOS)
  67.                        (get-box-elements (get-port-target whos))
  68.                        (get-box-elements whos))))
  69.     DO  (WITH-STATIC-ROOT-BOUND (GET-LEXICAL-ROOT WHO)
  70.           (EV-THING WHAT))))
  71.  
  72. ;;; call the debugger from 1BOXER
  73. 0(DEFBOXER-FUNCTION LISPM-ERROR () (FSIGNAL "Boxer Error"))
  74.  
  75. ;;; call the redisplay from 1BOXER0. This should be provided for somehow but right now it is
  76. ;;; just too expensive to call the redisplay automatically in order to pick up intermediate
  77. ;;; results of mutations
  78. (DEFBOXER-FUNCTION REDISPLAY REDISPLAY)
  79.  
  80.  
  81.  
  82. (DEFBOXER-FUNCTION EXPORT-ALL ((PORTIFY BOX))
  83.   (TELL (GET-PORT-TARGET BOX) :EXPORT-ALL-VARIABLES)
  84.   ':NOPRINT)
  85.  
  86.  
  87.  
  88. ;;; I/O
  89.  
  90. (DEFBOXER-FUNCTION GET-INPUT ((LIST-REST PROMPT))
  91.   (GET-BOXER-INPUT PROMPT))
  92.  
  93. ;; file sys
  94.  
  95. (DEFBOXER-FUNCTION READ ((PORTIFY BOX) (PORTIFY FILENAME))
  96.   (READ-FILE-INTO-BOX (GET-PORT-TARGET BOX) (TEXT-STRING (GET-PORT-TARGET FILENAME)))
  97.   :NOPRINT)
  98.  
  99. (DEFBOXER-FUNCTION SAVE ((PORTIFY BOX) (PORTIFY FILENAME))
  100.   (SAVE-BOX-INTO-FILE (GET-PORT-TARGET BOX) (TEXT-STRING (GET-PORT-TARGET FILENAME)))
  101.   :NOPRINT)
  102.  
  103. (DEFBOXER-FUNCTION SAVE-BOX-INTO-FILE ((PORTIFY BOX) (PORTIFY FILENAME))
  104.   (SAVE-BOX-INTO-FILE (GET-PORT-TARGET BOX) (TEXT-STRING (GET-PORT-TARGET FILENAME)))
  105.   :NOPRINT)
  106.  
  107. (DEFBOXER-FUNCTION READ-FILE-INTO-BOX ((PORTIFY BOX) (PORTIFY FILENAME))
  108.   (READ-FILE-INTO-BOX (GET-PORT-TARGET BOX) (TEXT-STRING (GET-PORT-TARGET FILENAME)))
  109.   :NOPRINT)
  110.  
  111. (DEFBOXER-FUNCTION SAVE-WORLD ((PORTIFY FILENAME))
  112.   (SAVE-BOX-INTO-FILE *INITIAL-BOX* (TEXT-STRING (GET-PORT-TARGET FILENAME)))
  113.   :NOPRINT)
  114.  
  115.  
  116.  
  117. (DEFUN PRINT-BOXER-PRIMITIVES (&optional (stream terminal-io))
  118.   (LET ((PACKAGE (PKG-FIND-PACKAGE "USER")))
  119.     (LOOP FOR FN IN *BOXER-FUNCTIONS*
  120.       DO (FORMAT stream "~% ~3T~s  ~15T--   ~:S" FN (BOXER-ARGLIST FN)))))
  121.  
  122.  
  123.  
  124.  
  125. ;(DEFBOXER-FUNCTION BU:MAKE (VARIABLE VALUE) (BOXER-MAKE VARIABLE VALUE) ':NOPRINT)
  126. ;(DEFBOXER-FUNCTION BU:SET (VARIABLE VALUE) (BOXER-SET VARIABLE VALUE) ':NOPRINT)
  127.  
  128. (DEFBOXER-FUNCTION BU:GET-KBD-CHAR ()
  129.   (STRING (TELL TERMINAL-IO :TYI)))
  130.  
  131. (DEFBOXER-FUNCTION BU:READCHARACTER ()
  132.     (STRING (TELL TERMINAL-IO :TYI)))
  133.  
  134. (DEFBOXER-FUNCTION BU:RC? ()
  135.   (BOXER-BOOLEAN (TELL TERMINAL-IO :LISTEN)))
  136.  
  137. (DEFBOXER-FUNCTION BU:RUN-KBD-CHAR ()
  138.   (HANDLE-BOXER-INPUT (TELL TERMINAL-IO :TYI)))
  139.  
  140. (DEFBOXER-FUNCTION BU:KBD-CHAR? ()
  141.   (TELL TERMINAL-IO :LISTEN))
  142.  
  143. (DEFBOXER-FUNCTION BU:GET-CHA-NO-WAIT ()
  144.   (LET ((CHA (TELL TERMINAL-IO :TYI-NO-HANG)))
  145.     (OR CHA (BOXER-BOOLEAN CHA))))
  146.  
  147. (DEFBOXER-FUNCTION BU:GENSYM () (GENSYM 'B))
  148.  
  149. (DEFBOXER-FUNCTION BU:PRINT (ignore) (ferror "Print doesn't work these days."))
  150.  
  151. (DEFBOXER-FUNCTION BU:BOX? (box) (boxer-boolean (EVAL-BOX? BOX)))
  152.  
  153. (DEFBOXER-FUNCTION BU:DOIT-BOX? (box) (boxer-boolean (EVAL-DOIT? BOX)))
  154.  
  155. (DEFBOXER-FUNCTION BU:DATA-BOX? (box) (boxer-boolean (EVAL-DATA? BOX)))
  156.  
  157.  
  158.  
  159. ;MISCELLANEOUS
  160.  
  161. (DEFBOXER-FUNCTION BU:HARDCOPY-BOX ((PORTIFY BOX))
  162.   (PBOX:HARDCOPY-BOX (BOX-OR-PORT-TARGET BOX)))
  163.  
  164. (DEFBOXER-FUNCTION WRITE-BOX-INTO-ZWEI-BUFFER ((PORTIFY BOX) ZWEI-BUFFER-NAME)
  165.   (WHEN (EVAL-PORT? BOX)
  166.     (ZWEI:WITH-EDITOR-STREAM
  167.       (OUT ':BUFFER-NAME (TEXT-STRING ZWEI-BUFFER-NAME) ':CREATE-P T)
  168.       (PBOX:PRINT-BOXES-FROM-STREAM-TO-STREAM (MAKE-BOXER-STREAM BOX) OUT
  169.                           72. 100. USER-ID
  170.                           (TELL (BOX-OR-PORT-TARGET BOX) :NAME)))))
  171.  
  172. (DEFBOXER-FUNCTION BEEP () (BEEP))
  173.  
  174. (DEFUN NUMBER-TO-STRING (NUMBER)            ;THIS CROCK
  175.     (FORMAT NIL "~D" NUMBER))
  176.  
  177. (DEFBOXER-FUNCTION POINT-BOX POINT-BOX)
  178.  
  179. (DEFBOXER-FUNCTION UPDATE-BOXER-SYSTEM ()
  180.   (LOAD-PATCHES 'BOXER :VERBOSE :NOSELECTIVE))
  181.  
  182. (DEFBOXER-FUNCTION DIRECTORY ((PORT-TO NAME))
  183.   (MAKE-BOX (MAPCAR #'(LAMBDA (F) (WHEN (CL:PATHNAMEP (CAR F))
  184.                     (NCONS (TELL (CAR F) :STRING-FOR-PRINTING))))
  185.             (FS:DIRECTORY-LIST
  186.               (fs:parse-pathname (TELL (GET-PORT-TARGET NAME) :TEXT-STRING))))))
  187.  
  188. (DEFBOXER-FUNCTION FIX-REGIONS ()
  189.   ;;first flush any regions that we might have
  190.   (DOLIST (R REGION-LIST)
  191.     (FLUSH-REGION R))
  192.   ;; now flush blinkers
  193.   (DOLIST (BL (TV:SHEET-BLINKER-LIST *BOXER-PANE*))
  194.     (WHEN (REGION-ROW-BLINKER? BL)
  195.       (SEND BL :SET-VISIBILITY NIL)
  196.       (SETF (TV:SHEET-BLINKER-LIST *BOXER-PANE*)
  197.         (DELQ BL (TV:SHEET-BLINKER-LIST *BOXER-PANE*))))))
  198.  
  199. (defboxer-function toggle-box-border-appearance ()
  200.   (cond ((string= "" (BOX-BORDERS-FN-TYPE-LABEL-STRING ':data-box))
  201.      (BOX-BORDERS-FN-SET-TYPE-LABEL-STRING ':data-box "Data")
  202.      (BOX-BORDERS-FN-SET-TYPE-LABEL-STRING ':doit-box ""))
  203.     (t
  204.      (BOX-BORDERS-FN-SET-TYPE-LABEL-STRING ':data-box "")
  205.      (BOX-BORDERS-FN-SET-TYPE-LABEL-STRING ':doit-box "Doit")))
  206.   (force-redisplay))
  207.  
  208.  
  209.  
  210. (defboxer-function doit->data ((list-rest line))
  211.      (let* ((thing (car line))
  212.             (new (copy-box (if (symbolp thing) (boxer-symeval thing) thing))))
  213.   (tell new :set-type ':data-box)
  214.       new))
  215.  
  216. (defboxer-function port-to-doit ((list-rest line))
  217.     (port-to-internal (if (symbolp (car line)) (boxer-symeval (car line)) (car line))))
  218.  
  219.