Return to ucido.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib

Annotation of 42BSD/ucb/lisp/lisplib/ucido.l, revision 1.1.1.1

1.1       root        1: (setq SCCS-ucido "@(#)ucido.l      1.3     6/29/81")
                      2: ;
                      3: ; ucilisp do loop,  this is a seperate file due to conflicts with
                      4: ;      the franz lisp do function.  To use this, one needs
                      5: ;      to load this file in at run time.  (And have calls to
                      6: ;      do be close compiled in compiled code).
                      7: ;
                      8: ;      NOTE: do is a macro and must be declared before calls to it
                      9: ;              in code to be compiled!
                     10: ;
                     11: ;      to compile this file: liszt ucido.l
                     12: ;
                     13: (declare (macros t))
                     14: 
                     15: (eval-when (compile)
                     16:   (load 'ucifnc))
                     17: 
                     18: (defun do macro (l)
                     19:   ((lambda (dotype alist)
                     20:           (cond ((eq dotype 'while)
                     21:                  (dowhile (car alist) (cdr alist)))
                     22:                 ((eq dotype 'until)
                     23:                  (dowhile (list 'not (car alist))
                     24:                           (cdr alist)))
                     25:                 ((eq dotype 'for)
                     26:                  (dofor (car alist) 
                     27:                         (cadr alist)
                     28:                         (caddr alist)
                     29:                         (cdddr alist)))
                     30:                 (t `((lambda ()
                     31:                              ,@alist)))))
                     32:    (cadr l)
                     33:    (cddr l)))
                     34: 
                     35: (defun dowhile (expr alist)
                     36:   `(prog (returnvar)
                     37:         loop
                     38:         (cond (,expr
                     39:                (setq returnvar ((lambda ()
                     40:                                         ,@alist)))
                     41:                (go loop))
                     42:               (t (return returnvar)))))
                     43: 
                     44: (defun dofor (var fortype varlist stmlist)
                     45:   (selectq fortype 
                     46:           (in `(prog (returnvar l1 l2)
                     47:                      (setq l2 ',varlist)
                     48:                      loop
                     49:                      (setq l1 (car l2))
                     50:                      (setq l2 (cdr l2))
                     51:                      (cond ((null l1) 
                     52:                             (return returnvar)))
                     53:                      (setq returnvar
                     54:                            ((lambda (,var)
                     55:                                     ,@stmlist)
                     56:                             (l1)))
                     57:                      (go loop)))
                     58:           (on `(prog (returnvar l1 l2)
                     59:                      (setq l2 ',varlist)
                     60:                      loop
                     61:                      (cond ((null l2) 
                     62:                             (return returnvar)))
                     63:                      (setq returnvar
                     64:                            ((lambda (,var)
                     65:                                     ,@stmlist)
                     66:                             (l2)))
                     67:                      (setq l2 (cdr l2))
                     68:                      (go loop)))
                     69:           (rpt `(prog (returnvar ,var)
                     70:                       (setq ,var 1)
                     71:                       loop
                     72:                       (cond ((not (> ,var ,varlist))
                     73:                              (setq returnvar ((lambda ()
                     74:                                                       ,@stmlist)))
                     75:                              (setq ,var (1+ ,var))
                     76:                              (go loop))
                     77:                             (t (return returnvar)))))
                     78:           nil))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.