home *** CD-ROM | disk | FTP | other *** search
- %% File writefile2 created at 20:32:48 on 06-Nov-88 %%
-
- %% (c)Simon Brooke 1988 %%
-
- (setq addtoset
- '(lambda (obj set)
- (cond ((member obj set) set) (t (nconc set (list obj)))) ))
-
- (setq flatten
- '(lambda (l)
- (cond
- ((null l) nil)
- ((atom l) (list l))
- (t (nconc (flatten (car l)) (flatten (cdr l)))) )))
-
- (setq remove
- '(lambda (object list)
- (cond
- ((null list) nil)
- ((eq object (car list)) (remove object (cdr list)))
- (t (cons (car list) (remove object (cdr list)))) )))
-
- (setq setfromlist
- '(lambda (lst)
- (cond
- ((null lst) nil)
- ((member (car lst) (cdr lst)) (setfromlst (cdrlst)))
- (t (cons (car lst) (setfromlst (cdr lst)))) )))
-
- (setq usercalls
- '(lambda (fn)
- (remove nil (mapcar (flatten (userdef fn)) 'userfnp))))
-
- (setq userdef
- '(lambda (obj)
- (cond
- ((codep (eval obj)) (get obj 'savedef))
- (t (eval obj)))) )
-
- (setq userfnp
- '(lambda (object)
- (cond
- ((eq object '*lambdatokens*) nil)
- ((get object 'savedef) object)
- ((and
- (consp (eval object))
- (member (car (eval object)) *lambdatokens*))
- object))))
-
- (setq writefile
- '(lambda (fname objs)
- (let
- ((objects (or objs (get fname 'objects))))
- (cond
- ((null objects)
- (error 500 "No objects specified for file")))
- (cond
- ((member
- nil
- (mapcar
- objects
- '(lambda (obj)
- (get obj 'savedef)
- (or (boundp obj) (plist obj)))) )
- (error
- 501
- "Unbound object specified in file contents")))
- (let
- ((handle (open fname 'output)))
- (cond
- ((numberp
- (errorset
- (progn
- (print (list fname 'open))
- (wrs handle)
- (printc
- (makestring
- "%% File "
- fname
- " created at "
- (timeofday)
- " on "
- (date)
- " %%"))
- (cond
- (*copyright*
- (terpri)
- (princ "%% (c)")
- (princ *copyright*)
- (printc " %%")
- (terpri)))
- (mapcar objects 'writeobject)
- (terpri)
- (prettyprint
- (list
- 'put
- (list 'quote fname)
- (list 'quote 'objects)
- (list 'quote objects)))
- (wrs nil)
- (close handle)
- (set-date-stamp fname (binary-time)))
- 0))
- (wrs nil)
- (close handle)
- (error 502 "error while writing file"))
- (t fname))))
- fname))
-
- (setq writeobject
- '(lambda (obj)
- (superprint (list 'setq obj (list 'quote (userdef obj))))
- (cond
- ((plist obj)
- (mapcar
- (plist obj)
- '(lambda (prop)
- (terpri)
- (cond
- ((consp prop)
- (superprint
- (list
- 'put
- (list 'quote obj)
- (list 'quote (car prop))
- (list 'quote (cdr prop)))) )
- ((atom prop)
- (superprint
- (list
- 'flag
- (list 'quote (list obj))
- (list 'quote prop)))) ))) ))
- (terpri)))
-
- (setq makestring
- '(lambda objs (progn (clearbuff) (mapcar objs 'pack) (mkstring))))
-
- (setq *copyright* '"Simon Brooke 1988")
-
- (flag '(*copyright*) 'fluid)
-
- (setq *lambdatokens*
- '("not code! " lambda lambdaq clambdaq clambda macro:))
-
- (flag '(*lambdatokens*) 'fluid)
-
-
- (put
- 'writefile
- 'objects
- '(addtoset flatten remove setfromlist usercalls userdef
- userfnp writefile writeobject makestring *copyright*
- *lambdatokens*))
-
-