sicp.scm (8782B) [raw]
1 #!/usr/local/bin/chicken-csi -ss 2 ;; sicp.scm -- pretty much verbatim the SICP version 3 ;; (with a few extensions / CHICKEN-isms) 4 ;; 5 ;; SICP is licensed under the CC-BY-SA [1] [2], so this code 6 ;; is licensed similarly. 7 ;; 8 ;; [1]: http://creativecommons.org/licenses/by-sa/4.0/ 9 ;; [2]: https://mitp-content-server.mit.edu/books/content/sectbyfn/books_pres_0/6515/sicp.zip/index.html 10 (import (chicken io)) 11 12 (define (_eval expr env) 13 (cond 14 ((self-evaluating? expr) expr) 15 ((variable? expr) (lookup-variable-value expr env)) 16 ((quoted? expr) (text-of-quotation expr)) 17 ((assignment? expr) (eval-assignment expr env)) 18 ((definition? expr) (eval-definition expr env)) 19 ((if? expr) (eval-if expr env)) 20 ((lambda? expr) 21 (make-procedure (lambda-parameters expr) 22 (lambda-body expr) 23 env)) 24 ((begin? expr) 25 (eval-sequence (begin-actions expr) env)) 26 ((cond? expr) (_eval (cond->if expr) env)) 27 ((application? expr) 28 (_apply (_eval (operator expr) env) 29 (map (lambda (o) (_eval o env)) (operands expr)))) 30 (else 31 (error "Unknown expr type -- EVAL" expr)))) 32 33 (define (_apply proc args) 34 (cond 35 ((primitive-procedure? proc) 36 (apply-primitive-procedure proc args)) 37 ((compound-procedure? proc) 38 (eval-sequence 39 (procedure-body proc) 40 (extend-environment 41 (procedure-parameters proc) 42 args 43 (procedure-environment proc)))) 44 (else (error "Unknown proc type -- APPLY" proc)))) 45 46 (define (eval-if expr env) 47 (if (true? (_eval (if-predicate expr) env)) 48 (_eval (if-consequent expr) env) 49 (_eval (if-alternative expr) env))) 50 51 (define (eval-sequence exprs env) 52 (cond 53 ((last-exp? exprs) (_eval (first-exp exprs) env)) 54 (else (_eval (first-exp exprs) env) 55 (eval-sequence (rest-exps exprs) env)))) 56 57 (define (eval-assignment expr env) 58 (set-variable-value! (assignment-variable expr) 59 (_eval (assignment-value expr) env) 60 env) 61 'ok) 62 63 (define (eval-definition expr env) 64 (define-variable! (definition-variable expr) 65 (_eval (definition-value expr) env) 66 env) 67 'ok) 68 69 (define (self-evaluating? expr) 70 (cond ((number? expr) #t) 71 ((string? expr) #t) 72 (else #f))) 73 74 (define (variable? expr) (symbol? expr)) 75 76 (define (tagged-list? l sym) 77 (and (pair? l) (eq? (car l) sym))) 78 79 (define (quoted? expr) 80 (tagged-list? expr 'quote)) 81 82 (define (text-of-quotation expr) (cadr expr)) 83 84 (define (assignment? expr) 85 (tagged-list? expr 'set!)) 86 87 (define (assignment-variable expr) (cadr expr)) 88 89 (define (assignment-value expr) (caddr expr)) 90 91 (define (definition? expr) 92 (tagged-list? expr 'define)) 93 94 (define (definition-variable expr) 95 (if (symbol? (cadr expr)) 96 (cadr expr) 97 (caadr expr))) 98 99 (define (definition-value expr) 100 (if (symbol? (cadr expr)) 101 (caddr expr) 102 (make-lambda (cdadr expr) (cddr expr)))) 103 104 (define (lambda? expr) (tagged-list? expr 'lambda)) 105 106 (define (lambda-parameters expr) (cadr expr)) 107 108 (define (lambda-body expr) (cddr expr)) 109 110 (define (make-lambda parameters body) 111 ;; `(lambda ,parameters ,@body)) ? 112 (cons 'lambda (cons parameters body))) 113 114 (define (if? expr) (tagged-list? expr 'if)) 115 116 (define (if-predicate expr) (cadr expr)) 117 118 (define (if-consequent expr) (caddr expr)) 119 120 (define (if-alternative expr) 121 (if (not (null? (cdddr expr))) 122 (cadddr expr) 123 'false)) 124 125 (define (make-if predicate consequent alternative) 126 (list 'if predicate consequent alternative)) 127 128 (define (begin? expr) (tagged-list? expr 'begin)) 129 130 (define (begin-actions expr) (cdr expr)) 131 132 (define (last-exp? seq) (null? (cdr seq))) 133 134 (define (first-exp seq) (car seq)) 135 136 (define (rest-exps seq) (cdr seq)) 137 138 (define (sequence->exp seq) 139 (cond ((null? seq) seq) 140 ((last-exp? seq) (first-exp seq)) 141 (else (make-begin seq)))) 142 143 (define (make-begin seq) (cons 'begin seq)) 144 145 (define (application? expr) (pair? expr)) 146 147 (define (operator expr) (car expr)) 148 149 (define (operands expr) (cdr expr)) 150 151 (define (no-operands? ops) (null? ops)) 152 153 (define (first-operand ops) (car ops)) 154 155 (define (rest-operands ops) (cdr ops)) 156 157 (define (cond? expr) (tagged-list? expr 'cond)) 158 159 (define (cond-clauses expr) (cdr expr)) 160 161 (define (cond-else-clause? clause) 162 (eq? (cond-predicate clause) 'else)) 163 164 (define (cond-predicate clause) (car clause)) 165 166 (define (cond-actions clause) (cdr clause)) 167 168 (define (cond->if expr) 169 (expand-clauses (cond-clauses expr))) 170 171 (define (expand-clauses clauses) 172 (if (null? clauses) 173 'false 174 (let ((first (car clauses)) 175 (rest (cdr clauses))) 176 (if (cond-else-clause? first) 177 (if (null? rest) 178 (sequence->exp (cond-actions first)) 179 (error "ELSE clause isn't last -- COND->IF" clauses)) 180 (make-if (cond-predicate first) 181 (sequence->exp (cond-actions first)) 182 (expand-clauses rest)))))) 183 184 (define (true? x) (not (false? x))) 185 186 (define (false? x) (eq? x #f)) 187 188 (define (make-procedure params body env) 189 (list 'procedure params body env)) 190 191 (define (compound-procedure? p) 192 (tagged-list? p 'procedure)) 193 194 (define (procedure-parameters p) (cadr p)) 195 196 (define (procedure-body p) (caddr p)) 197 198 (define (procedure-environment p) (cadddr p)) 199 200 (define (enclosing-environment env) (cdr env)) 201 202 (define (first-frame env) (car env)) 203 204 (define the-empty-env '()) 205 206 (define (make-frame vars vals) 207 (cons vars vals)) 208 209 (define (frame-variables f) (car f)) 210 211 (define (frame-values f) (cdr f)) 212 213 (define (add-binding-to-frame! var val frame) 214 (set-car! frame (cons var (car frame))) 215 (set-cdr! frame (cons val (cdr frame)))) 216 217 (define (extend-environment vars vals base-env) 218 (if (= (length vars) (length vals)) 219 (cons (make-frame vars vals) base-env) 220 (if (< (length vars) (length vals)) 221 (error "Too many arguments supplied" vars vals) 222 (error "Too few arguments supplied" vars vals)))) 223 224 (define (lookup-variable-value var env) 225 (define (env-lookup env) 226 (define (scan vars vals) 227 (cond ((null? vars) 228 (env-lookup (enclosing-environment env))) 229 ((eq? var (car vars)) 230 (car vals)) 231 (else (scan (cdr vars) (cdr vals))))) 232 (if (eq? env the-empty-env) 233 (error "Unbound variable" var) 234 (let ((frame (first-frame env))) 235 (scan (frame-variables frame) 236 (frame-values frame))))) 237 (env-lookup env)) 238 239 240 (define (set-variable-value! var val env) 241 (define (env-loop env) 242 (define (scan vars vals) 243 (cond ((null? vars) 244 (env-loop (enclosing-environment env))) 245 ((eq? var (car vars)) 246 (set-car! vals val)) 247 (else (scan (cdr vars) (cdr vals))))) 248 (if (eq? env the-empty-env) 249 (error "Unbound variable -- SET!" var) 250 (let ((frame (first-frame env))) 251 (scan (frame-variables frame) 252 (frame-values frame))))) 253 (env-loop env)) 254 255 256 (define (define-variable! var val env) 257 (let ((frame (first-frame env))) 258 (define (scan vars vals) 259 (cond ((null? vars) 260 (add-binding-to-frame! var val frame)) 261 ((eq? var (car vars)) 262 (set-car! vals val)) 263 (else (scan (cdr vars) (cdr vals))))) 264 (scan (frame-variables frame) (frame-values frame)))) 265 266 (define (setup-environment) 267 (let ((initial-env 268 (extend-environment (primitive-procedure-names) 269 (primitive-procedure-objects) 270 the-empty-env))) 271 (define-variable! 'true #t initial-env) 272 (define-variable! 'false #f initial-env) 273 initial-env)) 274 275 276 (define (primitive-procedure? proc) 277 (tagged-list? proc 'primitive)) 278 279 (define (primitive-implementation proc) (cadr proc)) 280 281 (define primitive-procedures 282 `((car ,car) 283 (cdr ,cdr) 284 (cons ,cons) 285 (null? ,null?) 286 (< ,<) 287 (<= ,<=) 288 (> ,>) 289 (>= ,>=) 290 (= ,=) 291 (+ ,+) 292 (* ,*) 293 (- ,-) 294 (/ ,/))) 295 296 (define (primitive-procedure-names) 297 (map car primitive-procedures)) 298 299 300 (define (primitive-procedure-objects) 301 (map (lambda (proc) (list 'primitive (cadr proc))) 302 primitive-procedures)) 303 304 (define the-global-env (setup-environment)) 305 306 (define (apply-primitive-procedure proc args) 307 (apply (primitive-implementation proc) args)) 308 309 (define input-prompt "#;> ") 310 311 (define (user-print object) 312 (if (compound-procedure? object) 313 (print (list 'compound-procedure 314 (procedure-parameters object) 315 (procedure-body object) 316 '<procedure-env>)) 317 (print object))) 318 319 (define (driver-loop) 320 (display input-prompt) 321 (let ((input (read))) 322 (if (not (eof-object? input)) 323 (begin 324 (user-print (_eval input the-global-env)) 325 (driver-loop))))) 326 327 (define (main args) 328 (driver-loop))