home *** CD-ROM | disk | FTP | other *** search
/ Archive Magazine CD 1995 / Archive Magazine CD 1995.iso / discs / prog_disc / volume_2 / issue_03 / lisp / writefile < prev   
Encoding:
Text File  |  1988-11-09  |  4.7 KB  |  155 lines

  1. %% File writefile2 created at 20:32:48 on 06-Nov-88 %%
  2.  
  3. %%     (c)Simon Brooke 1988     %%
  4.  
  5. (setq addtoset
  6.    '(lambda (obj set)
  7.        (cond ((member obj set) set) (t (nconc set (list obj)))) ))
  8.  
  9. (setq flatten
  10.    '(lambda (l)
  11.        (cond
  12.           ((null l) nil)
  13.           ((atom l) (list l))
  14.           (t (nconc (flatten (car l)) (flatten (cdr l)))) )))
  15.  
  16. (setq remove
  17.    '(lambda (object list)
  18.        (cond
  19.           ((null list) nil)
  20.           ((eq object (car list)) (remove object (cdr list)))
  21.           (t (cons (car list) (remove object (cdr list)))) )))
  22.  
  23. (setq setfromlist
  24.    '(lambda (lst)
  25.        (cond
  26.           ((null lst) nil)
  27.           ((member (car lst) (cdr lst)) (setfromlst (cdrlst)))
  28.           (t (cons (car lst) (setfromlst (cdr lst)))) )))
  29.  
  30. (setq usercalls
  31.    '(lambda (fn)
  32.        (remove nil (mapcar (flatten (userdef fn)) 'userfnp))))
  33.  
  34. (setq userdef
  35.    '(lambda (obj)
  36.        (cond
  37.           ((codep (eval obj)) (get obj 'savedef))
  38.           (t (eval obj)))) )
  39.  
  40. (setq userfnp
  41.    '(lambda (object)
  42.        (cond
  43.           ((eq object '*lambdatokens*) nil)
  44.           ((get object 'savedef) object)
  45.           ((and
  46.               (consp (eval object))
  47.               (member (car (eval object)) *lambdatokens*))
  48.              object))))
  49.  
  50. (setq writefile
  51.    '(lambda (fname objs)
  52.        (let
  53.           ((objects (or objs (get fname 'objects))))
  54.           (cond
  55.              ((null objects)
  56.                 (error 500 "No objects specified for file")))
  57.           (cond
  58.              ((member
  59.                  nil
  60.                  (mapcar
  61.                     objects
  62.                     '(lambda (obj)
  63.                         (get obj 'savedef)
  64.                         (or (boundp obj) (plist obj)))) )
  65.                 (error
  66.                    501
  67.                    "Unbound object specified in file contents")))
  68.           (let
  69.              ((handle (open fname 'output)))
  70.              (cond
  71.                 ((numberp
  72.                     (errorset
  73.                        (progn
  74.                           (print (list fname 'open))
  75.                           (wrs handle)
  76.                           (printc
  77.                              (makestring
  78.                                 "%% File "
  79.                                 fname
  80.                                 " created at "
  81.                                 (timeofday)
  82.                                 " on "
  83.                                 (date)
  84.                                 " %%"))
  85.                           (cond
  86.                              (*copyright*
  87.                                 (terpri)
  88.                                 (princ "%%     (c)")
  89.                                 (princ *copyright*)
  90.                                 (printc "     %%")
  91.                                 (terpri)))
  92.                           (mapcar objects 'writeobject)
  93.                           (terpri)
  94.                           (prettyprint
  95.                              (list
  96.                                 'put
  97.                                 (list 'quote fname)
  98.                                 (list 'quote 'objects)
  99.                                 (list 'quote objects)))
  100.                           (wrs nil)
  101.                           (close handle)
  102.                           (set-date-stamp fname (binary-time)))
  103.                        0))
  104.                    (wrs nil)
  105.                    (close handle)
  106.                    (error 502 "error while writing file"))
  107.                 (t fname))))
  108.        fname))
  109.  
  110. (setq writeobject
  111.    '(lambda (obj)
  112.        (superprint (list 'setq obj (list 'quote (userdef obj))))
  113.        (cond
  114.           ((plist obj)
  115.              (mapcar
  116.                 (plist obj)
  117.                 '(lambda (prop)
  118.                     (terpri)
  119.                     (cond
  120.                        ((consp prop)
  121.                           (superprint
  122.                              (list
  123.                                 'put
  124.                                 (list 'quote obj)
  125.                                 (list 'quote (car prop))
  126.                                 (list 'quote (cdr prop)))) )
  127.                        ((atom prop)
  128.                           (superprint
  129.                              (list
  130.                                 'flag
  131.                                 (list 'quote (list obj))
  132.                                 (list 'quote prop)))) ))) ))
  133.        (terpri)))
  134.  
  135. (setq makestring
  136.    '(lambda objs (progn (clearbuff) (mapcar objs 'pack) (mkstring))))
  137.  
  138. (setq *copyright* '"Simon Brooke 1988")
  139.  
  140. (flag '(*copyright*) 'fluid)
  141.  
  142. (setq *lambdatokens*
  143.    '("not code! " lambda lambdaq clambdaq clambda macro:))
  144.  
  145. (flag '(*lambdatokens*) 'fluid)
  146.  
  147.  
  148. (put
  149.    'writefile
  150.    'objects
  151.    '(addtoset flatten remove setfromlist usercalls userdef
  152.        userfnp writefile writeobject makestring *copyright*
  153.        *lambdatokens*))
  154.  
  155.