Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ;accessors for a list of operands
- (define (no-operands? ops) (null? ops))
- (define (first-operand ops) (car ops))
- (define (rest-operands ops) (cdr ops))
- ;predicate for cond
- (define (cond? exp) (tagged-list? exp 'cond))
- ;accessors for cond
- (define (cond-clauses exp) (cdr exp))
- (define (cond-else-clause? clause)
- (eq? (cond-predicate clause) 'else))
- (define (cond-predicate clause) (car clause))
- (define (cond-actions clause) (cdr clause))
- ;converts a cond to nested ifs
- (define (cond->if exp)
- (expand-clauses (cond-clauses exp)))
- ;converts a cond to nested ifs
- ;helper method for cond->if
- (define (expand-clauses clauses)
- (if (null? clauses)
- 'false ; no else clause
- (let ((first (car clauses))
- (rest (cdr clauses)))
- (if (cond-else-clause? first)
- (if (null? rest)
- (sequence->exp (cond-actions first))
- (error "ELSE clause isn't last -- COND->IF"
- clauses))
- (make-if (cond-predicate first)
- (sequence->exp (cond-actions first))
- (expand-clauses rest))))))
- ;;; SECTION 4.1.3
- (define (true? x)
- (not (eq? x false)))
- (define (false? x)
- (eq? x false))
- ;procedure objects are created by lambdas
- (define (make-procedure parameters body env)
- (list 'procedure parameters body env))
- (define (compound-procedure? p)
- (tagged-list? p 'procedure))
- (define (procedure-parameters p) (cadr p))
- (define (procedure-body p) (caddr p))
- (define (procedure-environment p) (cadddr p))
- (define (enclosing-environment env) (cdr env))
- (define (first-frame env) (car env))
- (define the-empty-environment '())
- (define (make-frame variables values)
- (cons variables values))
- (define (frame-variables frame) (car frame))
- (define (frame-values frame) (cdr frame))
- (define (add-binding-to-frame! var val frame)
- (set-car! frame (cons var (car frame)))
- (set-cdr! frame (cons val (cdr frame))))
- (define (extend-environment vars vals base-env)
- (if (= (length vars) (length vals))
- (cons (make-frame vars vals) base-env)
- (if (< (length vars) (length vals))
- (error "Too many arguments supplied" vars vals)
- (error "Too few arguments supplied" vars vals))))
- (define (lookup-variable-value var env)
- (define (env-loop env)
- (define (scan vars vals)
- (cond ((null? vars)
- (env-loop (enclosing-environment env)))
- ((eq? var (car vars))
- (car vals))
- (else (scan (cdr vars) (cdr vals)))))
- (if (eq? env the-empty-environment)
- (error "Unbound variable" var)
- (let ((frame (first-frame env)))
- (scan (frame-variables frame)
- (frame-values frame)))))
- (env-loop env))
- (define (set-variable-value! var val env)
- (define (env-loop env)
- (define (scan vars vals)
- (cond ((null? vars)
- (env-loop (enclosing-environment env)))
- ((eq? var (car vars))
- (set-car! vals val))
- (else (scan (cdr vars) (cdr vals)))))
- (if (eq? env the-empty-environment)
- (error "Unbound variable -- SET!" var)
- (let ((frame (first-frame env)))
- (scan (frame-variables frame)
- (frame-values frame)))))
- (env-loop env))
- (define (define-variable! var val env)
- (let ((frame (first-frame env)))
- (define (scan vars vals)
- (cond ((null? vars)
- (add-binding-to-frame! var val frame))
- ((eq? var (car vars))
- (set-car! vals val))
- (else (scan (cdr vars) (cdr vals)))))
- (scan (frame-variables frame)
- (frame-values frame))))
- ;;; SECTION 4.1.4
- (define (setup-environment)
- (let ((initial-env
- (extend-environment (primitive-procedure-names)
- (primitive-procedure-objects)
- the-empty-environment)))
- (define-variable! 'true true initial-env)
- (define-variable! 'false false initial-env)
- initial-env))
- ;;;; [do later] (define the-global-environment (setup-environment))
- ;predicate for primitive procedures
- (define (primitive-procedure? proc)
- (tagged-list? proc 'primitive))
- ;accessor for the actual function
- ;primitive values are stored in the frame as as ('primitive car '())
- (define (primitive-implementation proc) (cadr proc))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; ADD NEW PRIMITIVES HERE (SUCH AS +, -, etc)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;concrete definition of primitives (mapped to scheme)
- (define primitive-procedures
- (list (list 'car car)
- (list 'cdr cdr)
- (list 'cons cons)
- (list 'null? null?)
- ;; more primitives
- ))
- ;gets all primitive names
- (define (primitive-procedure-names)
- (map car
- primitive-procedures))
- ;gets all primitive procedures in the form ('primitive proc)
- (define (primitive-procedure-objects)
- (map (lambda (proc) (list 'primitive (cadr proc)))
- primitive-procedures))
- ; [moved to start of file] (define apply-in-underlying-scheme apply)
- ;applies calls the built-in apply function to execute primitive procedures
- (define (apply-primitive-procedure proc args)
- (apply-in-underlying-scheme
- (primitive-implementation proc) args))
- ;;; Prompts
- (define input-prompt ";;; M-Eval input:")
- (define output-prompt ";;; M-Eval value:")
- ;;; Main loop to drive metacircular interpreter
- (define (driver-loop)
- (prompt-for-input input-prompt)
- (let ((input (read)))
- (let ((output (eval input the-global-environment)))
- (announce-output output-prompt)
- (user-print output)))
- (driver-loop))
- (define (prompt-for-input string)
- (newline) (newline) (display string) (newline))
- (define (announce-output string)
- (newline) (display string) (newline))
- (define (user-print object)
- (if (compound-procedure? object)
- (display (list 'compound-procedure
- (procedure-parameters object)
- (procedure-body object)
- '<procedure-env>))
- (display object)))
- ;;; Following are commented out so as not to be evaluated when
- ;;; the file is loaded. They are needed to run the interpreter.
- (define the-global-environment (setup-environment))
- (driver-loop)
- 'METACIRCULAR-EVALUATOR-LOADED
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement