;;;     Partially funded by NSF grant number NSF-DUE CCLI 9952398      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Copyright © 2000 This program (MuLE and associated 
;interpreters/utilities) is free software;
;you can redistribute it and/or modify it under the 
;terms of the GNU General Public License as
;published by the Free Software Foundation; either 
;version 2 of the License, or any later version. 
;
;This program is distributed in the hope that it 
;will be useful, but WITHOUT ANY WARRANTY;
;without even the implied warranty of MERCHANTABILITY 
;or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details. 
;
;You should have received a copy of the GNU General 
;Public License along with this program; 
;if not, write to the Free Software Foundation, 
;Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;
;To view the full text of the GNU General Public License, see
;http://mathcs.holycross.edu/~mule/gpl.html
;
;We may be contacted at:
;John Barr      barr@ithaca.edu          (607) 274-3579
;Laurie King    la@cs.holycross.edu      (508) 793-2248
;

;;; MzScheme macros implementing records for the book:
;;;
;;; "Essentials of Programming Languages", Daniel P. Friedman,
;;;   Mitchell Wand and Christopher T. Haynes, MIT Press, 1992.
;;;
;;; Code modified January 15, 1998 by Matthias Felleisen
;;; 1) every? replaced by andmap to avoid namespace problems
;;;    andmap is a standard Scheme routine
;;; 2) define-record simplified with h/o function and in-lining
;;; 3) variant-case simplified  by in-lining and renaming
;;; 4) added test code (see end of file)
;;;
;;; Three changes 2000-02-03 Max Hailperin <max@gac.edu>:
;;; 1) Put the (print-struct #t) at the top of the file,
;;;    which causes records (i.e., structs) to be printed
;;;    out more or less the way shown in the EOPL book,
;;;    rather than opaquely w/ just the type visible.
;;;    For more compact output, you can always do
;;;    (print-struct #f).
;;; 2) Silenced the test stuff at the end, which was
;;;    always printing something out, at least the string.
;;; 3) Silenced define-record (made it return void rather than
;;;    the record name) by analogy w/ define.
;;;
;;; (variant-case code Based on code of David McCusker, Copyrighted in 1993)
;;; Code created October 21, 1997 by Dan Friedman.

(require (lib "class-old.ss"))
(require (lib "class.ss"))
(require (lib "class100.ss"))

;;; For behavioral specification see tests at end of file. 

