home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 January / macformat-020.iso / Shareware City / Developers / SIOD 3.0 / siod.scm < prev    next >
Encoding:
Text File  |  1994-10-01  |  7.9 KB  |  352 lines  |  [TEXT/ttxt]
  1. ;; SIOD: Scheme In One Defun                                    -*-mode:lisp-*-
  2. ;;
  3. ;; *                        COPYRIGHT (c) 1989-1994 BY                       *
  4. ;; *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.      *
  5. ;; *        See the source file SLIB.C for more information.                 *
  6.  
  7. (puts  ";; Optional Runtime Library for Release 3.0
  8. ")
  9.  
  10. (set! *after-gc* '(if (< (gc-info 4) 5000) (allocate-heap)))
  11.  
  12. (define list (lambda n n))
  13.  
  14. (define (sublis l exp)
  15.   (if (cons? exp)
  16.       (cons (sublis l (car exp))
  17.         (sublis l (cdr exp)))
  18.       (let ((cell (assq exp l)))
  19.     (if cell (cdr cell) exp))))
  20.  
  21. (define (caar x) (car (car x)))
  22. (define (cadr x) (car (cdr x)))
  23. (define (cdar x) (cdr (car x)))
  24. (define (cddr x) (cdr (cdr x)))
  25.  
  26. (define (caddr x) (car (cdr (cdr x))))
  27. (define (cdddr x) (cdr (cdr (cdr x))))
  28.  
  29. (define consp pair?)
  30.  
  31. (define (replace before after)
  32.   (set-car! before (car after))
  33.   (set-cdr! before (cdr after))
  34.   after)
  35.  
  36. (define (prognify forms)
  37.   (if (null? (cdr forms))
  38.       (car forms)
  39.     (cons 'begin forms)))
  40.  
  41. (define (defmac-macro form)
  42.   (let ((sname (car (cadr form)))
  43.     (argl (cdr (cadr form)))
  44.     (fname nil)
  45.     (body (prognify (cddr form))))
  46.     (set! fname (symbolconc sname '-macro))
  47.     (list 'begin
  48.       (list 'define (cons fname argl)
  49.         (list 'replace (car argl) body))
  50.       (list 'define sname (list 'quote fname)))))
  51.  
  52. (define defmac 'defmac-macro)
  53.  
  54. (defmac (push form)
  55.   (list 'set! (caddr form)
  56.     (list 'cons (cadr form) (caddr form))))
  57.  
  58. (defmac (pop form)
  59.   (list 'let (list (list 'tmp (cadr form)))
  60.     (list 'set! (cadr form) '(cdr tmp))
  61.     '(car tmp)))
  62.  
  63. (defmac (defvar form)
  64.   (list 'or
  65.     (list 'symbol-bound? (list 'quote (cadr form)))
  66.     (list 'define (cadr form) (caddr form))))
  67.  
  68. (defmac (defun form)
  69.   (cons 'define
  70.     (cons (cons (cadr form) (caddr form))
  71.           (cdddr form))))
  72.  
  73. (defmac (setq form)
  74.   (let ((l (cdr form))
  75.     (result nil))
  76.     (define (loop)
  77.       (if l
  78.       (begin (push (list 'set! (car l) (cadr l)) result)
  79.          (set! l (cddr l))
  80.          (loop))))
  81.     (loop)
  82.     (prognify (reverse result))))
  83.   
  84.   
  85. (define progn begin)
  86.  
  87. (define the-empty-stream ())
  88.  
  89. (define empty-stream? null?)
  90.  
  91. (define (*cons-stream head tail-future)
  92.   (list head () () tail-future))
  93.  
  94. (define head car)
  95.  
  96. (define (tail x)
  97.   (if (car (cdr x))
  98.       (car (cdr (cdr x)))
  99.       (let ((value ((car (cdr (cdr (cdr x)))))))
  100.     (set-car! (cdr x) t)
  101.     (set-car! (cdr (cdr x)) value))))
  102.  
  103. (defmac (cons-stream form)
  104.   (list '*cons-stream
  105.     (cadr form)
  106.     (list 'lambda () (caddr form))))
  107.  
  108. (define (enumerate-interval low high)
  109.   (if (> low high)
  110.       the-empty-stream
  111.       (cons-stream low (enumerate-interval (+ low 1) high))))
  112.  
  113. (define (print-stream-elements x)
  114.   (if (empty-stream? x)
  115.       ()
  116.       (begin (print (head x))
  117.          (print-stream-elements (tail x)))))
  118.  
  119. (define (sum-stream-elements x)
  120.   (define (loop acc x)
  121.     (if (empty-stream? x)
  122.     acc
  123.       (loop (+ (head x) acc) (tail x))))
  124.   (loop 0 x))
  125.  
  126. (define (standard-fib x)
  127.   (if (< x 2)
  128.       x
  129.       (+ (standard-fib (- x 1))
  130.      (standard-fib (- x 2)))))
  131.  
  132. (define (call-with-current-continuation fcn)
  133.   (let ((tag (cons nil nil)))
  134.     (*catch tag
  135.         (fcn (lambda (value)
  136.            (*throw tag value))))))
  137.  
  138. (define (loop-test n f)
  139.   (let ((j 0)
  140.     (k 0)
  141.     (m 0)
  142.     (result nil))
  143.     (while (< j n)
  144.       (setq j (+ 1 j))
  145.       (setq k 0)
  146.       (while (< k 99)
  147.     (setq k (+ k 1))
  148.     (setq m 0)
  149.     (while (< m 99)
  150.       (setq m (+ m 1))
  151.       (if f (setq result (cons nil result))))))
  152.     result))
  153.  
  154.  
  155. (defun atom (x)
  156.   (not (consp x)))
  157.  
  158. (define eq eq?)
  159.  
  160. (defmac (cond form)
  161.   (cond-convert (cdr form)))
  162.  
  163. (define null null?)
  164.  
  165. (defun cond-convert (l)
  166.   (if (null l)
  167.       ()
  168.     (if (null (cdar l))
  169.     (if (null (cdr l))
  170.         (caar l)
  171.       (let ((rest (cond-convert (cdr l))))
  172.         (if (and (consp rest) (eq (car rest) 'or))
  173.         (cons 'or (cons (caar l) (cdr rest)))
  174.           (list 'or (caar l) rest))))
  175.       (if (or (eq (caar l) 't)
  176.           (and (consp (caar l)) (eq (car (caar l)) 'quote)))
  177.       (prognify (cdar l))
  178.     (list 'if
  179.           (caar l)
  180.           (prognify (cdar l))
  181.           (cond-convert (cdr l)))))))
  182.  
  183. (defmac (+internal-comma form)
  184.   (error 'comma-not-inside-backquote))
  185.  
  186. (define +internal-comma-atsign +internal-comma)
  187. (define +internal-comma-dot +internal-comma)
  188.  
  189. (defmac (+internal-backquote form)
  190.   (backquotify (cdr form)))
  191.  
  192. (defun backquotify (x)
  193.   (let (a d aa ad dqp)
  194.     (cond ((atom x) (list 'quote x))
  195.       ((eq (car x) '+internal-comma) (cdr x))
  196.       ((or (atom (car x))
  197.            (not (or (eq (caar x) '+internal-comma-atsign)
  198.             (eq (caar x) '+internal-comma-dot))))
  199.        (setq a (backquotify (car x)) d (backquotify (cdr x))
  200.          ad (atom d) aa (atom a)
  201.          dqp (and (not ad) (eq (car d) 'quote)))
  202.        (cond ((and dqp (not (atom a)) (eq (car a) 'quote))
  203.           (list 'quote (cons (cadr a) (cadr d))))
  204.          ((and dqp (null (cadr d)))
  205.           (list 'list a))
  206.          ((and (not ad) (eq (car d) 'list))
  207.           (cons 'list (cons a (cdr d))))
  208.          (t (list 'cons a d))))
  209.       ((eq (caar x) '+internal-comma-atsign)
  210.        (list 'append (cdar x) (backquotify (cdr x))))
  211.       ((eq (caar x) '+internal-comma-dot)
  212.        (list 'nconc (cdar x)(backquotify (cdr x)))))))
  213.  
  214.  
  215. (defun append n
  216.   (appendl n))
  217.  
  218. (defun appendl (l)
  219.   (cond ((null l) nil)
  220.     ((null (cdr l)) (car l))
  221.     ((null (cddr l))
  222.      (append2 (car l) (cadr l)))
  223.     ('else
  224.      (append2 (car l) (appendl (cdr l))))))
  225.  
  226. (defun append2 (a b)
  227.   (if (null a)
  228.       b
  229.     (cons (car a) (append2 (cdr a) b))))
  230.  
  231. (defun rplacd (a b)
  232.   (set-cdr! a b)
  233.   a)
  234.  
  235. (defun nconc (a b)
  236.   (if (null a)
  237.       b
  238.     (rplacd (last a) b)))
  239.  
  240.  
  241. (defun last (a)
  242.   (cond ((null a) (error'null-arg-to-last))
  243.     ((null (cdr a)) a)
  244.     ((last (cdr a)))))
  245.  
  246. (define sfib
  247.   (eval `(lambda (x)
  248.        (,if (,< x 2)
  249.            x
  250.          (,+ (sfib (,- x 1))
  251.          (sfib (,- x 2)))))))
  252. (define sloop-test
  253.   (eval `(lambda (n f)
  254.        (let ((j 0)
  255.          (k 0)
  256.          (m 0)
  257.          (result nil))
  258.          (,while (,< j n)
  259.            (,set! j (,+ 1 j))
  260.            (,set! k 0)
  261.            (,while (,< k 99)
  262.          (,set! k (,+ k 1))
  263.          (,set! m 0)
  264.          (,while (,< m 99)
  265.            (,set! m (,+ m 1))
  266.            (,if f (,set! result (,cons () result))))))
  267.          result))))
  268.  
  269. (defvar *fasdump-hash* t)
  270.  
  271. (defun fasl-open (filename mode)
  272.   (list (fopen filename mode)
  273.     (if (or (equal? mode "rb") *fasdump-hash*)
  274.         (cons-array 100))
  275.     ;; If this is set NIL, then already hashed symbols will be
  276.     ;; optimized, and additional ones will not.
  277.     0))
  278.  
  279. (defun fasl-close (table)
  280.   (fclose (car table)))
  281.  
  282. (defun fasload args
  283.   (let ((filename (car args))
  284.     (head (and (cadr args) (cons nil nil))))
  285.     (let ((table (fasl-open filename "rb"))
  286.       (exp)
  287.       (tail head))
  288.       (while (not (eq table (setq exp (fast-read table))))
  289.     (cond (head
  290.            (setq exp (cons exp nil))
  291.            (set-cdr! tail exp)
  292.            (setq tail exp))
  293.           ('else
  294.            (eval exp))))
  295.       (fasl-close table)
  296.       (and head (cdr head)))))
  297.  
  298. (defun fasdump (filename forms)
  299.   (let ((table (fasl-open filename "wb"))
  300.     (l forms))
  301.     (while l
  302.       (fast-print (car l) table)
  303.       (setq l (cdr l)))
  304.     (fasl-close table)))
  305.  
  306. (defun compile-file (filename)
  307.   (let ((forms (load (string-append filename ".scm") t)))
  308.     (puts "Saving forms
  309. ")
  310.     (fasdump (string-append filename ".bin")
  311.          forms)))
  312.  
  313. (defvar *properties* (cons-array 100))
  314.  
  315. (defun get (sym key)
  316.   (cdr (assq key (href *properties* sym))))
  317.  
  318. (defun putprop (sym val key)
  319.   (let ((alist (href *properties* sym)))
  320.     (let ((cell (assq key alist)))
  321.       (cond (cell
  322.          (set-cdr! cell val))
  323.         ('else
  324.          (hset *properties* sym (cons (cons key val) alist))
  325.          val)))))
  326.  
  327. (define (mapcar1 f l1)
  328.   (and l1 (cons (f (car l1)) (mapcar1 f (cdr l1)))))
  329.  
  330.  
  331. (define (mapcar2 f l1 l2)
  332.   (and l1 l2 (cons (f (car l1) (car l2)) (mapcar2 f (cdr l1) (cdr l2)))))
  333.  
  334. (define (mapcar . args)
  335.   (cond ((null args)
  336.      (error "too few arguments"))
  337.     ((null (cdr args))
  338.      (error "too few arguments"))
  339.     ((null (cdr (cdr args)))
  340.      (mapcar1 (car args) (car (cdr args))))
  341.     ((null (cdr (cdr (cdr args))))
  342.      (mapcar2 (car args) (car (cdr args)) (car (cdr (cdr args)))))
  343.     ('else
  344.      (error "two many arguments"))))
  345.     
  346.      
  347. (defun addl (l)
  348.   (let ((sum 0))
  349.     (while l
  350.       (setq sum (+ sum (pop l))))
  351.     sum))
  352.