Semester Project, CSCI 4501 Spring 1995 Dr. Jaime Nino by George North Spring 1995 Programed with Scheme a functional language similar to LISP ; FETAL Interpreter, Part 1 -- Scanner ; ; Preconditions: none ; Postcondition: none ; ; Algorithm: ; 1. Scan the input stream, return valid tokens ; 1.1 LET is a reserved id, signals start of definitions ; 1.2 IN is a reserved id, signals start of expressions ; 2. Build environment trees from tokens between LET and IN ; 3. Build expressions trees for tokens after IN and until ; end of file, or another LET is encountered ; 4. Evaluate expressions print answers ;
; Function: fetal, start FETAL scanner ; Preconditions: none ; Postconditions: none ; ; fetal is the driver function for all of the Interpreter features ; ; use functions: scan - get the next token ; fetal_prompt - display user prompt ; fetal_rep - provides Read, Evaluate, Print LOOP ; (define fetal (lambda (input_file) (newline) (newline) (display "Welcome to FETAL (Fetal is an ") (display "Extremely Trivial Applicative Language)") (newline) (newline) (display "Enter a FETAL program, or type QUIT to exit") (newline) (newline) (fetal_prompt) (scan) (cond ( (equal? (token_in persistent) "debug") (set! debug #t) (scan) ) ) (fetal_rep) (newline) (newline) ) )
; Function: FETAL Read, Evaluate, Print LOOP ; Preconditions: persistent ; Postconditions: none ; ; use functions: scan - get the next token ; token_type_in - get token_type in persistent ; in_environment - build a FETAL environment table ; evaluate_expressions - calculate FETAL expressions ; (define (fetal_rep) (let ( (token_type (token_type_in persistent) ) ) ;; ;; is this the end of input stream, if yes end of job (cond ( (equal? token_type "EoF") (display "Thank you, for your visit ...") ) ;; ;; token = "LET", if yes build environment table, evaluate expressions ( (equal? token_type "LET-reserved") (scan) (scan) (evaluate_expressions (in_environment '()) ) (fetal_rep) ) ;; ;; error -- expected LET (else (syntax_error " ERROR - LET expected ....") (fetal_rep) ) ) ) )
; Function: display fetal prompt ; Preconditions: none ; Postconditions: none ; Rational: only Scheme statement to read the input stream (define (fetal_prompt) (display "ƒ> ") )
; Function: in_environment, builds a FETAL environment table ; Preconditions: persistent and environment_table ; Postconditions: environment_table ; ; use functions: scan - get the next token ; token_in - get token in persistent ; token_type_in - get token_type in persistent ; (define in_environment (lambda (environment_table) (let* ( (token_type (token_type_in persistent) ) (token (token_in persistent) ) ) ;; ;; is this the end the environment section, if yes return table (cond ( (or (equal? token_type "EoF") (equal? token_type "IN-reserved") ) (scan) (fetal_prompt) (scan) environment_table ) ;; ;; an environment entry must start with an identifier followed by = ;; if this is so, add a definition to environment table ( (and (equal? token_type "identifier") (equal? (token_in (scan)) "=") ) (scan) (in_environment (add_definition token environment_table) ) ) ;; ;; error -- definition expected (else (syntax_error "ERROR - Definition expected ....") (in_environment environment_table) ) ) ) ) )
; Function: add_definition, adds 1 definition to FETAL environment table ; Preconditions: identifier, environment_table ; Postconditions: environment_table ; ; use function: next_expression - build a FETAL expression ; token_type_in - get token_type in persistent ; (define add_definition (lambda (identifier environment_table) (let* ( (an_expression (next_expression)) (token (token_in persistent)) ) ;; ;; this expression must end in a ";" ;; if yes, add an entry to environment table (cond ( (and (equal? token ";") (not (null? an_expression)) ) (scan) (cons (list identifier an_expression) environment_table) ) ;; ;; otherwise it is invalid, report an error (else (syntax_error "invalid definition, syntax error") environment_table ) ) ) ) )
;-------------------------------------------------------------------------------
; Function syntax_error (define syntax_error (lambda (message) (let ( (token (token_in persistent)) ) (cond ( (equal? token ";") (display " -->") (print_etree (list message)) (newline) (newline) (scan) ) (else (scan) (syntax_error message) ) ) ) ) )
; Function to print an expression tree (define print_p_e_w_e (lambda (environment_with_expressions) (let* ( (environment_table (car environment_with_expressions)) (expression_tree (cadr environment_with_expressions)) ) ;; display "Persistent: " ;; display persistent ;; newline ;; add a display for environment_table latter (display " --> ") (print_etree expression_tree) (newline) ) ) )
; Function: print_etree ... for testing, prints an expression tree (define print_etree (lambda (expression_tree) (if (null? expression_tree) "" (let ( (head (car expression_tree) ) (the_rest (cdr expression_tree) ) ) (cond ( (list? head) (print_etree head) (print_etree the_rest) ) ( (equal? head "@") (display "( @ ") (print_etree the_rest) (display ") ") ) ( (equal? head "^") (display "[ ^ ") (print_etree (car the_rest) ) (print_etree (cadr the_rest) ) (display "] ") ) ( (equal? head "L") (display "{ ƒ") (print_function the_rest) ) ( (equal? head "leaf") (display (car the_rest)) (display " ") ) (else (display " ? ") (display head) ) ) ) ) ) )
; function to print a function expression (define print_function (lambda (a_list) (let ( (rest_of_list (cdr a_list) ) (head (car a_list) ) ) (print_etree head) (print_etree (car rest_of_list) ) (display "} ") ) ) )
; function to print an environment table (define print_environment (lambda (a_table) (cond ( (null? a_table) (newline) ) (else (display "( ") (display (caar a_table)) (display " = ") (print_etree (cadar a_table)) (display ")") (newline) (print_environment (cdr a_table)) ) ) ) )
(Display "Fetal_REP ... Loaded") (newline)
Parser Semester Project, CSCI 4501 by George North Spring 1995 Programed with Scheme a functional language similar to LISP ; FETAL Interpreter, Part 2 -- Parser ; Expression_Tree for FETAL Interpreter ; ; Expression_Tree is a collection of Scheme functions designed ; to build an expression tree
;-------------------------------------------------------------------------------
; Function: expressions, builds a FETAL expression tree ; Preconditions: expression_tree (and persistent) ; Postconditions: expression_tree ; ; use functions: token_in - get token in persistent ; token_type_in - get token_type in persistent ; scan - update persistent (with next token, etc.) ; abstraction - adds an abstraction to expression tree ; priority_group - adds a priority group to expression tree ; list_tree - build a list tree, add it to expression tree ; application_node - adds an application node to expression tree ; error_msg - return an error message ; (define expressions (lambda (expression_tree) (let* ( (token_type (token_type_in persistent) ) (token (token_in persistent) ) (leaf (list "leaf" token token_type) ) ) ;; ;; check for end of an expression (cond ( (or (equal? token_type "EoF") ;; end of input file (equal? token ",") ;; end of element in a list (equal? token "]") ;; end of a list (equal? token ")") ;; end of a priority grouping (equal? token ";") ;; end of line ) expression_tree ;; return completed expression ) ;; ;; is this a leaf, if yes add it to expression tree ( (or (equal? token_type "number") (equal? token_type "identifier") (equal? token_type "operator") ) (scan) (expressions (application_node leaf expression_tree) ) ) ;; ;; is this an abstraction, if yes build an abstraction ( (equal? token "\\") (scan) (let ( (an_abstraction (abstraction)) ) (expressions (application_node an_abstraction expression_tree) ) ) ) ;; ;; is this a list of expressions, if yes build a list ( (equal? token "[" ) (scan) (let ( (a_list (list_tree (next_expression) '())) ) (expressions (application_node a_list expression_tree) ) ) ) ;; ;; is this a priority grouping of expressions? if yes build a group ( (equal? token "(" ) (scan) (let ( (a_grouping (priority_group (next_expression))) ) (expressions (application_node a_grouping expression_tree) ) ) ) ;; ;; else this is an error of undetermined origin ;; execution should not reach this point (else (list "leaf" "some kind of error" "Error_Msg") ) ) ) ) )
; Function: error_msg, pass an error message as a leaf ; Preconditions: text of message ; Postconditions: leaf (define error_msg (lambda (message) (list "leaf" message "error_Msg") ) )
; Function: next_expression, get another expression ; Preconditions: persistent ; Postconditions: an_expression ; ; use function: expression - build an expression tree ; (define (next_expression) (expressions '() ) )
; Function: application_node, is this just a leaf, or another node ; Preconditions: node and expression_tree ; Postconditions: expression_tree ; ; Rational: if expression tree is empty, then this node is a leaf ; else build an application node ; ; @ or leaf ; / \ ; @ leaf ; / \ ; expression tree leaf ; ; ; Example: x y z or y ; ; is @ or y ; / \ ; @ z ; / \ ; x y ; ; each leaf node is a list of ("leaf" token token_type) ; i.e. ("leaf" "x" "identifier") ; each application node is a list of ("@" node node) ; a node could be either a leaf node or another application node ; ; Example: + x 100, is constructed as a scheme list ; each token is a list: + - ("leaf" "+" "operator") ; x - ("leaf" "x" "identifier") ; 100 - ("leaf" 100 "number") ; expression is constructed as a scheme list (for +, x, 100 substitute its list) ; ; ("@" ("@" + x) 100) ; ; (define application_node (lambda (node expression_tree) (if (null? expression_tree) node (list "@" expression_tree node) ) ) )
; Function: priority_group, verifies a grouping of FETAL expressions ; Preconditions: an_expression ; Postconditions: an_expression ; ; use functions: token_in - get token in persistent ; scan - update persistent (with next token, etc.) ; error_msg - return an error message ; ; x y z x (y z) ; ; @ @ ; / \ / \ ; @ z x @ ; / \ / \ ; x y y z ; (define priority_group (lambda (an_expression) (let ( (token (token_in persistent)) ) ;; ;; is this the end of a grouping, if yes return completed group (cond ( (equal? token ")") (scan) an_expression ) ;; ;; else, some kind of error ( else (error_msg "not a valid priority grouping") ) ) ) ) )
; Function: list_tree, builds a FETAL LIST tree ; Preconditions: an_expression and expression_list ; Postconditions: expression_list ; ; use functions: token_in - get token in persistent ; scan - update persistent (with next token, etc.) ; expression - build an expression tree ; end_of_list - is always an empty list "[]" ; ; ^ ; / \ ; expression ^ ; / \ ; expression [] ; ; Example: [1, 2, 3] or [] (empty list) ; ; is ^ ; / \ ; 1 ^ ; / \ ; 2 ^ ; / \ ; 3 [] ; ; ; each leaf node is an expression ; ; each application node is a list of ("^" expression list) ; ; Example: [1, 2, 3], is constructed as a scheme list ; remember that 1, 2, 3 are also scheme lists i.e. ("leaf" 2 "number) ; ; ("^" 1 ("^" 2 ("^" 3 []))) ; ; (define list_tree (lambda (an_expression expression_list) (let ( (token (token_in persistent)) ) ;; ;; is this the end of a list, if yes return completed list (cond ( (equal? token "]") (scan) (end_of_list an_expression) ) ;; ;; are there more expressions in this list ;; if yes than build a longer expression list ( (equal? token ",") (scan) (list "^" an_expression (list_tree (next_expression) expression_list) ) ) ;; ;; else, this is not a valid list ( else (error_msg "not a valid list") ) ) ) ) )
; Function: end_of_list, is always an empty list "[]" ; Preconditions: an_expression ; Postconditions: expression_list ; ; use functions: token_in - get token in persistent ; scan - update persistent (with next token, etc.) ; expression - build an expression tree ; (define end_of_list (lambda (an_expression) ;; ;; if entire list is empty, return just an empty list ;; otherwise, return an expression with an empty list (if (null? an_expression) (list "leaf" "[]" "Empty_List") (list "^" an_expression (list "leaf" "[]" "Empty_List") ) ) ) )
; Function: abstraction, builds a FETAL abstraction tree ; Preconditions: persistent ; Postconditions: an_abstraction ; ; use functions: token_type_in - get token_type in persistent ; scan - update persistent (with next token, etc.) ; abstraction_node - build a node on an abstraction tree ; error_msg - return an error message ; ; ƒ() ; | ; @ ; / \ ; expression tree leaf ; ; an abstraction tree is constructed by cons'ing together the ; abstraction ID with an expression tree ; ; Example: \ x : * x 3 ; ; ("L"x ("@" ("@" * x) 3)), ; remember that *, x, 3 are also scheme lists i.e. ("leaf" 3 "number) ; (define (abstraction) (let* ( (token_type (token_type_in persistent)) (token (token_in persistent)) (abs_ID (list "leaf" token token_type)) ) (cond ( (equal? token_type "identifier") (scan) ;; ;; abstractions must be an identifier (or identifiers) ;; followed by a ":" ;; this is, so make an abstraction node (abstraction_node abs_ID) ) (else (error_msg "not a valid abs_Identifier") ) ) ) )
; Function: abstraction_node, builds an abstraction tree ; Preconditions: abstraction and identifier ; Postconditions: an_abstraction ; ; use functions: token_in - get token in persistent ; token_type_in - get token_type in persistent ; scan - update persistent (with next token, etc.) ; next_expression - builds an expression tree ; abstraction - start another abstraction definition ; error_msg - return an error message ; (define abstraction_node (lambda (abs_ID) (let* ( (token_type (token_type_in persistent)) (token (token_in persistent)) ) ;; ;; ":" completes this abstraction definition ;; return it along with its expression (cond ( (equal? token ":") (scan) (list "L" abs_ID (next_expression) ) ) ( (equal? token "\\") (scan) ;; ;; "\" is another abstraction definition ;; make another abstraction (list "L" abs_ID (abstraction) ) ) ( (equal? token_type "identifier") ;; ;; Note that it is not necessary to scan for another token ;; because we assume that we have an implied "\" in input stream ;; ;; an identifier is another abstraction definition ;; make another abstraction (list "L" abs_ID (abstraction) ) ) ;; ;; report an error, this is not a complete abstraction ( else (error_msg "not a valid abstraction") ) ) ) ) )
Evaluator Semester Project, CSCI 4501 by George North Spring 1995 Programed with Scheme a functional language similar to LISP ; FETAL Interpreter, Part 3 -- Evaluator ; ; Semester Project, CSCI 4501 - Spring 1995 ; by George North ; May 2,1995
; Evaluate/Reduce Expressions for FETAL Interpreter ; ; evaluate_expressions is a collection of Scheme functions designed ; to evaluate FETAL expressions ; ; ; Algorithm: ; 1. Get the next expression from input stream ; 2. Evaluate (expression tree) ; 3. Print the answer, or report an error ; ; ; 2. Evaluate (expression tree) ; ; Note: A FETAL expression tree consists of leaf(s) that are numbers, ; identifiers, operators, or null list. Nodes are ; Applications, Abstractions, or Lists. Each node has both a ; Left leaf and a right leaf (a binary tree). ; ; Stack is constructed by tail-recursing an expression tree ; then reducing the Stack until only one leaf remains ; this is the answer returned by the expression ; or an ERROR happened, and the stack may not be empty ; ; Expressions are calculated and values returned using ; Lazy evaluation techniques. ; ; Abstractions may return abstractions as values. ; ; 2.1 if (is application) -- find redux ; 2.1.1 push right child ; 2.1.2 evaluate left child (will also Reduce Stack) ; 2.1.3 FINISHED ; ; 2.2 evaluate ; 2.2.1. if (an abstraction) abstract it ; 2.2.2. if (or (a number) (a list) (a empty list) FINISHED ; 2.2.3. else this must be a leaf, see if it will reduce ; ; ; ; 2.2.1. Abstraction ; ; Note: A FETAL abstraction consists of: a formal parameter, and ; an expression body. The expression body may itself be ; an abstraction, which can appear to be a function with ; more than one formal parameter, but functions receive ; parameters only one at a time. ; ; 2.2.1.0 separate the abstraction ; 2.2.1.1 get the formal parameter ; 2.2.1.2 get the abstraction body (abstract it if needed) ; 2.2.1.3 pop the actual parameter ; 2.2.1.4 substitute actual parameter for formal parameter ; ; ; 2.2.3. reduce a leaf ; ; 2.2.3.1. not a leaf, return ERROR ; 2.2.3.2. identify OPERATOR (unary, binary, IF, etc.) - evaluate it ; 2.2.3.3. if an identifier, loop it up in environment ; 2.2.3.4. else, ERROR - not a valid operator ; ; ; ------------------------------------------------------------------------------ ; ; ; Stack: is a global variable, used by the Evaluator ; Stack is a Scheme list maintained by LIFO method (last in first out) ; list of FETAL expressions ; ; use functions: push - add expression to top of stack ; pop - remove top of stack, return expression ; print_stack - list tokens in stack, used to print answer ; display_stack - list expressions in stack, used for debugging ; ; ;
;-------------------------------------------------------------------------------
; Function: evaluate_expressions - evaluate FETAL expressions ; Preconditions: environment_table ; Postconditions: none ; ; use functions: token_type_in - get token_type in persistent ; next_expression - get next FETAL expression ; evaluate - reduce/evaluate one expression ; scan - get tokens from input stream ; ; (define evaluate_expressions (lambda (environment_table) (let* ( (an_expression (next_expression)) (token_type (token_type_in persistent)) (token (token_in persistent)) ) ;; ;; check for end of input stream, ;; or beginning of another fetal program ;; if yes, exit evaluator (cond ( (or (equal? token_type "EoF") (equal? token "let") ) (display "All done -- ") ) ;; ;; this expression must end in a ";" ;; if yes, evaluate it in its environment table ( (equal? token ";") ;; ;; if this is a valid expression, call FETAL evaluator ;; empty the stack (set! stack '()) ;; make the environment global (set! an_environment environment_table) ;; ;; for debug ONLY (cond ( debug (display "Starting Evaluation") (newline) (display "Environment: ") (print_environment an_environment) (newline) (display "Expression: ") (display an_expression) (newline) ) ) ;; (newline) ;; ;; if not an empty expression, evaluate it (if (and (list? an_expression) (not (null? an_expression) ) ) (push (evaluate an_expression) ) (push (error_answer " ") ) ) (print_stack stack) (newline) (fetal_prompt) (scan) (evaluate_expressions environment_table) ) ;; ;; otherwise this is not a valid expression, report an error ( else (syntax_error "invalid expression, syntax error") (evaluate_expressions environment_table) ) ) ) ) )
; Function: evaluate - one expression ; Preconditions: an expression ; Postconditions: an expression ; ; use functions: token_type_of - token type of a leaf node ; token_of - token of a leaf node ; reduce - identify operator, apply FETAL semantics ; find_a_redux - get left and right child of an application ; abstract - parameter passing ; ; (define evaluate (lambda (an_expression) ;; ;; is this an application (cond ( (is_an_application? an_expression) (evaluate (find_a_redux an_expression)) ) ;; ;; is this an abstraction? ( (is_an_abstraction? an_expression) (evaluate (abstract an_expression (pop)) ) ) ;; ;; ?? already reduced, FINISHED ( (or (is_a_number? an_expression) (is_a_list? an_expression) (is_empty_list? an_expression) ) an_expression ) ;; ;; else, reduce some more (else evaluate (reduce an_expression) ) ) ) ) (define find_a_redux ;; separate an application into right and left child (lambda (an_expression) (let ( (right_child (caddr an_expression) ) ( left_child (cadr an_expression) ) ) (push right_child) (if (is_an_application? left_child) (find_a_redux left_child) left_child ) ) ) ) (define reduce ;; identify operator, apply semantics (lambda (an_expression) ;; ;; if this is NOT a leaf, ERROR (cond ( (not (is_a_leaf? an_expression) ) (error_answer "NOT a valid expression construct") ) ;; ;; if is an ERROR leaf, can't evaluate it ( (is_an_error? an_expression) an_expression ) ;; ( (is_unary_operator? an_expression) (unary (token_of an_expression) (evaluate (pop) ) ) ) ;; ( (is_binary_operator? an_expression) (binary (token_of an_expression) (evaluate (pop) ) (evaluate (pop) ) ) ) ;; ( (is_if_function? an_expression) (pre_defined_if (evaluate (pop) ) (pop) (pop) ) ) ;; ( (is_null_function? an_expression) (pre_defined_null (evaluate (pop) ) ) ) ;; ( (is_head_function? an_expression) (pre_defined_head (evaluate (pop) ) ) ) ;; ( (is_tail_function? an_expression) (pre_defined_tail (evaluate (pop) ) ) ) ;; ( (is_cons_function? an_expression) (pre_defined_cons (pop) (evaluate (pop) )) ) ;; ( (is_an_identifier? an_expression) (evaluate (identifier_lookup an_expression an_environment)) ) ;; ;; ERROR not a valid operator ( else (error_answer "NOT a valid operator") ) ) ) )
; Function: abstract - extract expression, pass parameters ; Preconditions: an_expression ; Postconditions: an_expression ; ; use functions: pop - top of the stack ; evaluate - an expression body in its environment ; pass_parameter - substitute actual parameter for formal ; ; (define abstract (lambda (an_expression actual_parameter) (let* ( (formal_parameter (cadr an_expression) ) (body (caddr an_expression) ) (expression_body (if (is_an_abstraction? body) (abstract body (pop) ) body ) ) ) ;; for debug ONLY (cond ( debug (display "Starting Abstraction") (newline) (display "Function Environment: ") (display formal_parameter) (display " : ") (display actual_parameter) (newline) (display "Expression Body: ") (display expression_body) (newline) ) ) ;; ;; pass parameters (if (is_an_error? actual_parameter) (error_answer "Abstraction missing a parameter ...") (pass_parameter formal_parameter actual_parameter expression_body) ) ) ) ) (define pass_parameter (lambda (formal_parameter actual_parameter expression_body) (cond ( (not (is_an_application? expression_body) ) (substitute formal_parameter actual_parameter expression_body ) ) ;; left child (else (list "@" (pass_parameter formal_parameter actual_parameter (cadr expression_body) ) ;; right child (pass_parameter formal_parameter actual_parameter (caddr expression_body) ) ) ) ) ) ) (define substitute (lambda (formal_parameter actual_parameter node) (cond ( (not (is_a_leaf? node) ) node ) ( (not (is_an_identifier? node) ) node ) ( (not (equal? (token_of formal_parameter) (token_of node) ) ) node ) (else actual_parameter) ) ) )
; Function: identifier_lookup, check environment table, copy expression ; Preconditions: expression, environment ; Postconditions: expression ; ; (define identifier_lookup (lambda (an_expression environment) (if (null? environment) ;; ;; identifier not found, ERROR (error_answer "Unknown Identifier") (let ( (new_identifier (caar environment) ) (new_expression (cadar environment) ) ) (if (not (equal? (token_of an_expression) new_identifier) ) (identifier_lookup an_expression (cdr environment) ) new_expression ) ) ) ) )
; Function: binary - evaluate binary operators ; Preconditions: operator operand ; Postconditions: expression ; ; use functions: token_type_of - get token_type of a leaf ; token_of - get token of a leaf ; number_answer - construct a leaf for the answer ; (define binary (lambda (operator operand1 operand2) (if (and (is_a_number? operand1) (is_a_number? operand2) ) (let ( (number1 (token_of operand1)) (number2 (token_of operand2)) ) (cond ( (equal? operator "&") (number_answer (if (= number1 0) 0 number2) ) ) ( (equal? operator "|") (number_answer (if (not (= number1 0)) 0 number2) ) ) ( (equal? operator "+") (number_answer (+ number1 number2) ) ) ( (equal? operator "-") (number_answer (- number1 number2) ) ) ( (equal? operator "*") (number_answer (* number1 number2) ) ) ( (or (equal? operator "/") (equal? operator "%") ) (if (= number2 0) (error_answer "Error, division by 0") (number_answer (/ number1 number2) ) ) ) ( (equal? operator ">") (number_answer (if (> number1 number2) 0 1) ) ) ( (equal? operator "<") (number_answer (if (< number1 number2) 0 1) ) ) ( (equal? operator "=") (number_answer (if (= number1 number2) 0 1) ) ) (else (error_answer "Error, unknown operator") ) ) ) (error_answer "Error, binary operator requires number") ) ) )
; Function: unary - evaluate unary operators ; Preconditions: operator operand ; Postconditions: expression ; ; use functions: token_type_of - get token_type of a leaf ; token_of - get token of a leaf ; number_answer - construct a leaf for the answer ; ; (define unary (lambda (operator operand) (if (is_a_number? operand) (let ( (number (token_of operand)) ) (cond ( (equal? operator "~") (number_answer (* -1 number) ) ) ( (equal? operator "!") (number_answer (if (= number 0) 1 0) ) ) ) ) (error_answer "Error, unary operator requires number") ) ) )
; Function: pre_defined_if - if then else ; Preconditions: question true_answer false_answer ; Postconditions: expression ; ; use functions: token_type_of - get token_type of a leaf ; token_of - get token of a leaf ; number_answer - construct a leaf for the answer ; ; (define pre_defined_if (lambda (conditional true_answer false_answer) (if (not (is_a_number? conditional) ) (error_answer "Error, IF condition won't reduce") ;; ;; evaluate IF (if (equal? (token_of conditional) 0) (evaluate true_answer) (evaluate false_answer) ) ) ) )
; Function: pre_defined_null ; Preconditions: operand ; Postconditions: expression ; ; use functions: is_empty_list? - TRUE/FALSE, is list empty ; (define pre_defined_null (lambda (operand) (number_answer (if (is_empty_list? operand) 0 1) ) ) )
; Function: pre_defined_head ; Preconditions: operand ; Postconditions: expression ; ; use functions: is_a_list? - TRUE/FALSE, is a list ; ; (define pre_defined_head (lambda (operand) (if (is_a_list? operand) (cadr operand) (error_answer "Error, HEAD requires a list of at least one element") ) ) )
; Function: pre_defined_tail ; Preconditions: operand ; Postconditions: expression ; ; use functions: is_a_list? - TRUE/FALSE, is a list ; ; (define pre_defined_tail (lambda (operand) (if (is_a_list? operand) (caddr operand) (error_answer "Error, TAIL requires a list of at least one element") ) ) )
; Function: pre_defined_cons ; Preconditions: operand1 operand2 ; Postconditions: expression ; ; use functions: is_a_list? - TRUE/FALSE, is a list ; ; (define pre_defined_cons (lambda (operand1 operand2) (if (or (is_a_list? operand2) (is_empty_list? operand2) ) (list "^" operand1 operand2) (error_answer "Error, CONS requires a list of at least one element") ) ) )
; Function: error_answer - construct a leaf with the answer ; Preconditions: error_msg ; Postconditions: expression ; (define error_answer (lambda (answer) (list "leaf" answer "Error_Msg") ) )
; Function: number_answer - construct a leaf with an integer answer ; Preconditions: number ; Postconditions: expression ; (define number_answer (lambda (answer) (list "leaf" answer "number") ) )
;------------------------------------------------------------------------------ ; stack - global variable ; ; a scheme list of FETAL expressions ;
; Function: push ; Preconditions: node ; Postconditions: stack ; ; (define push (lambda (node) (set! stack (cons node stack) ) (if debug (display_stack stack "PUSH") ) ) )
; Function: pop ; Preconditions: stack ; Postconditions: top of stack ; ; (define (pop) (if debug (display_stack stack "POP") ) (cond ( (null? stack) (push (error_answer "Stack underflow ERROR") ) ) ) (let ( (top (car stack)) ) (set! stack (cdr stack) ) top ) )
; Function: print_stack ; Preconditions: stack ; Postconditions: none ; ; (define print_stack (lambda (a_stack) (if (not (null? a_stack) ) (let ( (top (car a_stack)) ) (display " --> ") (if (not (is_a_leaf? top) ) (print_etree top) (display (token_of top) ) ) (newline) (print_stack (cdr a_stack) ) ) ) ) )
; Function: display_stack ; Preconditions: stack ; Postconditions: none ; ; (define display_stack (lambda (a_stack title) (display title) (newline) (display_stack2 a_stack) ) ) (define display_stack2 (lambda (a_stack) (if (null? a_stack) (newline) (let ( (top (car a_stack)) ) (display top) (newline) (display_stack2 (cdr a_stack) ) ) ) ) )
;-------------------------------------------------------------------------------
;Note: These are functions to identify parts of a node, or leaf of an expression ; tree. Rational is that these functions make code easier to read, hiding ; complexities of list construction.
; Function: token_of, return token of leaf of an expression tree ; Preconditions: leaf ; Postconditions: token ; (define token_of (lambda (leaf) (cadr leaf) ) )
; Function: token_type_of, return token-type of leaf ; Preconditions: leaf ; Postconditions: token_type ; (define token_type_of (lambda (leaf) (caddr leaf) ) )
; Function: is_if_function? ; Preconditions: node ; Postconditions: TRUE if this node is pre-defined IF function, otherwise FALSE ; (define is_if_function? (lambda (node) (if (equal? (token_of node) "if") #t #f ) ) )
; Function: is_null_function? ; Preconditions: node ; Postconditions: TRUE if this node is pre-defined NULL function ; (define is_null_function? (lambda (node) (if (equal? (token_of node) "null") #t #f ) ) )
; Function: is_head_function? ; Preconditions: node ; Postconditions: TRUE if this node is pre-defined HEAD function ; (define is_head_function? (lambda (node) (if (equal? (token_of node) "head") #t #f ) ) )
; Function: is_tail_function? ; Preconditions: node ; Postconditions: TRUE if this node is pre-defined TAIL function ; (define is_tail_function? (lambda (node) (if (equal? (token_of node) "tail") #t #f ) ) )
; Function: is_cons_function? ; Preconditions: node ; Postconditions: TRUE if this node is pre-defined CONS function ; (define is_cons_function? (lambda (node) (if (equal? (token_of node) "cons") #t #f ) ) )
; Function: is_a_leaf? ; Preconditions: node ; Postconditions: TRUE if this node is a leaf, otherwise FALSE ; (define is_a_leaf? (lambda (node) (if (equal? (car node) "leaf") #t #f ) ) )
; Function: is_an_application? ; Preconditions: node ; Postconditions: TRUE if this node is an application, otherwise FALSE ; (define is_an_application? (lambda (node) (if (equal? (car node) "@") #t #f ) ) )
; Function: is_a_list? ; Preconditions: node ; Postconditions: TRUE if this node is a list, otherwise FALSE ; (define is_a_list? (lambda (node) (if (equal? (car node) "^") #t #f ) ) )
; Function: is_an_abstraction? ; Preconditions: node ; Postconditions: TRUE if this node is an abstraction, otherwise FALSE ; (define is_an_abstraction? (lambda (node) (if (equal? (car node) "L") #t #f ) ) )
; Function: is_empty_list? ; Preconditions: leaf ; Postconditions: TRUE if this node is an EMPTY LIST, otherwise FALSE ; (define is_empty_list? (lambda (leaf) (if (equal? (token_type_of leaf) "Empty_List") #t #f ) ) )
; Function: is_a_number? ; Preconditions: leaf ; Postconditions: TRUE if this node is an integer, otherwise FALSE ; (define is_a_number? (lambda (leaf) (if (equal? (token_type_of leaf) "number") #t #f ) ) )
; Function: is_an_identifier? ; Preconditions: leaf ; Postconditions: TRUE if this node is an identifier, otherwise FALSE ; (define is_an_identifier? (lambda (leaf) (if (equal? (token_type_of leaf) "identifier") #t #f ) ) )
; Function: is_an_error? ; Preconditions: leaf ; Postconditions: TRUE if this node is an identifier, otherwise FALSE ; (define is_an_error? (lambda (leaf) (if (equal? (token_type_of leaf) "Error_Msg") #t #f ) ) )
; Function: is_unary_operator? ; Preconditions: leaf ; Postconditions: TRUE if this node is a unary operator, otherwise FALSE ; (define is_unary_operator? (lambda (leaf) (let ( (token (token_of leaf) ) (token_type (token_type_of leaf) ) ) (if (and (equal? token_type "operator") (or (equal? token "~") (equal? token "!") ) ) #t #f ) ) ) )
; Function: is_binary_operator? ; Preconditions: leaf ; Postconditions: TRUE if this node is a binary operator, otherwise FALSE ; (define is_binary_operator? (lambda (leaf) (let ( (token (token_of leaf) ) (token_type (token_type_of leaf) ) ) (if (and (not (is_unary_operator? leaf) ) (or (equal? (token_type_of leaf) "operator") (equal? (token_type_of leaf) "special" ) ) ) #t #f ) ) ) )
(Display "Evaluate_Expressions ... Loaded") (newline)
Some test DATA
-- debugLET; -- some Applications, some Curring.
addone = \ v : + 1 v; sq = \ x : * x x; twice = \f: \x: f (f x); fact = \ n : if (= n 0) 1 (* n (fact (- n 1))); fib = \ n : if (= n 1) 1 (if (= n 2) 2 (+ (fib (- n 1)) (fib (- n 2))) );
IN;
; eval; addone 3; sq 4; sq (addone 3); (\x:+ x x) 3; (\x:+ x x) (sq 4); (\x:+ x x) ((\x:+ 2 x) 3); twice addone 3; twice (+ 3) 2; twice twice twice addone 0; addone twice addone 3; fib 3; fib 8; fact 3; fact 10; if 0 (fib 7) (fact 4); if 1 (fib 7) (fact 4); cons fib []; eval (head (cons fib []) ) 4;
Converted with HTML Markup 1.1 by Scott J. Kleper
http://htc.rit.edu/klephacks/markup.html
ftp://htc.rit.edu/pub/HTML-Markup-current.hqx