examples/metacirc.scm

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