DataMuseum.dk

top - download

    Length: 2858 (0xb2a)
    Types: TextFile
    Names: »ps8mods.scm«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/psets/ps8mods.scm« 

TextFile

;;;This is the file PS8-MODS.SCM


(define (add-scheme-primitives prim-list base-env)
  (extend-environment
   prim-list
   (mapcar (lambda (prim)
             (eval prim user-initial-environment))
           prim-list)
   base-env))

(define (mini-apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence (procedure-body procedure)
                        (extend-environment
                         (procedure-parameters procedure)
                         arguments
                         (procedure-environment procedure))))
        (else (error "Unknown procedure type -- APPLY"
		     (list procedure arguments)))))



(define the-empty-environment '())

(define (add-binding-pair var val env)
  (cons (list var val) env))

(define (lookup-variable-value var env)
  (let ((bp (binding-pair var env)))
    (cond ((null? bp) (error "Unbound variable" var))
          (else (cadr bp)))))

(define (extend-environment variables values base-env)
  (define (pair-up variables values)
    (cond ((null? variables)
           (cond ((null? values) '())
                 (t
                  (error "Too many arguments supplied"
			 (list variable values)))))
          ((null? values)
           (error "Too few arguments supplied"
		  (list variables values)))
          (else (cons (list (car variables) (car values))
                      (pair-up (cdr variables)
                               (cdr values))))))
  (cons (pair-up variables values) base-env))

(define (binding-pair var env)
  (define (scan pairlist)
    (cond ((null? pairlist)
           (cond ((null? (cdr env)) '())
                 (else (binding-pair var (cdr env)))))
          ((eq? var (caar pairlist)) (car pairlist))
          (else (scan (cdr pairlist)))))
  (scan (car env)))


(define (set-variable-value! var val env)
  (let ((bp (binding-pair var env)))
    (cond ((null? bp) (error "Unbound variable" var))
          (else (set-car! (cdr bp) val)))))







(define (define-variable! var val env)
  (set-car! env
            (cons (list var val)
                  (car env))))



(define (definition-variable exp)
  (cond ((variable? (cadr exp))
         (cadr exp))
        (else
         (caadr exp))))

(define (definition-value exp) 
  (cond ((variable? (cadr exp))
         (caddr exp))           
        (else
         (make-lambda (cdadr exp)    ;Formal parameters
		      (cddr exp))))) ;Body



(define (make-lambda formals body)
  (cons 'lambda (cons formals body)))

(define (lambda-formals lambda-exp) (cadr lambda-exp))

(define (lambda-body lambda-exp) (cddr lambda-exp))

(define (procedure-parameters proc)
  (lambda-formals (procedure-text proc)))

(define (procedure-body proc)
  (lambda-body (procedure-text proc)))