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