home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume15 / siod / siod.scm < prev   
Text File  |  1988-06-06  |  2KB  |  96 lines
  1. '(SIOD: Scheme In One Defun
  2.   (c) Copyright 1988 George Carrette, gjc@bu-it.bu.edu
  3.   For demonstration purposes only.
  4.   Optional Runtime Library for Release 1.3)
  5.  
  6. (define list (lambda n n))
  7.  
  8. (define (sublis l exp)
  9.   (if (cons? exp)
  10.       (cons (sublis l (car exp))
  11.         (sublis l (cdr exp)))
  12.       (let ((cell (assq exp l)))
  13.     (if cell (cdr cell) exp))))
  14.  
  15. (define (cadr x) (car (cdr x)))
  16. (define (caddr x) (car (cdr (cdr x))))
  17. (define (cdddr x) (cdr (cdr (cdr x))))
  18.  
  19. (define (replace before after)
  20.   (set-car! before (car after))
  21.   (set-cdr! before (cdr after))
  22.   after)
  23.  
  24. (define (push-macro form)
  25.   (replace form
  26.        (list 'set! (caddr form)
  27.          (list 'cons (cadr form) (caddr form)))))
  28.  
  29. (define (pop-macro form)
  30.   (replace form
  31.        (list 'let (list (list 'tmp (cadr form)))
  32.          (list 'set! (cadr form) '(cdr tmp))
  33.          '(car tmp))))
  34.  
  35. (define push 'push-macro)
  36. (define pop 'pop-macro)
  37.  
  38. (define (defvar-macro form)
  39.   (list 'or
  40.     (list 'value-cell (list 'quote (cadr form)))
  41.     (list 'define (cadr form) (caddr form))))
  42.  
  43. (define defvar 'defvar-macro)
  44.  
  45. (define (defun-macro form)
  46.   (cons 'define
  47.     (cons (cons (cadr form) (caddr form))
  48.           (cdddr form))))
  49.  
  50. (define defun 'defun-macro)
  51.        
  52. (define setq set!)
  53. (define progn begin)
  54.  
  55. (define the-empty-stream ())
  56.  
  57. (define empty-stream? null?)
  58.  
  59. (define (*cons-stream head tail-future)
  60.   (list head () () tail-future))
  61.  
  62. (define head car)
  63.  
  64. (define (tail x)
  65.   (if (car (cdr x))
  66.       (car (cdr (cdr x)))
  67.       (let ((value ((car (cdr (cdr (cdr x)))))))
  68.     (set-car! (cdr x) t)
  69.     (set-car! (cdr (cdr x)) value))))
  70.  
  71. (define (cons-stream-macro form)
  72.   (replace form
  73.        (list '*cons-stream
  74.          (cadr form)
  75.          (list 'lambda () (caddr form)))))
  76.  
  77. (define cons-stream 'cons-stream-macro)
  78.  
  79. (define (enumerate-interval low high)
  80.   (if (> low high)
  81.       the-empty-stream
  82.       (cons-stream low (enumerate-interval (+ low 1) high))))
  83.  
  84. (define (print-stream-elements x)
  85.   (if (empty-stream? x)
  86.       ()
  87.       (begin (print (head x))
  88.          (print-stream-elements (tail x)))))
  89.  
  90. (define (standard-fib x)
  91.   (if (< x 2)
  92.       x
  93.       (+ (standard-fib (- x 1))
  94.      (standard-fib (- x 2)))))
  95.  
  96.