examples/metacirc.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Mandatory SICP Metacircular Evaluator ;;
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 (define apply-in-underlying-scheme apply)
   6 (define true #t)
   7 (define false #f)
   8
   9 ;; Verbatim code from SICP
  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 (eval-definition exp env)
  90   (define-variable!
  91     (definition-variable exp)
  92     (eval (definition-value exp) env)
  93     env)
  94   'ok)
  95
  96 (define (self-evaluating? exp)
  97   (cond ((number? exp) true)
  98         ((string? exp) true)
  99         (else false)))
 100
 101 (define (variable? exp) (symbol? exp))
 102
 103 (define (quoted? exp)
 104   (tagged-list? exp 'quote))
 105
 106 (define (text-of-quotation exp)
 107   (cadr exp))
 108
 109 (define (tagged-list? exp tag)
 110   (if (pair? exp)
 111     (eq? (car exp) tag)
 112     false))
 113
 114 (define (assignment? exp)
 115   (tagged-list? exp 'set!))
 116
 117 (define (assignment-variable exp)
 118   (cadr exp))
 119
 120 (define (assignment-value exp) (caddr exp))
 121
 122 (define (definition? exp)
 123   (tagged-list? exp 'define))
 124
 125 (define (definition-variable exp)
 126   (if (symbol? (cadr exp))
 127     (cadr exp)
 128     (caadr exp)))
 129
 130 (define (definition-value exp)
 131   (if (symbol? (cadr exp))
 132     (caddr exp)
 133     (make-lambda
 134       (cdadr exp)   ; formal parameters
 135       (cddr exp)))) ; body
 136
 137
 138 (define (lambda? exp)
 139   (tagged-list? exp 'lambda))
 140 (define (lambda-parameters exp) (cadr exp))
 141 (define (lambda-body exp) (cddr exp))
 142
 143 (define (make-lambda parameters body)
 144     (cons 'lambda (cons parameters body)))
 145
 146 (define (if? exp) (tagged-list? exp 'if))
 147 (define (if-predicate exp) (cadr exp))
 148 (define (if-consequent exp) (caddr exp))
 149 (define (if-alternative exp)
 150   (if (not (null? (cdddr exp)))
 151     (cadddr exp)
 152     'false))
 153
 154 (define (make-if predicate
 155                  consequent
 156                  alternative)
 157   (list 'if
 158         predicate
 159         consequent
 160         alternative))
 161
 162 (define (begin? exp)
 163   (tagged-list? exp 'begin))
 164 (define (begin-actions exp) (cdr exp))
 165 (define (last-exp? seq) (null? (cdr seq)))
 166 (define (first-exp seq) (car seq))
 167 (define (rest-exps seq) (cdr seq))
 168
 169 (define (sequence->exp seq)
 170   (cond ((null? seq) seq)
 171         ((last-exp? seq) (first-exp seq))
 172         (else (make-begin seq))))
 173
 174 (define (make-begin seq) (cons 'begin seq))
 175
 176 (define (application? exp) (pair? exp))
 177 (define (operator exp) (car exp))
 178 (define (operands exp) (cdr exp))
 179 (define (no-operands? ops) (null? ops))
 180 (define (first-operand ops) (car ops))
 181 (define (rest-operands ops) (cdr ops))
 182
 183
 184 (define (cond? exp)
 185   (tagged-list? exp 'cond))
 186 (define (cond-clauses exp) (cdr exp))
 187 (define (cond-else-clause? clause)
 188   (eq? (cond-predicate clause) 'else))
 189 (define (cond-predicate clause)
 190   (car clause))
 191 (define (cond-actions clause)
 192   (cdr clause))
 193 (define (cond->if exp)
 194   (expand-clauses (cond-clauses exp)))
 195 (define (expand-clauses clauses)
 196   (if (null? clauses)
 197     'false     ; no else clause
 198     (let ((first (car clauses))
 199           (rest (cdr clauses)))
 200       (if (cond-else-clause? first)
 201         (if (null? rest)
 202           (sequence->exp
 203             (cond-actions first))
 204           (error "ELSE clause isn't last: COND->IF"
 205           clauses))
 206       (make-if (cond-predicate first)
 207                (sequence->exp
 208                  (cond-actions first))
 209                (expand-clauses
 210                  rest))))))
 211
 212
 213 (define (true? x)
 214   (not (eq? x false)))
 215
 216 (define (false? x)
 217   (eq? x false))
 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 (define (make-frame variables values)
 234   (cons variables values))
 235 (define (frame-variables frame) (car frame))
 236 (define (frame-values frame) (cdr frame))
 237 (define (add-binding-to-frame! var val frame)
 238   (set-car! frame (cons var (car frame)))
 239   (set-cdr! frame (cons val (cdr frame))))
 240
 241 (define (extend-environment vars vals base-env)
 242   (if (= (length vars) (length vals))
 243     (cons (make-frame vars vals) base-env)
 244     (if (< (length vars) (length vals))
 245       (error "Too many arguments supplied"
 246              vars
 247              vals)
 248       (error "Too few arguments supplied"
 249              vars
 250              vals))))
 251
 252 (define (lookup-variable-value var env)
 253   (define (env-loop env)
 254     (define (scan vars vals)
 255       (cond ((null? vars)
 256              (env-loop
 257                (enclosing-environment env)))
 258             ((eq? var (car vars))
 259              (car vals))
 260             (else (scan (cdr vars)
 261                         (cdr vals)))))
 262     (if (eq? env the-empty-environment)
 263       (error "Unbound variable" var)
 264       (let ((frame (first-frame env)))
 265         (scan (frame-variables frame)
 266               (frame-values frame)))))
 267   (env-loop env))
 268
 269 (define (set-variable-value! var val env)
 270   (define (env-loop env)
 271     (define (scan vars vals)
 272       (cond ((null? vars)
 273              (env-loop
 274                (enclosing-environment env)))
 275             ((eq? var (car vars))
 276              (set-car! vals val))
 277             (else (scan (cdr vars)
 278                         (cdr vals)))))
 279     (if (eq? env the-empty-environment)
 280       (error "Unbound variable: SET!" var)
 281       (let ((frame (first-frame env)))
 282         (scan (frame-variables frame)
 283               (frame-values frame)))))
 284   (env-loop env))
 285
 286 (define (define-variable! var val env)
 287   (let ((frame (first-frame env)))
 288     (define (scan vars vals)
 289       (cond ((null? vars)
 290              (add-binding-to-frame!
 291                var val frame))
 292             ((eq? var (car vars))
 293              (set-car! vals val))
 294             (else
 295                 (scan (cdr vars)
 296                         (cdr vals)))))
 297     (scan (frame-variables frame)
 298           (frame-values frame))))
 299
 300 (define (setup-environment)
 301   (let ((initial-env
 302           (extend-environment
 303             (primitive-procedure-names)
 304             (primitive-procedure-objects)
 305             the-empty-environment)))
 306     (define-variable! 'true true initial-env)
 307     (define-variable! 'false false initial-env)
 308     initial-env))
 309
 310
 311 (define (primitive-procedure? proc)
 312   (tagged-list? proc 'primitive))
 313
 314 (define (primitive-implementation proc)
 315   (cadr proc))
 316
 317 (define primitive-procedures
 318   (list (list 'car car)
 319         (list 'cdr cdr)
 320         (list 'cons cons)
 321         (list 'null? null?)
 322         (list '+ +)
 323         (list '- -)
 324         (list '* *)))
 325
 326 (define (primitive-procedure-names)
 327   (map car primitive-procedures))
 328
 329 (define (primitive-procedure-objects)
 330   (map (lambda (proc)
 331          (list 'primitive (cadr proc)))
 332        primitive-procedures))
 333
 334 (define (apply-primitive-procedure proc args)
 335     (apply-in-underlying-scheme
 336          (primitive-implementation proc) args))
 337
 338 (define input-prompt  ";;; M-Eval input:")
 339 (define output-prompt ";;; M-Eval value:")
 340
 341
 342 (define (driver-loop)
 343   (prompt-for-input input-prompt)
 344   (let ((input (read)))
 345     (let ((output
 346             (eval input
 347                   the-global-environment)))
 348       (announce-output output-prompt)
 349       (user-print output)))
 350   (driver-loop))
 351
 352 (define (prompt-for-input string)
 353   (newline) (newline)
 354   (display string) (newline))
 355
 356 (define (announce-output string)
 357   (newline) (display string) (newline))
 358
 359 (define (user-print object)
 360   (if (compound-procedure? object)
 361     (display
 362       (list 'compound-procedure
 363             (procedure-parameters object)
 364             (procedure-body object)
 365             '<procedure-env>))
 366     (display object)))
 367
 368
 369 (define the-global-environment (setup-environment))
 370
 371 (driver-loop)