home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / SICP.SCM < prev    next >
Text File  |  1992-06-17  |  3KB  |  114 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Compatibility mode for use with Abelson & Sussman's book,
  4. ; Structure and Interpretation of Computer Programs.
  5.  
  6. ; Incompatible change to the meanings of AND and OR
  7.  
  8. (define (and . rest)
  9.   (let loop ((rest rest))
  10.     (if (null? rest)
  11.     #t
  12.     (if (car rest)
  13.         (loop (cdr rest))
  14.         #f))))
  15.  
  16. (define (or . rest)
  17.   (let loop ((rest rest))
  18.     (if (null? rest)
  19.     #f
  20.     (let ((temp (car rest)))
  21.       (if temp
  22.           temp
  23.           (loop (cdr rest)))))))
  24.  
  25. ; Misc. nonsense
  26.  
  27. (define-syntax sequence
  28.   (syntax-rules ()
  29.     ((sequence form ...) (begin form ...))))
  30.  
  31. (define mapcar map)
  32. (define mapc for-each)
  33.  
  34. (define (1+ x) (+ x 1))
  35. (define (-1+ x) (- x 1))
  36.  
  37. (define t #t)
  38. (define nil #f)
  39. (define (atom? x) (not (pair? x)))
  40.  
  41. (define (print x)
  42.   (write x)
  43.   (newline))
  44. (define princ display)
  45. (define prin1 write)
  46. (define error (access-scheme48 'error))
  47.  
  48. ; Streams
  49.  
  50. (define-syntax cons-stream
  51.   (syntax-rules ()
  52.     ((cons-stream head tail)
  53.      (cons head (delay tail)))))
  54.  
  55. (define head car)
  56. (define (tail s) (force (cdr s)))
  57. (define the-empty-stream '<the-empty-stream>)
  58. (define (empty-stream? s) (eq? s the-empty-stream))
  59.  
  60. ; EXPLODE and IMPLODE
  61.  
  62. (define (explode thing)
  63.   (map (lambda (c) (string->symbol (string c)))
  64.        (string->list (cond ((symbol? thing)
  65.                 (symbol->string thing))
  66.                ((number? thing)
  67.                 (number->string thing))
  68.                (else
  69.                 (error "invalid argument to explode" thing))))))
  70.  
  71. (define (implode l)
  72.   (string->symbol (list->string (map (lambda (s)
  73.                        (string-ref (symbol->string s) 0))
  74.                      l))))
  75.  
  76. ; GET and PUT
  77.  
  78. (define (make-property-module)
  79.   (define make-table (access-scheme48 'make-table))
  80.   (define table-ref  (access-scheme48 'table-ref))
  81.   (define table-set! (access-scheme48 'table-set!))
  82.   (define symbol-properties-table #f)
  83.  
  84.   (define (put symbol indicator value)
  85.     (let* ((probe (table-ref symbol-properties-table symbol))
  86.        (table (if probe
  87.               probe
  88.               (let ((table (make-table)))
  89.             (table-set! symbol-properties-table symbol table)
  90.             table))))
  91.       (table-set! table indicator value)))
  92.  
  93.   (define (get symbol indicator)
  94.     (let ((probe (table-ref symbol-properties-table symbol)))
  95.       (if probe
  96.       (table-ref probe indicator)
  97.       #f)))
  98.  
  99.   (set! symbol-properties-table (make-table))
  100.  
  101.   (cons get put))
  102.           
  103. (define property-module (make-property-module))
  104. (define get (car property-module))
  105. (define put (cdr property-module))
  106.  
  107. ; Need these special forms:
  108. ;   collect make-environment access the-environment
  109.  
  110. ; The following are among the procedures defined in MIT's student
  111. ; system; I don't know how many are actually needed for the book:
  112. ;   ascii char nth nthcdr tyo vector-cons
  113. ;   accumulate filter map-stream append-streams
  114.