examples/metacirc.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Mandatory SICP Metacircular Evaluator ;;
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 (define apply-in-underlying-scheme apply)
   6
   7 ;; Verbatim code from SICP
   8
   9 (display "eval and apply\n")
  10
  11 (define (eval exp env)
  12   (cond ((self-evaluating? exp)
  13          exp)
  14         ((variable? exp)
  15          (lookup-variable-value exp env))
  16         ((quoted? exp)
  17          (text-of-quotation exp))
  18         ((assignment? exp)
  19          (eval-assignment exp env))
  20         ((definition? exp)
  21          (eval-definition exp env))
  22         ((if? exp)
  23          (eval-if exp env))
  24         ((lambda? exp)
  25          (make-procedure
  26            (lambda-parameters exp)
  27            (lambda-body exp)
  28            env))
  29         ((begin? exp)
  30          (eval-sequence
  31            (begin-actions exp)
  32            env))
  33         ((cond? exp)
  34          (eval (cond->if exp) env))
  35         ((application? exp)
  36          (apply (eval (operator exp) env)
  37                 (list-of-values
  38                   (operands exp)
  39                   env)))
  40         (else
  41           (error "Unknown expression type: EVAL" exp))))
  42
  43 (define (apply procedure arguments)
  44   (cond ((primitive-procedure? procedure)
  45          (apply-primitive-procedure
  46            procedure
  47            arguments))
  48         ((compound-procedure? procedure)
  49          (eval-sequence
  50            (procedure-body procedure)
  51            (extend-environment
  52              (procedure-parameters
  53                procedure)
  54              arguments
  55              (procedure-environment
  56                procedure))))
  57         (else
  58           (error "Unknown procedure type: APPLY"
  59                  procedure))))
  60
  61 (define (list-of-values exps env)
  62   (if (no-operands? exps)
  63     '()
  64     (cons (eval (first-operand exps) env)
  65           (list-of-values
  66             (rest-operands exps)
  67             env))))
  68
  69 (define (eval-if exp env)
  70   (if (true? (eval (if-predicate exp) env))
  71     (eval (if-consequent exp) env)
  72     (eval (if-alternative exp) env)))
  73
  74 (define (eval-sequence exps env)
  75   (cond ((last-exp? exps)
  76          (eval (first-exp exps) env))
  77         (else
  78           (eval (first-exp exps) env)
  79           (eval-sequence (rest-exps exps)
  80                          env))))
  81
  82 (define (eval-assignment exp env)
  83   (set-variable-value!
  84     (assignment-variable exp)
  85     (eval (assignment-value exp) env)
  86     env)
  87   'ok)
  88
  89 (define (self-evaluating? exp)
  90   (cond ((number? exp) true)
  91         ((string? exp) true)
  92         (else false)))
  93
  94 (define (variable? exp) (symbol? exp))
  95
  96 (define (quoted? exp)
  97   (tagged-list? exp 'quote))
  98
  99 (define (text-of-quotation exp)
 100   (cadr exp))
 101
 102 (define (tagged-list? exp tag)
 103   (if (pair? exp)
 104     (eq? (car exp) tag)
 105     false))
 106
 107 (define (assignment? exp)
 108   (tagged-list? exp 'set!))
 109
 110 (define (assignment-variable exp)
 111   (cadr exp))
 112
 113 (define (assignment-value exp) (caddr exp))
 114
 115 (define (definition? exp)
 116   (tagged-list? exp 'define))
 117
 118 (define (definition-variable exp)
 119   (if (symbol? (cadr exp))
 120     (cadr exp)
 121     (caadr exp)))
 122
 123 (define (definition-value exp)
 124   (if (symbol? (cadr exp))
 125     (caddr exp)
 126     (make-lambda
 127       (cdadr exp)   ; formal parameters
 128       (cddr exp)))) ; body
 129
 130
 131 (display "lambda... \n")
 132
 133 (define (lambda? exp)
 134   (tagged-list? exp 'lambda))
 135 (define (lambda-parameters exp) (cadr exp))
 136 (define (lambda-body exp) (cddr exp))
 137
 138 (define (make-lambda parameters body)
 139     (cons 'lambda (cons parameters body)))
 140
 141 (define (if? exp) (tagged-list? exp 'if))
 142 (define (if-predicate exp) (cadr exp))
 143 (define (if-consequent exp) (caddr exp))
 144 (define (if-alternative exp)
 145   (if (not (null? (cdddr exp)))
 146     (cadddr exp)
 147     'false))
 148
 149 (define (make-if predicate
 150                  consequent
 151                  alternative)
 152   (list 'if
 153         predicate
 154         consequent
 155         alternative))
 156
 157 (define (begin? exp)
 158   (tagged-list? exp 'begin))
 159 (define (begin-actions exp) (cdr exp))
 160 (define (last-exp? seq) (null? (cdr seq)))
 161 (define (first-exp seq) (car seq))
 162 (define (rest-exps seq) (cdr seq))
 163
 164 (define (sequence->exp seq)
 165   (cond ((null? seq) seq)
 166         ((last-exp? seq) (first-exp seq))
 167         (else (make-begin seq))))
 168
 169 (define (make-begin seq) (cons 'begin seq))
 170
 171 (define (application? exp) (pair? exp))
 172 (define (operator exp) (car exp))
 173 (define (operands exp) (cdr exp))
 174 (define (no-operands? ops) (null? ops))
 175 (define (first-operand ops) (car ops))
 176 (define (rest-operands ops) (cdr ops))
 177
 178
 179 (display "cond... \n")
 180
 181 (define (cond? exp)
 182   (tagged-list? exp 'cond))
 183 (define (cond-clauses exp) (cdr exp))
 184 (define (cond-else-clause? clause)
 185   (eq? (cond-predicate clause) 'else))
 186 (define (cond-predicate clause)
 187   (car clause))
 188 (define (cond-actions clause)
 189   (cdr clause))
 190 (define (cond->if exp)
 191   (expand-clauses (cond-clauses exp)))
 192 (define (expand-clauses clauses)
 193   (if (null? clauses)
 194     'false     ; no else clause
 195     (let ((first (car clauses))
 196           (rest (cdr clauses)))
 197       (if (cond-else-clause? first)
 198         (if (null? rest)
 199           (sequence->exp
 200             (cond-actions first))
 201           (error "ELSE clause isn't last: COND->IF"
 202           clauses))
 203       (make-if (cond-predicate first)
 204                (sequence->exp
 205                  (cond-actions first))
 206                (expand-clauses
 207                  rest))))))
 208
 209
 210 (define (true? x)
 211   (not (eq? x false)))
 212
 213 (define (false? x)
 214   (eq? x false))
 215
 216
 217 (display "make-procedure...\n")
 218
 219
 220 (define (make-procedure parameters body env)
 221   (list 'procedure parameters body env))
 222 (define (compound-procedure? p)
 223   (tagged-list? p 'procedure))
 224 (define (procedure-parameters p) (cadr p))
 225 (define (procedure-body p) (caddr p))
 226 (define (procedure-environment p) (cadddr p))
 227
 228 (define (enclosing-environment env) (cdr env))
 229 (define (first-frame env) (car env))
 230 (define the-empty-environment '())
 231
 232
 233 (display "make-frame\n")
 234
 235 (define (make-frame variables values)
 236   (cons variables values))
 237 (define (frame-variables frame) (car frame))
 238 (define (frame-values frame) (cdr frame))
 239 (define (add-binding-to-frame! var val frame)
 240   (set-car! frame (cons var (car frame)))
 241   (set-cdr! frame (cons val (cdr frame))))
 242
 243 (display "extend-environment\n")
 244
 245 (define (extend-environment vars vals base-env)
 246   (if (= (length vars) (length vals))
 247     (cons (make-frame vars vals) base-env)
 248     (if (< (length vars) (length vals))
 249       (error "Too many arguments supplied"
 250              vars
 251              vals)
 252       (error "Too few arguments supplied"
 253              vars
 254              vals))))
 255
 256 (display "lookup-variable\n")
 257
 258 (define (lookup-variable-value var env)
 259   (define (env-loop env)
 260     (define (scan vars vals)
 261       (cond ((null? vars)
 262              (env-loop
 263                (enclosing-environment env)))
 264             ((eq? var (car vars))
 265              (car vals))
 266             (else (scan (cdr vars)
 267                         (cdr vals)))))
 268     (if (eq? env the-empty-environment)
 269       (error "Unbound variable" var)
 270       (let ((frame (first-frame env)))
 271         (scan (frame-variables frame)
 272               (frame-values frame)))))
 273   (env-loop env))
 274
 275 (display "set-variable\n")
 276
 277 (define (set-variable-value! var val env)
 278   (define (env-loop env)
 279     (define (scan vars vals)
 280       (cond ((null? vars)
 281              (env-loop
 282                (enclosing-environment env)))
 283             ((eq? var (car vars))
 284              (set-car! vals val))
 285             (else (scan (cdr vars)
 286                         (cdr vals)))))
 287     (if (eq? env the-empty-environment)
 288       (error "Unbound variable: SET!" var)
 289       (let ((frame (first-frame env)))
 290         (scan (frame-variables frame)
 291               (frame-values frame)))))
 292   (env-loop env))
 293
 294 (display "define-variable\n")
 295
 296 (define (define-variable! var val env)
 297   (let ((frame (first-frame env)))
 298     (define (scan vars vals)
 299       (cond ((null? vars)
 300              (add-binding-to-frame!
 301                var val frame))
 302             ((eq? var (car vars))
 303              (set-car! vals val))
 304             (else (scan (cdr vars)
 305                         (cdr vals)))))
 306     (scan (frame-variables frame)
 307           (frame-values frame))))
 308
 309 (display "setup-environment...\n")
 310
 311 (define (setup-environment)
 312   (let ((initial-env
 313           (extend-environment
 314             (primitive-procedure-names)
 315             (primitive-procedure-objects)
 316             the-empty-environment)))
 317     (define-variable! 'true true initial-env)
 318     (define-variable! 'false false initial-env)
 319     initial-env))
 320
 321 (define (primitive-procedure? proc)
 322   (tagged-list? proc 'primitive))
 323
 324 (define (primitive-implementation proc)
 325   (cadr proc))
 326
 327 (define primitive-procedures
 328   (list (list 'car car)
 329         (list 'cdr cdr)
 330         (list 'cons cons)
 331         (list 'null? null?)
 332         (list '+ +)
 333         (list '- -)
 334         (list '* *)))
 335
 336 (define (primitive-procedure-names)
 337   (map car primitive-procedures))
 338
 339 (define (primitive-procedure-objects)
 340   (map (lambda (proc)
 341          (list 'primitive (cadr proc)))
 342        primitive-procedures))
 343
 344
 345
 346 (define (apply-primitive-procedure proc args)
 347     (apply-in-underlying-scheme
 348          (primitive-implementation proc) args))
 349
 350 (define input-prompt  ";;; M-Eval input:")
 351 (define output-prompt ";;; M-Eval value:")
 352
 353
 354 (display "driver-loop...\n")
 355
 356
 357 (define (driver-loop)
 358   (prompt-for-input input-prompt)
 359   (let ((input (read)))
 360     (let ((output
 361             (eval input
 362                   the-global-environment)))
 363       (announce-output output-prompt)
 364       (user-print output)))
 365   (driver-loop))
 366
 367 (define (prompt-for-input string)
 368   (newline) (newline)
 369   (display string) (newline))
 370
 371 (define (announce-output string)
 372   (newline) (display string) (newline))
 373
 374 (define (user-print object)
 375   (if (compound-procedure? object)
 376     (display
 377       (list 'compound-procedure
 378             (procedure-parameters object)
 379             (procedure-body object)
 380             '<procedure-env>))
 381     (display object)))
 382
 383 (define the-global-environment
 384   (setup-environment))