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