(print-struct #t)

(define-macro define-record 
  (lambda (rec-name rec-fields)
    (let ((translate
            (lambda (token)
              (lambda (rec-name f)
                (string->symbol
                  (string-append
                    (symbol->string rec-name) token (symbol->string f)))))))
      `(begin
         ,@(append
             (list (list 'define-struct rec-name rec-fields))
             (map (lambda (f)
                    (list 'define
                      ((translate "->") rec-name f)
                      ((translate "-")  rec-name f)))
                  rec-fields)
             '((void)))))))

(define-macro variant-case
  (lambda (record-exp . clauses)
    (let*
      (;; -- silly abbreviations
       (sym string->symbol)
       (str symbol->string)
       (cat string-append)
       ;; -- real stuff
       (exp (gensym))
       (make-clause
         (lambda (c)
           (let* ((name (str (car c)))
                  (n-f (lambda (f) (list f (list (sym (cat name "-" (str f))) exp)))))
             (if (eq? 'else (car c))
                 c
                 (list (list (sym (cat name "?")) exp)
                       (cons 'let (cons (map n-f (cadr c)) (cddr c)))))))))
      (for-each
        (lambda (c)
          (unless (and (pair? c)
                    (or (eq? 'else (car c))
                        (and (symbol? (car c))
                          (pair? (cdr c))
                          (list? (cadr c))
                          (andmap symbol? (cadr c)))))
            (error "variant-case: expected (name fields* ...); given: ~s" c)))
        clauses)
      `(let ((,exp ,record-exp))
         (cond
           ,@(map make-clause clauses))))))

(begin  
  ; in addition to moving the quote, you need to take the (begin ... (void)) out -max
  "Tests:
In DrScheme, should see same values in repl. Otherwise run and compare. 
To test: remove quotes at end of file and put one right here ->

(define-record bar (x))
'bar
(define-record foo (man chu))
'foo
(display
  (variant-case (make-bar 2)
    (foo (man chu) (cons man chu))
    (bar (x) x)
    (else (list 1))))
= 2
(display
  (variant-case (make-foo 1 2)
    (foo (man chu) (cons man chu))
    (bar (x) x)
    (else (list 1))))
= '(1 . 2)
(display 
  (variant-case 'go
    (foo (man chu) (cons man chu))
    (bar (x) x)
    (else (list 1))))
'(1)
"
  (void))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  End of Variant Record macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  This version is integrating get_next_expression.  Uses John's code.
;;;   Only works for the interpreter window, does not work for the editor window.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  muleFrame.  This is the window class.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define muleFrame%
  (class100 frame% (newInterp theTitle)
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;  Private variables
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (private-field
      (theInterp newInterp)
      ;;; variable that determines the number of lines to read from the interpreter window
      (numLinesToRead  1)
      ;;; Right - this is a global variable used in get next expression
      ;;;  we just initialize it.
      ;;;
      (next-line "")
      ;;;
      ;;;   list of the keywords recognized by every interpreter.  Better not
      ;;;    try to use this as part of the language syntax.
      ;;;
      (KEYWORD '(list exit help))
      
      (getEdCanvas (lambda ()
                     (letrec ((childWin (send this get-children))
                              (getLast
                               (lambda (lst)
                                 (if (eq? (cdr lst) '())
                                     (car lst) 
                                     (getLast (cdr lst)))))
                           )
                       (getLast childWin)))
                 )
      (getTextEd1 (lambda ()
                     (letrec ((childWin (send this get-children))
                              (getLast
                               (lambda (lst)
                                 (if (eq? (cddr lst) '())
                                     (send (car lst)  get-editor)
                                     (getLast (cdr lst)))))
                           ) 
                       (getLast childWin)))
                 )
       (getTextEd2 (lambda ()
                     (letrec ((childWin (send this get-children))
                              (getLast
                               (lambda (lst)
                                 (if (eq? (cdr lst) '())
                                     (send (car lst)  get-editor)
                                     (getLast (cdr lst)))))
                           )
                       (getLast childWin)))
                 )
       
       (getMessBox (lambda ()
                     (letrec ((childWin (send this get-children))
                              (getLast
                               (lambda (lst)
                                 (if (eq? (cdddr lst) '())
                                     (send (car lst)  get-editor)
                                     (getLast (cdr lst)))))
                           )
                       (getLast childWin)))
                 )
      ) ;;; end private instance variable declarations.
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;  public variables and functions
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (public
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;  writeCaret
      ;;;
      ;;;  This function used to initialize the caret in the interpreter window.
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      
      (writeCaret (lambda ()
                    ;;; put the caret into the interpreter window
                    (send (getTextEd2) insert "> ")
                    (send (getTextEd2) set-caret-owner #f 'global)
                    ))
      
                      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;  writeln 
      ;;;
      ;;;  This function writes to the text window
      ;;;  Precondition:  none
      ;;;  Postcondition:  expr is writen to the interpreter window
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      
      (writeln  (lambda (expr)
                      ;;; getLast (local private function) returns the text editor of the
                       ;;; last item in this frame which is an editor-canvas.
                       ;;; We want to send the insert message to this text editor
                  (letrec ( (theEd (getTextEd2))
                            (writeList
                             (lambda (lst)
                               (send theEd insert " ")
                               (cond 
                                 ((null? lst) '())
                                 ((list? (car lst))
                                  (begin
                                    ;;; if we have a list of lists, we'll print
                                    ;;; out the inside list in parenthesis
                                    (send theEd insert "(")
                                    (writeList (car lst))
                                    (send theEd insert ")")
                                    (writeList (cdr lst))))
                                 ((number? (car lst))
                                  (begin
                                    (send theEd insert (number->string (car lst)))
                                    (writeList (cdr lst))))
                                ((string? (car lst))
                                  (begin
                                    (send theEd insert (car lst)))
                                  (writeList (cdr lst)))
                                ((char? (car lst))
                                  (begin
                                    (send theEd insert (string (car lst)))
                                    (writeList (cdr lst))))
                                ((symbol? (car lst))
                                  (begin
                                    (send theEd insert (symbol->string (car lst)))
                                    (writeList (cdr lst))))
                                (else
                                 (send theEd insert "record"))
                                )))  ;;;  end writeList
                                   )  ;;;  end letRec definitions
                       (if  (not (null? theEd))  
                            (begin
                              ;;; Here I'm setting the position of the cursor
                              ;;; to be the last position of the last line in
                              ;;; the window.  I don't think that I need to do this!
                              ;;; When writeln is called, the cursor should already
                              ;;; be in the last position.
                              ;;;(send (getTextEd2) set-position 
                              ;;;      (send (getTextEd2) last-position)
                              ;;;      'same #f #t 'default)
                              (send theEd insert (string #\return))
                              (cond  
                                ((number? expr)
                                 (send theEd insert (number->string expr)))
                                ((string? expr)
                                 (send theEd insert expr))
                                ((char? expr)
                                 (send theEd insert (string expr)))
                                ((symbol? expr)
                                 (send theEd insert (symbol->string expr)))
                                ((boolean? expr)
                                 (if expr
                                 (send theEd insert "true")
                                 (send theEd insert "false")))
                                ((list? expr)
                                 ;;; if we have a list, print the opening and
                                 ;;; closing parenthesis also
                                 (send theEd insert "(")
                                 (writeList expr)
                                 (send theEd insert ")"))
                                (else (send theEd insert "record type")))
                              (send theEd insert (string #\return))
                           )
                           )
                       )))  ;;; end writeln
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;; This function looks to see if an expression contains the error string  "*#@*"
      ;;; receives a variable number of parameters.
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      (containString
       (lambda (expr)
         ;;; debug
         (cond
           ((null? expr) #f)
           ((symbol? expr) 
            (if (string=? (symbol->string expr)  "*#@*")
                #t
                #f))
           ((list? expr)
            (if (list? (car expr))
                ;;; the first item is a list
                  (or (containString (car expr)) (containString (cdr expr)))
                  ;;; the first item is not a list.  We're only interested if
                  ;;; it is the terminal string.
                  (if (or (and (string? (car expr)) (string=? (car expr)  "*#@*"))
                          (containString (cdr expr)))
                      #t
                      #f)))
           ((and (string? expr) (string=? expr  "*#@*")) #t)
           (else #t))
         ))
                  
      
      


;;;  The procedure "flush" resets the variable next-line.  This variable
;;;  contains the input from the last line entered.  If there is a error
;;;  in the input stream, an error message is printed and the input flushed
;;;  by calling this procedure.

(flush
  (lambda ()
    (set! next-line "")))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  This deletes the last item in a list.  I put this in here in case
;;;  it's needed for SPOC.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(delete-last
  (lambda (lst)
    (if (or (not (pair? lst)) 
            (null? lst)
            (null? (cdr lst)))
        '()
        (cons (car lst) (delete-last (cdr lst))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  eats white-space.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(delete-white
  (lambda (str pos)
    (if (>= pos (string-length str))
        ""
        (if (not (char-whiteSpace? (string-ref str pos)))
            (substring str pos (string-length str))
            (delete-white str (add1 pos))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  OVERVIEW:  read-word and get-next-expression are the workhorse procedures 
;;;    for reading input from windows.  We needed to roll our own so we can handle
;;;    both reading from the transcript window and a text window.  A little messy 
;;;    since we went for a pure functional style instead of using "iterative"
;;;    constructs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  is-comment
;;;
;;;  This function tests a given input string to see if it begins with two forward 
;;;  slashes (ie. "//")
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(is-comment
    (lambda theLine
      (if (and (char=? (string-ref (car theLine) 0) #\/)
               (char=? (string-ref (car theLine) 1) #\/))
          #t
          #f
          )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  read-all-lines
;;;
;;;  This function is called by the call-back function that recognizes a return in the interpreter
;;;  window.  It gets all of the lines indicated by the parameter getLines.  getLines is the
;;;  number of lines that the user has entered in the interpreter window without making a complete
;;;  expression.  It is incremented in read-word when get_next_expression asks for another token
;;;  but there are none left from the input lines.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (read-all-lines
              (lambda (getLines theEd)
                ;;; numLinesToRead is a class instance variable.  Initialized to 1.
                ;;; gives the number of lines in the text window that need to be read.
                ;;;  read-it will increment this variable if completes reading all the
                ;;;  tokens on the input line(s) and get_next_expression asks for another
                ;;;  token.  getLines is initialized to the value of numLinesToRead.
                (if (= getLines 1)
                    ;;; there is only one line left to read.
                    (send theEd get-text
                          ;;; get the start position of this line.
                          (send theEd line-start-position
                                (send theEd last-line) #f)
                          'eof #f #f)
                    ;;; otherwise get next line.  Append the next line with a space and then with
                    ;;; all the other lines indicated by getLines.
                    (let ( (nextLine (send theEd get-text
                           ;;; The get-text message needs a start and ending position.
                          ;;; get the start position of this line.
                          (send theEd line-start-position
                                ;;; must determine which line we're getting
                                (- (send theEd last-line) (- getLines 1)) #f)
                          ;;;  Now get the end position of this line.  
                          (send theEd line-end-position
                                (- (send theEd last-line) (- getLines 1)) #f)
                          
                          #f #f)
                                     )
                           )
                      (if (not (is-comment nextLine))
                          (string-append nextLine " " 
                                         (read-all-lines (- getLines 1) theEd))
                          (read-all-lines (- getLines 1) theEd))
                      ) ;;; end the let which is the else part of if (= getLines 1)
                    )))
             ;;; end function read-all-lines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  read-word
;;;
;;;  This function is defined in Mule.s as read-word and is redefined 
;;;  here.  Returns tokens, where white-space is the separator.  This is used a
;;;  by get-next-expression.  Has some complications because it takes a window as
;;;  a parameter.  If this is null, the transcript window is assumed.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(read-word
  (lambda ()
    (letrec (
           
             ;;;  Internal function read-it
              (read-it
               (lambda (pos rslt)
                  (if (>= pos (string-length next-line))
                     ;;; have discovered the end of line
                     (if
                       (equal? rslt "")
                           ;;; if true, there are no more words in the input lines
                           ;;; Then return the error string, since get_next_expression 
                           ;;; wants another token.  Increment numLinesToRead since we
                           ;;; will not be processing the current line(s).
                           (begin
                             (set! numLinesToRead (+ 1 numLinesToRead))
                             ;;;  write a return to the window so the user can enter the
                             ;;;  rest of the expression.  Can't call writeln cuz that function
                             ;;;  enters a return before and after the text sent.  here we only
                             ;;;  want a single return.
                              (send (getTextEd2) insert (string #\return))
                             ;;;  next line in the interactive window.
                              (begin
                             "*#@*" 
                             )
                             )
                           ;;;  else discovered the last word in the line.
                           ;;;  reset next-line and return the result.
                           (begin 
                             (set! next-line "")
                             (if (string->number rslt)
                                 (string->number rslt)
                                 (string->symbol rslt)
                             )))
                     ;;;  else we have not reached the end of the line.
                     ;;;  Check next character for whitespace or ")" or ";"
                     ;;;  The ")" and ";" are delimiters in different langauges
                     (if (char-whiteSpace? (string-ref next-line pos))
                         (begin
                           (set! next-line (delete-white next-line pos))
                           (if (equal? rslt "")
                               (read-it pos rslt)
                               (if (string->number rslt)
                                   (string->number rslt)
                                   (string->symbol rslt))))
                         ;;; Else check for a string character
                         (if (equal? (string-ref "\"" 0) (string-ref next-line pos))
                             (begin
                               (set! next-line (substring next-line (add1 pos) 
                                                          (string-length next-line)))
                               (string->symbol "\""))
                             ;;; check for semicolon delimiter
                             (if (equal? (string-ref ";" 0) (string-ref next-line pos))
                                 (if (equal? rslt "")
                                     ;;; no token has yet been identified
                                     (begin
                                       (set! next-line (substring next-line (add1 pos) 
                                                          (string-length next-line)))
                                       (string->symbol ";"))
                                     ;;; else we have recognized a token before the semicolon.
                                     (begin
                                       (set! next-line (substring next-line pos 
                                                          (string-length next-line)))
                                       (if (string->number rslt)
                                           (string->number rslt)
                                           (string->symbol rslt)))
                                     )
                                 ;;; else check for an opening paren
                                 (if (equal? (string-ref "(" 0) (string-ref next-line pos))
                                     ;;; found an opening paren
                                     (begin
                                       (set! next-line (substring next-line (add1 pos)
                                                                  (string-length next-line)))
                                       (string->symbol "("))
                                     ;;; else check for a closing paren
                                     (if (equal? (string-ref ")" 0) (string-ref next-line pos))
                                         ;;; found a closing paren with nothing before it
                                         (if (equal? rslt "")
                                             (begin
                                               (set! next-line (substring next-line (add1 pos)
                                                                          (string-length next-line)))
                                               (string->symbol ")"))
                                             ;;; else there is a symbol before the closing paren
                                             (begin
                                               (set! next-line (substring next-line pos 
                                                                          (string-length next-line)))
                                               (if (string->number rslt)
                                                   (string->number rslt)
                                                   (string->symbol rslt))))
                                         ;;; else found a character for a symbol
                                         (begin                                           
                                           (read-it (add1 pos)
                                                    (string-append rslt (substring next-line pos (add1 pos)))))
                                         ))))))))
             )
      
      (read-it 0 "")))) 
;;;;;;;;;;;;;;;;;;;;;;;;;;  end function read-word ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  get_next_expression
;;;
;;;  This function calls read-word to get tokens.  The main reason for get-next-expression is
;;;  to "package" the tokens in the form of a Scheme expression.  Since the 
;;;  user/language module parsers are written in Scheme as well, this simplifies 
;;;  the parsers since they can use the built-in Scheme operators to manipulate the
;;;  expression.  So the expressions returned are Scheme lists which one can manipulate
;;;  using car, cdr, etc... instead of strings/characters which would force the parsers
;;;  to do ugly things with string operations.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(get_next_expression 
                 (lambda ()
                  (letrec (
                         (temp (read-word))
                         (get-expr (lambda (num next)
                                     ;;; In get-expr.  Must have found an opening parenthesis,
                                     ;;;  so now we complete the expression until find closing
                                     ;;;  parenthesis at same level.
                                       (cond
                                         ;;; find closing paren, return null
                                         ;;; check to see if "next" is a number first because
                                         ;;; cannot so symbol->string for a number
                                         ((and (not (number? next)) 
                                               (string=? (symbol->string next) ")" ))
                                          '()  ) 
                                         ;;; otherwise, must read next token and recurse
                                         (else
                                          (let ( (nextWord (read-word))
                                                 )
                                             (if (and (string? nextWord) 
                                                     (string=? nextWord "*#@*"))
                                                ;;; in this case, read-word ran out of lines
                                                ;;; so we return and wait for another line
                                                (begin

                                                  (list nextWord))
                                                ;;; else we check to see what nextWord was
                                                ;;; and recurse
                                                (cond
                                                  ((number? next)
                                                   (append (list next)
                                                           (get-expr num nextWord)))
                                                  ((string=? (symbol->string next) "(" )
                                                   (let (
                                                         (temp (list (get-expr (add1 num)
                                                                       nextWord)))
                                                         )
                                            ;;; if num is 0 then we have completed the top 
                                            ;;; level
                                            ;;; OW we must finish the nesting
                                                     (if (= num 0)
                                                         temp
                                                         ;;; else must get the next word and
                                                         ;;; check to see if read-word ran out
                                                         ;;; of tokens.  
                                                         (let ( (nextWord (read-word))
                                                                )
                                                           (if (and (string? nextWord) 
                                                                    (string=? nextWord "*#@*"))
                                                               ;;; read-word ran out of tokens, so
                                                               ;;; return the error code.
                                                               (list nextWord)
                                                               ;;; read-word got a token, continue
                                                               (append temp (get-expr num 
                                                                                nextWord)))))))
                                                  
                                                  (else (append (list next)
                                                                (get-expr num nextWord)))
                                                  )))))))                                                        
                          )
                    
                    (cond
                      ((number? temp) temp)
                      ((string? temp) temp)
                      (else 
                         (if (not (string=? (symbol->string temp) "(" ))
                            temp
                            ;;; Must take car since first "(" sent creates a list but last
                            ;;; ")" found starts a list, thus get two lists out of the first
                            ;;; level of parenthesis
                            (car (get-expr 0 temp)))))
                        )))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;New Functions Christian added;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      
      
      
      
      ;;this function is called when the execute button is pressed
      ;; it sets the value of num lines to read and fills nex-line
      ;;then it calls the get-next-expression loop which is defined below
      (please-let-this-button-work
       (lambda ()
                                 ;;;first need to set numLines to read to the 
                                 ;;;number of lines of code in the upper window
                                 ;;;last-line returns number of last line but
                                 ;;;lines are numbered starting with 0 so add 1
                                                        
                                 
                              (set! numLinesToRead (+(send (getTextEd1) last-line)1))
                               ;;;john's code I copied, I hope this works
                               
                                    (set! next-line (read-all-lines numLinesToRead (getTextEd1)))
                                    (get-next-expression-loop)
        )
      )
      
      ;;this function calls get-next-expression repeatedly until next-line has
      ;;no more complete expressions in it.
      (get-next-expression-loop
       (lambda ()
         (let ( (nextExpr (get_next_expression)))
                                      ;;;  The function containString checks to see if nextExpr
                                      ;;;  contains the error string that indicates that a complete
                                      ;;;  expression was not found.
                                      
                                      ;;; Problem:  if nextExpr contains the error string "*#@*"
                                      ;;; it may not be a comlete expression, ie it may be
                                      ;;; (+ x (* y "*#@*".  The default behavior of containString
                                      ;;; is to return #t, so incomplete expressions are assumed
                                      ;;; to be error strings.
                                    (if (not (containString nextExpr)) 
                                          ;;;  reset the number of lines to read since we found a good expression
                                          (begin
                                          
                                          ;(set! numLinesToRead 1)
                                          (theInterp nextExpr this)
                                          (get-next-expression-loop))
                                        ;;; else do nothing
                                        ))
         )
       )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;end of my new functions;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         



)   ;;; end public instance variables
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;; Overridden functions from parent classes
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    (override
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;  on-subwindow-char
      ;;;   catches a keyboard event.  We're looking for the return character in the interpreter
      ;;;   window.  Then we get the expression from the window by calling get_next_expression.
      ;;;   If get_next_expression  cannot create a complete expression, it returns the special
      ;;;   string "*#@*".  We call function containString to determine if the result contains
      ;;;   this string.  If it does, we do nothing.  Read-word will have allready incremented
      ;;;   the global variable numLinesToRead.  If the error string is not present, we send the
      ;;;   expression to the interpreter.
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      (on-subwindow-char (lambda (theWin theKeyEvent)
                          (if (equal? (send theKeyEvent get-key-code) '#\return)
                              (if (equal? theWin (getEdCanvas))
                                  ;;; numLinesToRead is a class instance variable.  Initialized to 1.
                                  ;;; gives the number of lines in the text window that need to 
                                  ;;;  be read.  read-it will increment this variable if completes
                                  ;;;  reading all the tokens on the input line(s) and
                                  ;;;  get_next_expression asks for another token.  read-all-lines
                                  ;;; will initialize a global private variable to the concatenation
                                  ;;; of the last numLinesToRead lines of the interpreter window.
                                  (begin
                                    (set! next-line (read-all-lines numLinesToRead (getTextEd2)))
                                    (if (and (not (string=? next-line ""))
                                             (eq? (string-ref next-line 0) #\>))
                                        (set! next-line (substring next-line 1 (string-length next-line)))
                                        )
                                    ;;;  debug writeln
;                                    (writeMess "number of lines to read: ")
;                                    (writeMess numLinesToRead)
;                                    (writeMess "on-subwindow-char, next line is:")
;                                    (writeMess next-line)
;                                    (writeMess "next-line[0]:  ")
;                                    (writeMess (string-ref next-line 0))
                                    ; (writeMess "last line is")
                                    ; (writeMess (send (getTextEd2) last-line))
                                    (let ( (nextExpr (get_next_expression))
                                         )
                                      ;;;  Debug writeln
                                      ;;;(writeMess "on-subwindow-char, nextExpr is:")
                                      ;;;(writeMess nextExpr)
                                      ;;;  The function containString checks to see if nextExpr
                                      ;;;  contains the error string that indicates that a complete
                                      ;;;  expression was not found.
                                      
                                      ;;; Problem:  if nextExpr contains the error string "*#@*"
                                      ;;; it may not be a comlete expression, ie it may be
                                      ;;; (+ x (* y "*#@*".  The default behavior of containString
                                      ;;; is to return #t, so incomplete expressions are assumed
                                      ;;; to be error strings.
                                    (if (not (containString nextExpr)) 
                                          ;;;  reset the number of lines to read since we found a good expression
                                          (begin
                                          
                                          (set! numLinesToRead 1)
                                          (theInterp nextExpr this)
                                          ;;; can't call writeln to print ">" since it will also
                                          ;;; write a blank line.
                                          (send (getTextEd2) insert "> "))
                                        ;;; else do nothing
                                        )))
                                  #f)
                              #f)))
      
       
      
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;  on-subwindow-event.
      ;;;    traps mouse events to the buttons.  Probably won't use in the final edition.
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      (on-subwindow-event (lambda (theWin theMouseEvent)
                          (if (send theMouseEvent button-down?)
                              (if (equal? (send theWin get-plain-label) "Execute")
                                  ;;;  Have to call framePrint explicitly because
                                  ;;;  the interpreter is defind externally and can't
                                  ;;;  see framePrint.  The function getTextEd2 returns the
                                  ;;;  editor canvas in the top editor
                                  (begin
                                    (please-let-this-button-work)
                                    (set! numLinesToRead 1)
                                    ;;; can't call writeln to print ">" since it will also
                                    ;;; write a blank line.
                                    (send (getTextEd2) insert "> ")
                                    (send (getTextEd2) set-caret-owner #f 'global)
                                    ) ;;; end begin
                                  #f)
                              #f)))  ;;; end of on-subwindow-event
      )
    (sequence
      
      (super-init theTitle #f 450 500)

      )))  ;;; end muleFrame

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  end muleFrame.  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  make-Mule-Win.  This creates an instance of a muleFrame.
;;;
;;;      input:  an interpreter that receives two parameters, an expression and a muleFrame
;;;              object.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define make-Mule-Win
  (lambda (interp title)
    (letrec (

;;; our Mule window for input/output
             (muleFrame (make-object muleFrame% interp title))



 ;;; create a panel with buttons: evaluate, save, load.
             (panel1 (make-object horizontal-panel% muleFrame '(border))) 
             
             ;;;(panel1 (make-object horizontal-panel% muleFrame))
             
             ;;;this button will execute the code in the upper window
             ;;;when pushed 
             (execButton (make-object button% "Execute" panel1 void))
             ;;; add instead of void if you want a call back function 
             ;;; associated with the button
                           ;(lambda (No precedence vs. Normal Precedence button event)(send muleFrame please-let-this-button-work)
                           ;  )))
                           
                                       
             ;(saveButton (make-object button% "Save" panel1 void))
             ;(openButton (make-object button% "Open" panel1 void))
                  
;;; create a canvas with a text editor (this is the editing portion)
             (canvas1 (make-object editor-canvas% muleFrame))
             (text1 (make-object text%))
             
             ;;;
             ;;;Here's what I added, having the "" makes it so that you get promted for the file name
             ;;;
             
             (saveButton (make-object button% "Save" panel1 
                           (lambda (button event)(send text1 save-file "" 'text #t))))
             
             (openButton (make-object button% "Open" panel1
                           (lambda (button event)(send text1 load-file "" 'text #t))))
      
             
;;; create a canvas with a text editor (this is the evaluation portion)
             (canvas2 (make-object editor-canvas% muleFrame))
             (text2 (make-object text% ))
             
;;;  create a menu bar
             (mb (make-object menu-bar% muleFrame))
             (m-edit (make-object menu% "Edit" mb))
             (m-font (make-object menu% "Font" mb))
           
             )
      
      ;;; set the panel position 
      (send panel1 set-alignment 'center 'top)
      (send panel1 stretchable-height #f)
      ;;; now give the test frame a status bar
      (send muleFrame create-status-line)
      ;;; associate the editors with the canvases.
      (send canvas1 set-editor text1)
      (send canvas2 set-editor text2)
      ;;;  put the new menus in the menu bar
      (append-editor-operation-menu-items m-edit)
      (append-editor-font-menu-items m-font)

      ;;; give the interpreter window the initial focus
      (send muleFrame writeCaret)
      ;;; now test the editor
      (send muleFrame show #t)
    
    )))
      
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Global functions, variables, constants, and structures.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   Map2 
;;;    is a simple extension of the built in map procedure to two 
;;;   arguments.  The procedure is applied to the corresponding args
;;;   in the first list and the second list is used as the second argument.
;;;   Note that lst2 is always used as is, i.e., it is never changed!
;;;   This function is a global variable since it must be used in the interpreter.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define map2
  (lambda (proc lst1 lst2)
    (if (null? lst1)
        '()
        (cons (proc (car lst1) lst2) (map2 proc (cdr lst1) lst2)))))


      ;;;  These definitions create the structures that are used in the interpreters
      ;;;  to store the parse tree information.
      


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Same thing as for-each except the procedure takes two arguments,
;;; a window and then an operand.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define for-each-2
  (lambda (proc win ls)
    (if (not (null? ls))
        (begin 
          (send win writeln (car ls))
          (for-each-2 proc win (cdr ls))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  writeln  A simple helper function for performing debug writes.  Prints all of its args
;;;  and then writes a newline.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define writeln
  (lambda lst
    (letrec ( (writeHelp 
               (lambda (lst)
                 (if (null? lst)
                     (newline)
                     (begin
                       (display (car lst))
                       (display " ")
                       (writeHelp (cdr lst))
                       )
                     )
                 )))
      (writeHelp lst))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Structures for use in the interpreters.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-record IF (test-exp then-exp else-exp))
(define-record PROC (formals body))
(define-record CLOSURE (formals body))
(define-record PRIM-PROC (prim-op))
(define-record APPLY (opr opnds))
(define-record NUM (val))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;   list of the keywords recognized by every interpreter.  Better not
;;;    try to use this as part of the language syntax.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define KEYWORD '(list exit help clear))

(define PRIMOP '(+ - * /))
;;; These are general use
(define-record ID (name))
(define-record BIND (var exp))
(define-record LST ())
(define-record EXIT ())
(define-record STR (name))
(define-record HELP ())
(define-record CLEAR ())
(define-record ERR (msg exp))
 
(define prim-op? (lambda (item)
                             (member item '(+ - * / = != > < and or not))))
(define-record sbind (var exp vtype))

(define parse (lambda (datum)
                          (cond 
                            ((member datum KEYWORD)
                             (cond
                               ((equal? datum 'list) (make-lst))
                               ((equal? datum 'help) (make-help))
                               ((equal? datum 'clear) (make-clear))
                               ))
                            ((number? datum) (make-num datum))
                            ((prim-op? datum) (make-prim-proc datum))  
                            ((and (symbol? datum) 
                                  (not (member datum KEYWORD))
                                  (not (prim-op? datum)))
                             (make-id datum))
                            ((pair? datum)
                             (cond 
                               ((eq? (car datum) 'proc)          
                        
                                (make-proc (cadr datum) (parse (caddr datum)) ))
                               
                               ((eq? (car datum) 'assign)
                                (make-sbind (cadr datum) (parse (caddr datum) ) 'untyped))
                               ((eq? (car datum) 'if)
                                (let ( (then-exp (cadddr datum))
                                       (else-exp (cadddr (cddr datum)))
                                       )
                                  ;;; do some error checking
;                                  (if (not (and (eq? (caddr datum) 'then)
;                                                (eq? (caddr (cddr datum)) 
;                                                     'else))) 
;                                      (make-error "not a valid if expr" datum)
;                                      (make-if (parse (cadr datum) ) (parse then-exp ) (parse else-exp )))
                                  (cond
                                    ((not (and (eq? (caddr datum) 'then)
                                                (eq? (caddr (cddr datum)) 
                                                     'else)))
                                     (make-error "not a valid if expr" datum))
                                     (else
                                  (make-if (parse (cadr datum) ) (parse then-exp ) (parse else-exp ))))
                                  ))
                               (else  
                                  (make-apply (parse (car datum) )
                                            (map parse (cdr datum) ))))
                             ) ;;; end (pair? datum) condition
                            
                            (else 
                             (begin
                               (display " ")
                               (display "parse:  Invalid concrete syntax")
                               (display datum)
                               
                               ;;; flush tells the window that we have an error and want to dump the line
                               (newline))))))